diff --git a/README.md b/README.md index 0be8c760..6a8f13d0 100644 --- a/README.md +++ b/README.md @@ -1,12 +1,14 @@ # Medley -This repository is for the Lisp environment of [Medley](https://interlisp.org). +The [Medley Interlisp Project](https://interlisp.org) aims to preserve, revive, and modernize the [Interlisp](https://interlisp.org) software development environment for rapid prototyping, research and Artificial Intelligence created at Xerox PARC since the 1970s. -[Install and Run](https://interlisp.org/software/install-and-run) covers ways to install and start up Medley on Linux systems, MacOS, and Windows (with or without WSL). +This repository is for the Lisp environment of the [Medley](https://interlisp.org) release of Interlisp. Other repositories hold additional subsystems and applications such as [Maiko](https://github.com/Interlisp/maiko), the implementation (in C) of the Medley virtual machine, the [LOOPS](https://github.com/Interlisp/loops) object-oriented extension of Interlisp, and the [NoteCards](https://github.com/Interlisp/notecards) hypermedia system. + +[Install and Run](https://interlisp.org/software/install-and-run) covers ways to install and start up Medley on Linux systems, MacOS, Windows (with or without WSL), and in a web browser. [Using Medley](https://interlisp.org/software/using-medley/) has an overview and pointers to documentation. -[Interlisp/maiko](https://github.com/Interlisp/maiko), is the repo for the implementation (in C) of the Medley virtual machine. +The [Glossary](https://interlisp.org/history/glossary) defines system-specific terms such as "loadup" and "sysout". ## Releases @@ -67,25 +69,9 @@ If you have a high-resolution display, note that much of the graphics was design Medley presumes you have a 3-button mouse; the scroll-wheel on some mice acts as one, with some difficulty. Go into XQuartz Preferences/Input and check "Emulate three button mouse" option. -### Running Medley Interlisp (obsolete) +### Running Medley Interlisp -The `run-medley` script in this repo sets up some convenient defaults. Running Medley can be done by typing: -``` -$ cd medley -$ ./run-medley -``` - -Or, if you wish to start Medley up with a different SYSOUT: - -``` -$ cd medley -$ ./run-medley -``` -The first time the system is run it loads the system image that comes -with the system. When you exit the system (or "do a `SaveVM`" menu -option) the state of your machine is saved in a file named -`~/lisp.virtualmem`. Subsequent system startups load the -`~/lisp.virtualmem` image by default. +The primer [Medley Interlisp for the Newcomer](https://primer.interlisp.org) eases new users into the Interlisp environment. It assumes no prior knowledge of Lisp and covers the user interface, programming and debugging, windows and graphics, and more. We recommend consulting this document to learn how to run and use the system. ### Exiting The System @@ -123,7 +109,7 @@ Each directory should have a README.md, but briefly * BUILDING.md -- instructions on how to make your own loadups * clos -- early implementation of Common Lisp Object System * CLTL2 -- files submitted to bring Medley up to the conformance to "Common Lisp, the Language" 2nd edition. Not enough to conform to the ANSI standard lisp. -* docs -- Documentation files (in TEdit format, PDFs, or online help; look [here](https://github.com/Interlisp/medley/Documentation)) +* docs -- Documentation files (in TEdit format, PDFs, or online help * fonts -- raster fonts (or font widths) in various resolutions for display, postscript, interpress, press formats * greetfiles -- various configuration setups * internal -- These _were_ internal to Venue diff --git a/greetfiles/APPS-INIT b/greetfiles/APPS-INIT index 21f74cec..defae498 100644 --- a/greetfiles/APPS-INIT +++ b/greetfiles/APPS-INIT @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "26-Nov-2025 12:30:08" {DSK}larry>il>MEDLEY>GREETFILES>APPS-INIT.;2 23361 +(FILECREATED " 1-Feb-2026 13:41:02" {WMEDLEY}APPS-INIT.;11 22926 - :EDIT-BY "lmm" + :EDIT-BY rmk - :CHANGES-TO (FNS Apps.CreateButtons) + :CHANGES-TO (FNS XCL-USER::EXEC¬INTERLISP) - :PREVIOUS-DATE "25-Feb-2024 13:56:23" {DSK}larry>il>MEDLEY>GREETFILES>APPS-INIT.;1) + :PREVIOUS-DATE " 1-Feb-2026 07:58:14" {WMEDLEY}APPS-INIT.;9) (PRETTYCOMPRINT APPS-INITCOMS) @@ -19,7 +19,7 @@ (Apps.RoomsActivated NIL)) (FNS Apps.InitNotecards Apps.SetUpNOTECARDSDIRECTORIES Apps.DoInit Apps.CreateButtons Apps.CreateLabel Apps.ActivateCLOS Apps.ActivateRooms Apps.ShowDoc - XCL-USER::EXEC_INTERLISP Apps.AroundExitFn) + XCL-USER::EXEC¬INTERLISP Apps.AroundExitFn) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (Apps.DoInit))) (DECLARE%: FIRST DONTEVAL@LOAD DOCOPY (P (BKSYSBUF " "]) @@ -35,52 +35,53 @@ (RPAQ? Apps.RoomsActivated NIL) (DEFINEQ -(Apps.InitNotecards +(Apps.InitNotecards [LAMBDA (DoNotRefreshButtons) - (DECLARE (GLOBALVARS BackgroundMenuCommands BackgroundMenu)) - (* ; "Edited 19-Jan-2023 11:57 by FGH") - (* ; "Edited 7-Dec-2022 11:14 by FGH") - (* ; "Edited 12-Nov-2022 14:41 by FGH") - (* ; "Edited 11-Sep-2022 01:09 by fgh") - (* ; "Edited 7-Feb-2022 20:22 by tp7") + (DECLARE (GLOBALVARS BackgroundMenuCommands BackgroundMenu)) + (* ; "Edited 1-Feb-2026 00:00 by rmk") + (* ; "Edited 19-Jan-2023 11:57 by FGH") + (* ; "Edited 7-Dec-2022 11:14 by FGH") + (* ; "Edited 12-Nov-2022 14:41 by FGH") + (* ; "Edited 11-Sep-2022 01:09 by fgh") + (* ; "Edited 7-Feb-2022 20:22 by tp7") (LET* [[SRCDIR (OR (UNIX-GETENV 'NOTEFILESSRC) - (AND (UNIX-GETENV 'NC_INSTALLDIR) - (CONCAT (UNIX-GETENV 'NC_INSTALLDIR) + (AND (UNIX-GETENV 'NC¬INSTALLDIR) + (CONCAT (UNIX-GETENV 'NC¬INSTALLDIR) "/notefiles")) (LET ((SUBDIR "notecards/notefiles")) - (for DIR in (LIST (CONCAT (MEDLEYDIR) + (for DIR in (LIST (CONCAT (MEDLEYDIR) SUBDIR) (CONCAT (MEDLEYDIR) "../" SUBDIR) (CONCAT (MEDLEYDIR) - "../../" SUBDIR)) thereis (DIRECTORYNAME DIR] + "../../" SUBDIR)) thereis (DIRECTORYNAME DIR] (DESTDIR (OR (UNIX-GETENV 'NOTEFILESDIR) - (AND (UNIX-GETENV 'MEDLEY_USERDIR) - (CONCAT (UNIX-GETENV 'MEDLEY_USERDIR) + (AND (UNIX-GETENV 'MEDLEY¬USERDIR) + (CONCAT (UNIX-GETENV 'MEDLEY¬USERDIR) "/notefiles")) (CONCAT LOGINDIR "notefiles"] - [if (AND (NOT (DIRECTORYNAME DESTDIR)) + [if (AND (NOT (DIRECTORYNAME DESTDIR)) (DIRECTORYNAME SRCDIR)) - then (for NF in (DIRECTORY (CONCAT SRCDIR "/*")) - do (COPYFILE NF (PACKFILENAME 'HOST "DSK" 'DIRECTORY DESTDIR 'NAME + then (for NF in (DIRECTORY (CONCAT SRCDIR "/*")) + do (COPYFILE NF (PACKFILENAME 'HOST "DSK" 'DIRECTORY DESTDIR 'NAME (FILENAMEFIELD NF 'NAME) 'EXTENSION (FILENAMEFIELD NF 'EXTENSION) 'VERSION (FILENAMEFIELD NF 'VERSION] (LET* ((PW-REGION (WINDOWPROP PROMPTWINDOW 'REGION)) - (LEFT (IPLUS (fetch (REGION RIGHT) of PW-REGION) + (LEFT (IPLUS (fetch (REGION RIGHT) of PW-REGION) 20)) - (BOTTOM (fetch (REGION BOTTOM) of PW-REGION))) - (NC.BringUpNoteCardsIcon (create POSITION + (BOTTOM (fetch (REGION BOTTOM) of PW-REGION))) + (NC.BringUpNoteCardsIcon (create POSITION XCOORD _ LEFT YCOORD _ BOTTOM))) (NC.FileBrowserMenu NC.NoteCardsIconWindow (PACKFILENAME 'HOST "DSK" 'DIRECTORY DESTDIR 'NAME "*" 'EXTENSION "notefile") (CREATEREGION 50 (IDIFFERENCE SCREENHEIGHT 700) 550 220)) - (if (NULL (SASSOC 'NoteCards BackgroundMenuCommands)) - then (PROGN [SETQ BackgroundMenuCommands (APPEND BackgroundMenuCommands + (if (NULL (SASSOC 'NoteCards BackgroundMenuCommands)) + then (PROGN [SETQ BackgroundMenuCommands (APPEND BackgroundMenuCommands (LIST '(NoteCards ( NC.BringUpNoteCardsIcon ) @@ -89,59 +90,61 @@ ] (SETQ BackgroundMenu NIL))) (SETQ Apps.NotecardsActivated T) - (if (NOT DoNotRefreshButtons) - then (Apps.CreateButtons]) + (if (NOT DoNotRefreshButtons) + then (Apps.CreateButtons]) -(Apps.SetUpNOTECARDSDIRECTORIES +(Apps.SetUpNOTECARDSDIRECTORIES [LAMBDA NIL - (* ;; "Find the location of the Notecards directory and call NC.SetUpNOTECARDSDIRECTORIES.") + (* ;; "Find the location of the Notecards directory and call NC.SetUpNOTECARDSDIRECTORIES.") - (* ;; " This is needed to make sure that lazy loading of Notecard types works.") + (* ;; " This is needed to make sure that lazy loading of Notecard types works.") (LET* [(LOC1 (CONCAT MEDLEYDIR "notecards>")) (LOC2 (CONCAT MEDLEYDIR "..>notecards>")) (LOC3 (CONCAT MEDLEYDIR "..>..>notecards>")) - (NCDIR (for LOC in (LIST LOC1 LOC2 LOC3) thereis (OR (INFILEP (CONCAT LOC + (NCDIR (for LOC in (LIST LOC1 LOC2 LOC3) thereis (OR (INFILEP (CONCAT LOC "system>NOTECARDS")) (INFILEP (CONCAT LOC "system>NOTECARDS.LCOM" ] - (if NCDIR - then [SETQ NCDIR (OR (INFILEP (CONCAT NCDIR "system>NOTECARDS")) + (if NCDIR + then [SETQ NCDIR (OR (INFILEP (CONCAT NCDIR "system>NOTECARDS")) (INFILEP (CONCAT NCDIR "system>NOTECARDS.LCOM"] (SETQ NCDIR (SUBSTRING NCDIR 1 (IDIFFERENCE (STRPOS "system>NOTECARDS" NCDIR) 1))) (NC.SetUpNOTECARDSDIRECTORIES NCDIR) T - else (PRIN1 "Warning: Notecards directory could not be found." T) + else (PRIN1 "Warning: Notecards directory could not be found." T) (PRIN1 "Hence, NOTECARDSDIRECTORIES is probably not set correctly" T) (PRIN1 "and Notecards will not work properly." T) NIL]) -(Apps.DoInit +(Apps.DoInit [LAMBDA NIL - (* ;; "Edited 19-Jan-2023 12:43 by FGH") + (* ;; "Edited 31-Jan-2026 23:57 by rmk") - (* ;; "Edited 17-Jan-2023 23:23 by FGH") + (* ;; "Edited 19-Jan-2023 12:43 by FGH") - (* ;; "Edited 7-Dec-2022 11:14 by FGH") + (* ;; "Edited 17-Jan-2023 23:23 by FGH") - (* ;; "Edited 12-Nov-2022 13:57 by FGH") + (* ;; "Edited 7-Dec-2022 11:14 by FGH") - (* ;; "Edited 12-Oct-2022 20:23 by fgh") + (* ;; "Edited 12-Nov-2022 13:57 by FGH") - (* ;; "Edited 6-Sep-2022 17:22 by fgh") + (* ;; "Edited 12-Oct-2022 20:23 by fgh") - (* ;; "Edited 4-Sep-2022 16:44 by larry") + (* ;; "Edited 6-Sep-2022 17:22 by fgh") - (* ;; "Edited 18-Mar-2022 18:53 by fgh") + (* ;; "Edited 4-Sep-2022 16:44 by larry") - (* ;; "Edited 17-Dec-2021 22:05 by fgh") + (* ;; "Edited 18-Mar-2022 18:53 by fgh") + + (* ;; "Edited 17-Dec-2021 22:05 by fgh") (PROGN - (* ;; " Adjust windows so that the exec window and the prompt window don't overlap") + (* ;; " Adjust windows so that the exec window and the prompt window don't overlap") [MAPC (OPENWINDOWS) (FUNCTION (LAMBDA (W) @@ -152,90 +155,92 @@ (IDIFFERENCE SCREENHEIGHT 18))) ((STREQUAL (WINDOWPROP W 'TITLE) "Prompt Window") - (PROGN (MOVEW W (create POSITION + (PROGN (MOVEW W (create POSITION XCOORD _ 50 YCOORD _ (IDIFFERENCE SCREENHEIGHT 120))) (CLEARW W))) ((STREQUAL (WINDOWPROP W 'TITLE) "Exec (XCL)") (PROGN (WINDOWPROP W 'TITLE "Exec (INTERLISP)") - (MOVEW W (create POSITION + (MOVEW W (create POSITION XCOORD _ 50 YCOORD _ (IDIFFERENCE SCREENHEIGHT 460] - (* ;; " Set up INITIALSLST based on information passed in from the Linux environment") + (* ;; " Set up INITIALSLST based on information passed in from the Linux environment") - [SETQ INITIALSLST (LIST (LIST USERNAME (UNIX-GETENV 'MEDLEY_FIRSTNAME) - (UNIX-GETENV 'MEDLEY_INITIALS] + [SETQ INITIALSLST (LIST (LIST USERNAME (UNIX-GETENV 'MEDLEY¬FIRSTNAME) + (UNIX-GETENV 'MEDLEY¬INITIALS] (LOAD '{DSK}/usr/local/interlisp/medley/lispusers/HELPSYS.LCOM T) - (* ;; "change to interlisp exec if required") + (* ;; "change to interlisp exec if required") (COND - ((OR (STRING-EQUAL (UNIX-GETENV 'MEDLEY_EXEC) + ((OR (STRING-EQUAL (UNIX-GETENV 'MEDLEY¬EXEC) "inter") (STRING-EQUAL (UNIX-GETENV 'NCO) "true")) - (BKSYSBUF "(EXEC_INTERLISP)"))) + (BKSYSBUF "(EXEC¬INTERLISP)"))) - (* ;; "Always Activate CLOS") + (* ;; "Always Activate CLOS") - (Apps.ActivateCLOS) + (Apps.ActivateCLOS) - (* ;; " activate Notecards if requested") + (* ;; " activate Notecards if requested") (COND - ((STRING-EQUAL (UNIX-GETENV 'RUN_NOTECARDS) + ((STRING-EQUAL (UNIX-GETENV 'RUN¬NOTECARDS) "true") - (Apps.InitNotecards T))) + (Apps.InitNotecards T))) - (* ;; " activate Rooms if requested") + (* ;; " activate Rooms if requested") (COND - ((STRING-EQUAL (UNIX-GETENV 'RUN_ROOMS) + ((STRING-EQUAL (UNIX-GETENV 'RUN¬ROOMS) "true") - (Apps.ActivateRooms T))) + (Apps.ActivateRooms T))) - (* ;; " create the Documentation and ROOMS, Notecards Activation Buttons, if needed") + (* ;; " create the Documentation and ROOMS, Notecards Activation Buttons, if needed") - (Apps.CreateButtons T) + (Apps.CreateButtons T) - (* ;; " Make sure Notecards doesn't try to load its HASH file in NC.PostGreet") + (* ;; " Make sure Notecards doesn't try to load its HASH file in NC.PostGreet") (SETTOPVAL '\NC.SourceAccessFlg NIL) - (* ;; "Setup NOTECARDSDIRECTORIES.") + (* ;; "Setup NOTECARDSDIRECTORIES.") - (Apps.SetUpNOTECARDSDIRECTORIES) + (Apps.SetUpNOTECARDSDIRECTORIES) - (* ;; "Add AROUNDEXITFN to ensure NOTECARDSDIRECTORIES get reset after LOGOUT, etc.") + (* ;; "Add AROUNDEXITFN to ensure NOTECARDSDIRECTORIES get reset after LOGOUT, etc.") (SETQ AROUNDEXITFNS (LSUBST '(MEDLEY-INIT-VARS Apps.AroundExitFn) 'MEDLEY-INIT-VARS AROUNDEXITFNS]) -(Apps.CreateButtons - [LAMBDA (DoDocsToo) (* ; "Edited 26-Nov-2025 12:29 by lmm") - (* ; "Edited 13-Dec-2022 12:51 by frank") - (* ; "Edited 7-Dec-2022 11:28 by FGH") - (* ; "Edited 5-Dec-2022 17:31 by FGH") - (* ; "Edited 12-Nov-2022 14:52 by FGH") +(Apps.CreateButtons + [LAMBDA (DoDocsToo) (* ; "Edited 31-Jan-2026 23:59 by rmk") + (* ; "Edited 26-Nov-2025 12:29 by lmm") + (* ; "Edited 13-Dec-2022 12:51 by frank") + (* ; "Edited 7-Dec-2022 11:28 by FGH") + (* ; "Edited 5-Dec-2022 17:31 by FGH") + (* ; "Edited 12-Nov-2022 14:52 by FGH") - (* ;; " Create buttons for Documentation and to activate Rooms, Notecards ") + (* ;; " Create buttons for Documentation and to activate Rooms, Notecards ") - (* ;; "Note: due to bug in DELETE-BUTTON need to create Doc buttons last. This will make sure that the NoteCards/Rooms buttons get properl deleted when they are activated. But the Doc buttons will not necessariy get deleted properly (but then there is never a need for them to be deleted).") + (* ;; "Note: due to bug in DELETE-BUTTON need to create Doc buttons last. This will make sure that the NoteCards/Rooms buttons get properl deleted when they are activated. But the Doc buttons will not necessariy get deleted properly (but then there is never a need for them to be deleted).") - (LET* ((FEATURES (LIST (LIST Apps.NotecardsActivated '(Apps.InitNotecards) + + (LET* ((FEATURES (LIST (LIST Apps.NotecardsActivated '(Apps.InitNotecards) "NOTECARDS") - (LIST Apps.RoomsActivated '(Apps.ActivateRooms) + (LIST Apps.RoomsActivated '(Apps.ActivateRooms) "ROOMS"))) - (FEATURES-LABELS (for FEATURE in FEATURES collect (CADDR FEATURE))) + (FEATURES-LABELS (for FEATURE in FEATURES collect (CADDR FEATURE))) (DOCS (LIST (LIST "https://interlisp.org/docs/medley/orientation/" "BASICS") (LIST "https://primer.interlisp.org/" "PRIMER") (LIST "https://interlisp.org/documentation/IRM.pdf" "MANUAL") - (LIST "https://interlisp.org/documentation/notecards_user_guide_v1.2.pdf" + (LIST "https://interlisp.org/documentation/notecards¬user-guide¬v1.2.pdf" "NOTECARDS") (LIST "https://interlisp.org/documentation/ROOMSTECHDESC.pdf" "ROOMS"))) - (DOCS-LABELS (for DOC in DOCS collect (CADR DOC))) + (DOCS-LABELS (for DOC in DOCS collect (CADR DOC))) (RIGHTMARGINISH 140) (SECTION1YPOS 225) (YPOSDELTA 55) @@ -249,31 +254,31 @@ (IWS NIL) (BUTTONS NIL)) - (* ;; "First remove/re-create feature buttons") + (* ;; "First remove/re-create feature buttons") - (for W in (OPENWINDOWS) when (MEMBER (WINDOWPROP W 'ICONLABEL) - (LIST "ACTIVATE" "FEATURES")) do (CLOSEW W)) - (for B in *ALL-BUTTONS* when (AND (EQ (WINDOWPROP B 'Apps.BUTTON) + (for W in (OPENWINDOWS) when (MEMBER (WINDOWPROP W 'ICONLABEL) + (LIST "ACTIVATE" "FEATURES")) do (CLOSEW W)) + (for B in *ALL-BUTTONS* when (AND (EQ (WINDOWPROP B 'Apps.BUTTON) 'FEATURE) (MEMBER (BUTTON-LABEL B) - FEATURES-LABELS)) do (DELETE-BUTTON B)) - [if FEATURES-REQUIREDP - then [SETQ IWS (LIST (Apps.CreateLabel "ACTIVATE" (IDIFFERENCE SCREENWIDTH + FEATURES-LABELS)) do (DELETE-BUTTON B)) + [if FEATURES-REQUIREDP + then [SETQ IWS (LIST (Apps.CreateLabel "ACTIVATE" (IDIFFERENCE SCREENWIDTH (IDIFFERENCE RIGHTMARGINISH 50 )) (IDIFFERENCE SCREENHEIGHT (IDIFFERENCE SECTION2YPOS 20))) - (Apps.CreateLabel "FEATURES" (IDIFFERENCE SCREENWIDTH + (Apps.CreateLabel "FEATURES" (IDIFFERENCE SCREENWIDTH (IDIFFERENCE RIGHTMARGINISH 50 )) (IDIFFERENCE SCREENHEIGHT SECTION2YPOS] - (SETQ BUTTONS (for FEATURE in FEATURES - collect (OR (CAR FEATURE) + (SETQ BUTTONS (for FEATURE in FEATURES + collect (OR (CAR FEATURE) (LET (B) (SETQ BUTTONY-FEATURES (IPLUS BUTTONY-FEATURES YPOSDELTA)) [SETQ B (CREATE-BUTTON (CADR FEATURE) (CADDR FEATURE) - (create POSITION + (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH RIGHTMARGINISH) @@ -284,30 +289,30 @@ (WINDOWPROP B 'Apps.BUTTON 'FEATURE) B] - (* ;; "Then if needed, remove/recreate documentation buttons") + (* ;; "Then if needed, remove/recreate documentation buttons") - (if DoDocsToo - then (for W in (OPENWINDOWS) when (MEMBER (WINDOWPROP W 'ICONLABEL) + (if DoDocsToo + then (for W in (OPENWINDOWS) when (MEMBER (WINDOWPROP W 'ICONLABEL) (LIST "DOCUMENTATION")) - do (CLOSEW W)) - (for B in *ALL-BUTTONS* when (AND (EQ (WINDOWPROP B 'Apps.BUTTON) + do (CLOSEW W)) + (for B in *ALL-BUTTONS* when (AND (EQ (WINDOWPROP B 'Apps.BUTTON) 'DOC) (MEMBER (BUTTON-LABEL B) - DOCS-LABELS)) do (DELETE-BUTTON B)) - (SETQ IWS (CONS (Apps.CreateLabel "DOCUMENTATION" (IDIFFERENCE SCREENWIDTH + DOCS-LABELS)) do (DELETE-BUTTON B)) + (SETQ IWS (CONS (Apps.CreateLabel "DOCUMENTATION" (IDIFFERENCE SCREENWIDTH (IDIFFERENCE RIGHTMARGINISH 50) ) (IDIFFERENCE SCREENHEIGHT SECTION1YPOS)) IWS)) - (SETQ BUTTONS (APPEND (for DOC in DOCS - collect (LET (B) + (SETQ BUTTONS (APPEND (for DOC in DOCS + collect (LET (B) (SETQ BUTTONY-DOCS (IPLUS BUTTONY-DOCS YPOSDELTA)) [SETQ B (CREATE-BUTTON (LIST 'Apps.ShowDoc (CAR DOC)) (CADR DOC) - (create POSITION + (create POSITION XCOORD _ (IDIFFERENCE SCREENWIDTH @@ -319,30 +324,30 @@ (WINDOWPROP B 'Apps.BUTTON 'DOC) B)) BUTTONS))) - [for B in BUTTONS do (COND + [for B in BUTTONS do (COND ((WINDOWP B) (WINDOWPROP B 'RIGHTBUTTONFN 'NILL) (WINDOWPROP B 'BUTTONEVENTFN (FUNCTION (LAMBDA (BUTTON) - (if (LASTMOUSESTATE + (if (LASTMOUSESTATE (ONLY LEFT)) - then (EXECUTE-BUTTON + then (EXECUTE-BUTTON BUTTON] - [for IW in IWS do (COND + [for IW in IWS do (COND ((WINDOWP IW) (WINDOWPROP IW 'RIGHTBUTTONFN 'NILL] - (for B in BUTTONS when (WINDOWP B) collect B]) + (for B in BUTTONS when (WINDOWP B) collect B]) -(Apps.CreateLabel - [LAMBDA (Text CenterX BottomY) (* ; "Edited 5-Dec-2022 16:49 by FGH") +(Apps.CreateLabel + [LAMBDA (Text CenterX BottomY) (* ; "Edited 5-Dec-2022 16:49 by FGH") (LET* ((DS (DSPCREATE)) (FONT (DSPFONT '(HELVETICA 18 BOLD) DS)) (SR (STRINGREGION Text DS)) - (BMW (fetch (REGION WIDTH) of SR)) - (BMH (IPLUS (fetch (REGION HEIGHT) of SR) - (fetch (REGION BOTTOM) of SR))) + (BMW (fetch (REGION WIDTH) of SR)) + (BMH (IPLUS (fetch (REGION HEIGHT) of SR) + (fetch (REGION BOTTOM) of SR))) (BM (BITMAPCREATE BMW BMH)) - (POS (create POSITION + (POS (create POSITION XCOORD _ (IDIFFERENCE CenterX (IQUOTIENT BMW 2)) YCOORD _ BottomY)) IW) @@ -352,12 +357,12 @@ (WINDOWPROP IW 'ICONLABEL Text) IW]) -(Apps.ActivateCLOS +(Apps.ActivateCLOS [LAMBDA NIL - (DECLARE (GLOBALVARS BackgroundMenuCommands BackgroundMenu)) - (* ; "Edited 12-Nov-2022 14:41 by FGH") - (if (NULL (SASSOC "CLOS Browse Class" BackgroundMenuCommands)) - then (PROGN [SETQ BackgroundMenuCommands + (DECLARE (GLOBALVARS BackgroundMenuCommands BackgroundMenu)) + (* ; "Edited 12-Nov-2022 14:41 by FGH") + (if (NULL (SASSOC "CLOS Browse Class" BackgroundMenuCommands)) + then (PROGN [SETQ BackgroundMenuCommands (APPEND BackgroundMenuCommands (LIST '("CLOS Browse Class" (CLOS-BROWSER::BROWSE-CLASS) "Bring up a class browser." @@ -372,27 +377,27 @@ ] (SETQ BackgroundMenu NIL]) -(Apps.ActivateRooms +(Apps.ActivateRooms [LAMBDA (DoNotRefreshButtons) - (DECLARE (GLOBALVARS BackgroundMenuCommands ROOMS:*SUITE-DIRECTORIES*)) - (* ; "Edited 7-Dec-2022 11:13 by FGH") - (* ; "Edited 12-Nov-2022 14:56 by FGH") - (if (NULL (SASSOC "Rooms" BackgroundMenuCommands)) - then (ROOMS:RESET)) - (SETQ ROOMS:*SUITE-DIRECTORIES* (CONS (CONCAT (UNIX-GETENV 'MEDLE_USERDIR) + (DECLARE (GLOBALVARS BackgroundMenuCommands ROOMS:*SUITE-DIRECTORIES*)) + (* ; "Edited 7-Dec-2022 11:13 by FGH") + (* ; "Edited 12-Nov-2022 14:56 by FGH") + (if (NULL (SASSOC "Rooms" BackgroundMenuCommands)) + then (ROOMS:RESET)) + (SETQ ROOMS:*SUITE-DIRECTORIES* (CONS (CONCAT (UNIX-GETENV 'MEDLEY¬USERDIR) "/suites") ROOMS:*SUITE-DIRECTORIES*)) (SETQ Apps.RoomsActivated T) (PROMPTPRINT " ROOMS functionality is now available via the Background Menu") - (if (NOT DoNotRefreshButtons) - then (Apps.CreateButtons]) + (if (NOT DoNotRefreshButtons) + then (Apps.CreateButtons]) -(Apps.ShowDoc - [LAMBDA (URL) (* ; "Edited 18-Jan-2023 20:26 by FGH") +(Apps.ShowDoc + [LAMBDA (URL) (* ; "Edited 18-Jan-2023 20:26 by FGH") (ShellBrowse URL]) -(XCL-USER::EXEC_INTERLISP +(XCL-USER::EXEC¬INTERLISP [LAMBDA NIL (* ; "Edited 18-Mar-2022 18:53 by fgh") (PROGN [MAPC (OPENWINDOWS) (FUNCTION (LAMBDA (W) @@ -406,10 +411,10 @@ (XCL:SET-DEFAULT-EXEC-TYPE 'INTERLISP) (XCL:SET-EXEC-TYPE 'INTERLISP]) -(Apps.AroundExitFn +(Apps.AroundExitFn [LAMBDA (EVENT) - (if (MEMB EVENT '(AFTERLOGOUT AFTERSYSOUT AFTERSAVEVM)) - then (Apps.SetUpNOTECARDSDIRECTORIES]) + (if (MEMB EVENT '(AFTERLOGOUT AFTERSYSOUT AFTERSAVEVM)) + then (Apps.SetUpNOTECARDSDIRECTORIES]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY @@ -420,8 +425,8 @@ (BKSYSBUF " ") ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1184 23227 (Apps.InitNotecards 1194 . 5056) (Apps.SetUpNOTECARDSDIRECTORIES 5058 . 6613 -) (Apps.DoInit 6615 . 10212) (Apps.CreateButtons 10214 . 19123) (Apps.CreateLabel 19125 . 19935) ( -Apps.ActivateCLOS 19937 . 21286) (Apps.ActivateRooms 21288 . 22139) (Apps.ShowDoc 22141 . 22290) ( -XCL-USER::EXEC_INTERLISP 22292 . 23064) (Apps.AroundExitFn 23066 . 23225))))) + (FILEMAP (NIL (1153 22792 (Apps.InitNotecards 1163 . 5006) (Apps.SetUpNOTECARDSDIRECTORIES 5008 . 6527 +) (Apps.DoInit 6529 . 10067) (Apps.CreateButtons 10069 . 18820) (Apps.CreateLabel 18822 . 19592) ( +Apps.ActivateCLOS 19594 . 20919) (Apps.ActivateRooms 20921 . 21730) (Apps.ShowDoc 21732 . 21871) ( +XCL-USER::EXEC¬INTERLISP 21873 . 22645) (Apps.AroundExitFn 22647 . 22790))))) STOP diff --git a/greetfiles/APPS-INIT.LCOM b/greetfiles/APPS-INIT.LCOM index bcf9748c..bfde24fd 100644 Binary files a/greetfiles/APPS-INIT.LCOM and b/greetfiles/APPS-INIT.LCOM differ diff --git a/internal/TEDIT-DEBUG b/internal/TEDIT-DEBUG index 32b6966f..7b08db5c 100644 --- a/internal/TEDIT-DEBUG +++ b/internal/TEDIT-DEBUG @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "13-Oct-2025 16:52:28" {WMEDLEY}TEDIT-DEBUG.;175 138298 +(FILECREATED " 7-Feb-2026 17:00:39" {WMEDLEY}TEDIT-DEBUG.;178 138742 :EDIT-BY rmk - :CHANGES-TO (FNS SP) + :CHANGES-TO (FNS TEDIT-DEBUG) - :PREVIOUS-DATE "29-Jul-2025 11:42:21" {WMEDLEY}TEDIT-DEBUG.;174) + :PREVIOUS-DATE " 7-Feb-2026 10:41:45" {WMEDLEY}TEDIT-DEBUG.;177) (PRETTYCOMPRINT TEDIT-DEBUGCOMS) @@ -540,7 +540,8 @@ (RETURN PC]) (SL - [LAMBDA (FIRSTLINE LASTLINE PANE TOBJ OFILE) (* ; "Edited 17-Apr-2025 13:36 by rmk") + [LAMBDA (FIRSTLINE LASTLINE PANE TOBJ OFILE) (* ; "Edited 9-Jan-2026 11:12 by rmk") + (* ; "Edited 17-Apr-2025 13:36 by rmk") (* ; "Edited 15-Apr-2025 13:57 by rmk") (* ; "Edited 11-Apr-2025 12:15 by rmk") (* ; "Edited 29-Mar-2025 20:27 by rmk") @@ -580,6 +581,7 @@ (SETQ PANE (pop LINES)) (SETQ PNO (pop LINES)) (DEBUGOUTPUT (DEBUGOUTPUT.STREAM OFILE WTYPE TITLE NIL '(TERMINAL 8)) + (RESETSAVE (LINELENGTH MAX.SMALLP OFILE)) (PRINTOUT OFILE .FONT '(TERMINAL 8) "Pane " PNO " = " PANE T) (PRINTOUT OFILE .FONT '(TERMINAL 8) @@ -805,7 +807,8 @@ else (RETURN OUTFILE))))]) (SHOWLINE - [LAMBDA (LINE FILE TEXTOBJ) (* ; "Edited 20-Nov-2024 00:31 by rmk") + [LAMBDA (LINE FILE TEXTOBJ) (* ; "Edited 9-Jan-2026 11:09 by rmk") + (* ; "Edited 20-Nov-2024 00:31 by rmk") (* ; "Edited 17-Nov-2024 15:56 by rmk") (* ; "Edited 9-Nov-2024 10:37 by rmk") (* ; "Edited 1-Sep-2024 16:49 by rmk") @@ -836,7 +839,7 @@ "*" " ") .FONT - '(TERMINAL 6) + '(TERMINAL 8) " ") (if (GETLD LINE LDUMMY) then (PRINTOUT FILE -8 (CL:IF (GETLD LINE LDUMMY) @@ -2480,7 +2483,8 @@ (DEFINEQ (TEDIT-DEBUG - [LAMBDA (DONTOVERLOAD) (* ; "Edited 9-Aug-2024 13:20 by rmk") + [LAMBDA (DONTOVERLOAD) (* ; "Edited 7-Feb-2026 17:00 by rmk") + (* ; "Edited 9-Aug-2024 13:20 by rmk") (* ; "Edited 16-Jul-2024 12:37 by rmk") (* ; "Edited 6-Jul-2024 21:16 by rmk") (* ; "Edited 10-Jun-2024 14:21 by rmk") @@ -2493,6 +2497,7 @@ (* ; "Edited 3-Dec-2023 21:00 by rmk") (* ; "Edited 29-Nov-2023 10:49 by rmk") (* ; "Edited 24-Nov-2023 12:53 by rmk") + (DRIBBLE "TEDIT-DEBUG.DRIBBLE") (CL:WHEN (DIRECTORYNAMEP (MEDLEYDIR "../oldtedit/")) (PSEUDOHOST 'OT (MEDLEYDIR "../oldtedit/"))) (FILESLOAD (NOERROR FROM LOADUPS) @@ -2511,7 +2516,8 @@ (FILESLOAD (NOERROR) {OT}OTWHEREIS) (PRINTOUT T T "Connected to " (PSEUDOFILENAME (MEDLEYDIR "library/tedit")) - T]) + T) + (DRIBBLE]) ) (DEFINEQ @@ -2579,33 +2585,33 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (5115 7674 (GTO 5125 . 5375) (GTS 5377 . 7148) (GTW 7150 . 7306) (GSEL 7308 . 7672)) ( -7707 8828 (TEST.TEMPLATE 7717 . 8826)) (8829 9764 (TESTACTION 8839 . 9762)) (9789 23604 (IPC 9799 . -11303) (ILINES 11305 . 13846) (ISEL 13848 . 14459) (ITS 14461 . 16185) (IPANES 16187 . 16422) (ITL -16424 . 16843) (IHIST 16845 . 19507) (IPCTB 19509 . 19935) (IMB 19937 . 20696) (ICL 20698 . 21399) ( -IPL 21401 . 21941) (ICARET 21943 . 22470) (INSPECTPIECES 22472 . 23602)) (23626 52365 (SP 23636 . -28751) (SL 28753 . 32588) (SSP 32590 . 34292) (SPF 34294 . 36824) (SLF 36826 . 45959) (SHOWLINE 45961 - . 49523) (SLL 49525 . 50272) (STBYTES 50274 . 52000) (SSEL 52002 . 52363)) (52366 64879 (STL 52376 . -61377) (CLEARTHISLINE 61379 . 61859) (CHARSLOTP 61861 . 63180) (\TLVALIDATE 63182 . 64877)) (64880 -70253 (NTHPIECE 64890 . 66022) (NPIECES 66024 . 66889) (NTHPIECECHAR 66891 . 68199) (SELPIECE 68201 . -68643) (PIECENUM 68645 . 69364) (PCBYTES 69366 . 70251)) (70254 72728 (FILEBYTES 70264 . 71688) ( -TFILEBYTES 71690 . 72726)) (72729 74051 (TRELMOVE 72739 . 72982) (TSCROLL 72984 . 73150) (TSCROLL* -73152 . 74049)) (74052 77101 (TRY 74062 . 75331) (TEDITCLOSEW 75333 . 75676) (PARALASTWITHOUTEOL 75678 - . 76563) (FIXPARALAST 76565 . 77099)) (77102 91989 (SPPRINT 77112 . 83937) (SPPRINT.CHAR 83939 . -84923) (SPPRINT.OBJ 84925 . 87983) (SHOWPIECEBYTES 87985 . 89541) (CHECKPLENGTHS 89543 . 90000) (SBT -90002 . 91139) (COPYPCHAIN 91141 . 91987)) (91990 94051 (POSLINE 92000 . 94049)) (94052 94935 ( -PRESPLIT 94062 . 94933)) (94936 96649 (ALLTL 94946 . 96199) (NTHCHARSLOT 96201 . 96647)) (96675 106888 - (PLCHAIN 96685 . 97213) (PRINTLINE 97215 . 100205) (SL.GETLINES 100207 . 103500) (CHECKLINES 103502 - . 104482) (COLLECTLINES 104484 . 104736) (NTHLINE 104738 . 105743) (HEIGHT 105745 . 106033) (LINEBOTS - 106035 . 106886)) (106889 109337 (IPC.DECODEARGS 106899 . 109335)) (109338 109931 (SPF1 109348 . -109929)) (109960 112338 (SLF.FATPLEN 109970 . 110829) (FILEPIECE 110831 . 112336)) (112371 113139 ( -SELTEDIT 112381 . 113137)) (113209 118821 (PPARA 113219 . 113641) (PRUN 113643 . 115119) ( -ADDLINEPOSITIONS 115121 . 116548) (SBR 116550 . 117204) (SBC 117206 . 118819)) (118878 120654 (OLDWI -118888 . 119263) (COMP 119265 . 119460) (DFR 119462 . 120652)) (120655 121688 (DFGV 120665 . 121191) ( -GDIRECTORIES 121193 . 121686)) (121689 128254 (TTEST 121699 . 126231) (LTEST 126233 . 127598) (THC -127600 . 128252)) (128568 129260 (SHOWSAFE 128578 . 129258)) (129313 129760 (MYH 129323 . 129758)) ( -130005 131100 (DFVENUE 130015 . 130894) (VSEE 130896 . 131098)) (131101 131555 (PTT 131111 . 131553)) -(131914 133495 (DEBUGOUTPUT.STREAM 131924 . 133493)) (133496 135812 (TEDIT-DEBUG 133506 . 135810)) ( -135813 136305 (HEXTOHILO 135823 . 136163) (CW 136165 . 136303)) (136306 138042 (TRENAME 136316 . -138040))))) + (FILEMAP (NIL (5124 7683 (GTO 5134 . 5384) (GTS 5386 . 7157) (GTW 7159 . 7315) (GSEL 7317 . 7681)) ( +7716 8837 (TEST.TEMPLATE 7726 . 8835)) (8838 9773 (TESTACTION 8848 . 9771)) (9798 23613 (IPC 9808 . +11312) (ILINES 11314 . 13855) (ISEL 13857 . 14468) (ITS 14470 . 16194) (IPANES 16196 . 16431) (ITL +16433 . 16852) (IHIST 16854 . 19516) (IPCTB 19518 . 19944) (IMB 19946 . 20705) (ICL 20707 . 21408) ( +IPL 21410 . 21950) (ICARET 21952 . 22479) (INSPECTPIECES 22481 . 23611)) (23635 52650 (SP 23645 . +28760) (SL 28762 . 32764) (SSP 32766 . 34468) (SPF 34470 . 37000) (SLF 37002 . 46135) (SHOWLINE 46137 + . 49808) (SLL 49810 . 50557) (STBYTES 50559 . 52285) (SSEL 52287 . 52648)) (52651 65164 (STL 52661 . +61662) (CLEARTHISLINE 61664 . 62144) (CHARSLOTP 62146 . 63465) (\TLVALIDATE 63467 . 65162)) (65165 +70538 (NTHPIECE 65175 . 66307) (NPIECES 66309 . 67174) (NTHPIECECHAR 67176 . 68484) (SELPIECE 68486 . +68928) (PIECENUM 68930 . 69649) (PCBYTES 69651 . 70536)) (70539 73013 (FILEBYTES 70549 . 71973) ( +TFILEBYTES 71975 . 73011)) (73014 74336 (TRELMOVE 73024 . 73267) (TSCROLL 73269 . 73435) (TSCROLL* +73437 . 74334)) (74337 77386 (TRY 74347 . 75616) (TEDITCLOSEW 75618 . 75961) (PARALASTWITHOUTEOL 75963 + . 76848) (FIXPARALAST 76850 . 77384)) (77387 92274 (SPPRINT 77397 . 84222) (SPPRINT.CHAR 84224 . +85208) (SPPRINT.OBJ 85210 . 88268) (SHOWPIECEBYTES 88270 . 89826) (CHECKPLENGTHS 89828 . 90285) (SBT +90287 . 91424) (COPYPCHAIN 91426 . 92272)) (92275 94336 (POSLINE 92285 . 94334)) (94337 95220 ( +PRESPLIT 94347 . 95218)) (95221 96934 (ALLTL 95231 . 96484) (NTHCHARSLOT 96486 . 96932)) (96960 107173 + (PLCHAIN 96970 . 97498) (PRINTLINE 97500 . 100490) (SL.GETLINES 100492 . 103785) (CHECKLINES 103787 + . 104767) (COLLECTLINES 104769 . 105021) (NTHLINE 105023 . 106028) (HEIGHT 106030 . 106318) (LINEBOTS + 106320 . 107171)) (107174 109622 (IPC.DECODEARGS 107184 . 109620)) (109623 110216 (SPF1 109633 . +110214)) (110245 112623 (SLF.FATPLEN 110255 . 111114) (FILEPIECE 111116 . 112621)) (112656 113424 ( +SELTEDIT 112666 . 113422)) (113494 119106 (PPARA 113504 . 113926) (PRUN 113928 . 115404) ( +ADDLINEPOSITIONS 115406 . 116833) (SBR 116835 . 117489) (SBC 117491 . 119104)) (119163 120939 (OLDWI +119173 . 119548) (COMP 119550 . 119745) (DFR 119747 . 120937)) (120940 121973 (DFGV 120950 . 121476) ( +GDIRECTORIES 121478 . 121971)) (121974 128539 (TTEST 121984 . 126516) (LTEST 126518 . 127883) (THC +127885 . 128537)) (128853 129545 (SHOWSAFE 128863 . 129543)) (129598 130045 (MYH 129608 . 130043)) ( +130290 131385 (DFVENUE 130300 . 131179) (VSEE 131181 . 131383)) (131386 131840 (PTT 131396 . 131838)) +(132199 133780 (DEBUGOUTPUT.STREAM 132209 . 133778)) (133781 136256 (TEDIT-DEBUG 133791 . 136254)) ( +136257 136749 (HEXTOHILO 136267 . 136607) (CW 136609 . 136747)) (136750 138486 (TRENAME 136760 . +138484))))) STOP diff --git a/internal/TEDIT-DEBUG.LCOM b/internal/TEDIT-DEBUG.LCOM index f3afda41..7b7aa101 100644 Binary files a/internal/TEDIT-DEBUG.LCOM and b/internal/TEDIT-DEBUG.LCOM differ diff --git a/internal/loadups/LOADUP-APPS b/internal/loadups/LOADUP-APPS index ec4cde71..3e8cd112 100644 --- a/internal/loadups/LOADUP-APPS +++ b/internal/loadups/LOADUP-APPS @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 9-Mar-2025 20:03:27" {DSK}frank>il>medley>internal>loadups>LOADUP-APPS.;10 3274 +(FILECREATED " 1-Feb-2026 13:45:36" {WMEDLEY}loadups>LOADUP-APPS.;3 3343 - :EDIT-BY "frank" + :EDIT-BY rmk :CHANGES-TO (FNS LOADUP-APPS) - :PREVIOUS-DATE " 9-Mar-2025 19:42:36" {DSK}frank>il>medley>internal>loadups>LOADUP-APPS.;8 -) + :PREVIOUS-DATE " 9-Mar-2025 20:03:27" {WMEDLEY}loadups>LOADUP-APPS.;2) (PRETTYCOMPRINT LOADUP-APPSCOMS) @@ -21,7 +20,8 @@ (DEFINEQ (LOADUP-APPS - [LAMBDA NIL (* ; "Edited 9-Mar-2025 20:02 by frank") + [LAMBDA NIL (* ; "Edited 1-Feb-2026 13:45 by rmk") + (* ; "Edited 9-Mar-2025 20:02 by frank") (* ; "Edited 2-Jan-2025 20:38 by lmm") (* ; "Edited 2-Jan-2025 06:30 by larry") @@ -46,7 +46,7 @@ "/system")) NOTECARDS)) (Apps.RemoveBackgroundMenuItem 'NoteCards) (* ; "") - (PUTASSOC 'NOTECARDS (LIST (UNIX-GETENV 'NOTECARDS_COMMIT_ID)) + (PUTASSOC 'NOTECARDS (LIST (UNIX-GETENV 'NOTECARDS¬COMMIT¬ID)) SYSOUTCOMMITS) (* ;; "======================") @@ -78,7 +78,7 @@ (* ;; "") - (PUTASSOC 'MEDLEY (LIST (UNIX-GETENV 'LOADUP_COMMIT_ID)) + (PUTASSOC 'MEDLEY (LIST (UNIX-GETENV 'LOADUP¬COMMIT¬ID)) SYSOUTCOMMITS) (PRINTOUT T "commits-- " SYSOUTCOMMITS T]) @@ -95,5 +95,5 @@ Apps.SBG]) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (656 3251 (LOADUP-APPS 666 . 2579) (Apps.RemoveBackgroundMenuItem 2581 . 3249))))) + (FILEMAP (NIL (616 3320 (LOADUP-APPS 626 . 2648) (Apps.RemoveBackgroundMenuItem 2650 . 3318))))) STOP diff --git a/internal/loadups/LOADUP-APPS.LCOM b/internal/loadups/LOADUP-APPS.LCOM index 54800c0d..a35022b5 100644 Binary files a/internal/loadups/LOADUP-APPS.LCOM and b/internal/loadups/LOADUP-APPS.LCOM differ diff --git a/internal/loadups/LOADUP-FULL b/internal/loadups/LOADUP-FULL index 037dd5cd..f6289eff 100644 --- a/internal/loadups/LOADUP-FULL +++ b/internal/loadups/LOADUP-FULL @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "28-Dec-2025 12:06:12" {WMEDLEY}loadups>LOADUP-FULL.;35 5759 +(FILECREATED "14-Feb-2026 00:42:39" {WMEDLEY}loadups>LOADUP-FULL.;38 5967 :EDIT-BY rmk :CHANGES-TO (FNS LOADUP-FULL) - :PREVIOUS-DATE "20-Sep-2025 14:18:19" {WMEDLEY}loadups>LOADUP-FULL.;34) + :PREVIOUS-DATE "13-Feb-2026 00:47:52" {WMEDLEY}loadups>LOADUP-FULL.;37) (PRETTYCOMPRINT LOADUP-FULLCOMS) @@ -47,7 +47,9 @@ (PRINTOUT T "FULL fonts loaded" T]) (LOADUP-FULL - [LAMBDA (DRIBBLEFILE) (* ; "Edited 28-Dec-2025 12:06 by rmk") + [LAMBDA (DRIBBLEFILE) (* ; "Edited 14-Feb-2026 00:42 by rmk") + (* ; "Edited 5-Feb-2026 10:26 by rmk") + (* ; "Edited 28-Dec-2025 12:06 by rmk") (* ; "Edited 1-Sep-2025 11:59 by rmk") (* ; "Edited 18-Aug-2025 12:09 by rmk") (* ; "Edited 21-Jun-2025 23:33 by rmk") @@ -77,16 +79,16 @@ (DIRECTORYNAME T) T T) (* ; "For FONTSAVAILABLE lookup") (LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT") - (LOADFULLFONTS) (LISTPUT IDLE.PROFILE 'TIMEOUT 0) (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) (* ;; "RMK: 2025: PRESS was after CHAT") (LOADUP '(CHAT INTERPRESS TEDIT HRULE TEDIT-CHAT READNUMBER EDITBITMAP FILEBROWSER THINFILES - GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT ISO8859IO - HELPSYS DINFO CLIPBOARD MODERNIZE WHEELSCROLL PRETTYFILEINDEX WHO-LINE UNIXCOMM - UNIXCHAT UNIXYCD)) + GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT HELPSYS + DINFO CLIPBOARD MODERNIZE WHEELSCROLL PRETTYFILEINDEX WHO-LINE UNIXCOMM UNIXCHAT + UNIXYCD)) + (LOADFULLFONTS) (COND ((WINDOWP *WHO-LINE*) (CLOSEW *WHO-LINE*))) @@ -101,5 +103,5 @@ (FIXMETA) (DECLARE%: DONTCOPY - (FILEMAP (NIL (456 5721 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5471) (FIXMETA 5473 . 5719))))) + (FILEMAP (NIL (456 5929 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5679) (FIXMETA 5681 . 5927))))) STOP diff --git a/internal/loadups/LOADUP-FULL.LCOM b/internal/loadups/LOADUP-FULL.LCOM index 4b6d5511..b6d976e2 100644 Binary files a/internal/loadups/LOADUP-FULL.LCOM and b/internal/loadups/LOADUP-FULL.LCOM differ diff --git a/internal/loadups/LOADUP-LISP b/internal/loadups/LOADUP-LISP index 8eaa2a18..9d7dca17 100644 --- a/internal/loadups/LOADUP-LISP +++ b/internal/loadups/LOADUP-LISP @@ -1,13 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED " 3-Feb-2026 11:59:42"  -|{DSK}briggs>Projects>medley>internal>loadups>LOADUP-LISP.;12| 7475 +(FILECREATED "26-Mar-2026 18:38:22"  +|{DSK}briggs>Projects>medley>internal>loadups>LOADUP-LISP.;14| 7604 - :EDIT-BY |nhb| + :EDIT-BY "briggs" :CHANGES-TO (FNS LOADUP-LISP) - :PREVIOUS-DATE "28-Jan-2026 14:30:48" |{DSK}new-LOADUP-LISP.;1|) + :PREVIOUS-DATE "22-Feb-2026 14:15:31" +|{DSK}briggs>Projects>medley>internal>loadups>LOADUP-LISP.;13|) (PRETTYCOMPRINT LOADUP-LISPCOMS) @@ -20,7 +21,8 @@ (DEFINEQ (LOADUP-LISP - (LAMBDA (DRIBBLEFILE) (* \; "Edited 3-Feb-2026 11:59 by nhb") + (LAMBDA (DRIBBLEFILE) (* \; "Edited 26-Mar-2026 18:38 by briggs") + (* \; "Edited 22-Feb-2026 14:15 by rmk") (* \; "Edited 28-Jan-2026 14:30 by lmm") (* \; "Edited 27-Dec-2025 15:02 by rmk") (* \; "Edited 16-Oct-2025 16:55 by rmk") @@ -96,9 +98,9 @@ (* |;;| "Also, UNICODE is split into UNICODE-TABLES and UNICODE, so the tables are loaded before their MCCS/Uncode client functions are installed. Functions in UFS now depend on those translations so that filenames can have characters outside of Ascii. ") - (LOADUP '(UNICODE-TABLES UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU - WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL - DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN)) + (LOADUP '(CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU WINDOWOBJ WINDOWSCROLL + WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE + CMLARRAYINSPECTOR EDITINTERFACE TTYIN)) (LOADUP '(BREAK-AND-TRACE)) (LOADUP '(FASDUMP XCL-COMPILER ADVISE)) @@ -149,5 +151,5 @@ (GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST) ) (DECLARE\: DONTCOPY - (FILEMAP (NIL (652 7269 (LOADUP-LISP 662 . 7267))))) + (FILEMAP (NIL (695 7398 (LOADUP-LISP 705 . 7396))))) STOP diff --git a/internal/loadups/LOADUP-LISP.LCOM b/internal/loadups/LOADUP-LISP.LCOM index e81c7000..2bbfe60e 100644 Binary files a/internal/loadups/LOADUP-LISP.LCOM and b/internal/loadups/LOADUP-LISP.LCOM differ diff --git a/internal/loadups/man-page/loadup.1 b/internal/loadups/man-page/loadup.1 index d31156d8..4702ca50 100644 --- a/internal/loadups/man-page/loadup.1 +++ b/internal/loadups/man-page/loadup.1 @@ -111,11 +111,11 @@ output directory called \f[I]gitinfo\f[R] which contains the git commit, git branch and git status information for the directory at the time the loadup is run. .PP -Only one instance (per ) of loadup can be run at a time. +Only one instance (per ) of loadup can be run at a time. There is lock file to prevent simultaneous loadups in the work directory (named \f[B]\f[BI]lock\f[B]\f[R]) that can be manually removed. -The lock can also be automatically overridden (see the \[en]override -flag below). +The lock can also be automatically overridden (see the --override flag +below). Alternatively, if a lock is encountered at run time, the user will be asked to choose whether to override or simply exit the loadup. .PP @@ -130,7 +130,7 @@ But Medley can be installed in multiple places on any given machine and hence MEDLEYDIR is computed on each invocation of loadup. .SH OPTIONS .TP -\f[B]-z [+], --man [+], -man [+], -h [+], \[en]help [+]\f[R] +\f[B]-z [+], --man [+], -man [+], -h [+], --help [+]\f[R] Print this manual page on the screen. If the \f[B]+\f[R] parameter is specified, then no pager is used when displaying the man page. @@ -138,7 +138,7 @@ displaying the man page. \f[B]-t STAGE, --target STAGE, -target STAGE\f[R] Run the sequential loadup procedure until the STAGE is complete, starting from the files created by the previously run STAGE specified in -the \[en]start option. +the --start option. .RS .PP STAGE can be one of the following: @@ -175,7 +175,7 @@ Full.sysout is copied into the loadups directory. .RS .PP a, apps, 5: Run the loadup sequence through Stage 5 (apps.sysout). -Also run the Aux stage as if \[en]aux option had been specified. +Also run the Aux stage as if --aux option had been specified. Apps.sysout and the Aux files are copied into the loadups directory. .RE .RE @@ -185,7 +185,7 @@ Apps.sysout and the Aux files are copied into the loadups directory. a-, apps-, 5-: Run the loadup sequence through Stage 5 (apps.sysout). The Aux stage is not run unless otherwise specified. Apps.sysout is copied into the loadups directory. -Also run the Aux stage as if \[en]aux option had been specified. +Also run the Aux stage as if --aux option had been specified. .RE .RE .TP @@ -245,22 +245,22 @@ If this stage complete successfully, these files are copied into loadups. .TP \f[B]-i, --init, -init, -1\f[R] -Synonym for \[lq]\[en]target init\[rq] +Synonym for \[lq]--target init\[rq] .TP \f[B]-m, --mid, -mid, -2\f[R] -Synonym for \[lq]\[en]target mid\[rq] +Synonym for \[lq]--target mid\[rq] .TP \f[B]-l, --lisp, -lisp, -3\f[R] -Synonym for \[lq]\[en]target lisp\[rq] +Synonym for \[lq]--target lisp\[rq] .TP \f[B]-f, --full. -full, -4\f[R] -Synonym for \[lq]\[en]target full\[rq] +Synonym for \[lq]--target full\[rq] .TP \f[B]-a, --apps, -apps, -5\f[R] -Synonym for \[lq]\[en]target apps\[rq] +Synonym for \[lq]--target apps\[rq] .TP \f[B]-a-, --apps-, -apps-, -5-\f[R] -Synonym for \[lq]\[en]target apps\[rq] +Synonym for \[lq]--target apps\[rq] .TP \f[B]-ov, --override, -override\f[R] Automatically override the lock that prevents two loadups from running @@ -300,14 +300,14 @@ contained in the working directory. If the \f[B]+\f[R] parameter is used, then instead of deleting just the versioned files, all files and subdirectories are deleted except for those contained in the working directory. -If \f[B]+\f[R] is used and there is no working directory and -\f[I]\[en]tag TAG\f[R] is also specified, then the tagged loadups -directory (/loadups/tagged/TAG) is also deleted. +If \f[B]+\f[R] is used and there is no working directory and \f[I]--tag +TAG\f[R] is also specified, then the tagged loadups directory +(/loadups/tagged/TAG) is also deleted. .TP \f[B]-th [+], --thin [+], -thin [+]\f[R] Equivalent to specifying both -tw [+] and -tl [+]. -If \f[I]\[en]tag TAG\f[R] is also specified and the \f[B]+\f[R] -parameter is used here, then the tagged loadups directory +If \f[I]--tag TAG\f[R] is also specified and the \f[B]+\f[R] parameter +is used here, then the tagged loadups directory (/loadups/tagged/TAG) is removed. .TP \f[B]-d DIR, --maikodir DIR, -maikodir DIR\f[R] @@ -328,38 +328,36 @@ commonly used in running Medley in the absence of an Xwindows server. .PP The defaults for the Options context-dependent and somewhat complicated due to the goal of maintaining compatibility with legacy loadup scripts. -All of the following defaults rules hold independent of the -\[en]maikodir (-d) option. +All of the following defaults rules hold independent of the --maikodir +(-d) option. .IP "1." 3 -If none of \[en]target, \[en]start, \[en]aux, and \[en]db are specified, -then: +If none of --target, --start, --aux, and --db are specified, then: .RS .PP 1A. -If neither \[en]thinw nor \[en]thinl are specified, the options default -to: +If neither --thinw nor --thinl are specified, the options default to: .RE .RS .RS .PP -\f[B]\[en]target full \[en]start 0 \[en]aux\f[R] +\f[B]--target full --start 0 --aux\f[R] .RE .RE .RS .PP 1B. -If either \[en]thinw or \[en]thinl are specified, no loadups are run. +If either --thinw or --thinl are specified, no loadups are run. .RE .IP "2." 3 -If neither \[en]start nor \[en]target are specified but either -aux or --db or both are, then \[en]start defaults to \f[I]full\f[R] and -\[en]target is irrelevant. +If neither --start nor --target are specified but either -aux or -db or +both are, then --start defaults to \f[I]full\f[R] and --target is +irrelevant. .IP "3." 3 -If \[en]start is specified and \[en]target is not, then \[en]target -defaults to \f[I]full\f[R] +If --start is specified and --target is not, then --target defaults to +\f[I]full\f[R] .IP "4." 3 -If \[en]target is specified and \[en]start is not, then \[en]start -defaults to \f[I]0\f[R] +If --target is specified and --start is not, then --start defaults to +\f[I]0\f[R] .SH EXAMPLES .PP \f[B]./loadup -full -s lisp\f[R] : run loadup thru Stage 4 (full.sysout) @@ -368,14 +366,14 @@ starting from existing Stage 3 outputs (lisp.sysout). \f[B]./loadup --target full --start lisp\f[R] : run loadup thru Stage 4 (full.sysout) starting from existing Stage 3 outputs (lisp.sysout). .PP -\f[B]./loadup -5 \[en]aux\f[R] : run loadup from the beginning thru -Stage 5 (apps.sysout) then run the Aux \[lq]stage\[rq] to create +\f[B]./loadup -5 --aux\f[R] : run loadup from the beginning thru Stage 5 +(apps.sysout) then run the Aux \[lq]stage\[rq] to create \f[I]whereis.hash\f[R] and \f[I]exports.all\f[R] .PP \f[B]./loadup -db\f[R] : just run the DB \[lq]stage\[rq] starting from an existing full.sysout; do not run any of the sequential stages. .PP -\f[B]./loadup \[en]maikodir \[ti]/il/newmaiko\f[R] : run loadup sequence +\f[B]./loadup --maikodir \[ti]/il/newmaiko\f[R] : run loadup sequence from beginning to full plus the loadup Aux stage, while using \f[I]\[ti]/il/newmaiko\f[R] as the location for the lde executables when running Medley. diff --git a/internal/loadups/man-page/loadup.1.gz b/internal/loadups/man-page/loadup.1.gz index 2ae4135e..8500f0a9 100644 Binary files a/internal/loadups/man-page/loadup.1.gz and b/internal/loadups/man-page/loadup.1.gz differ diff --git a/internal/loadups/man-page/loadup.1.md b/internal/loadups/man-page/loadup.1.md index 957dad2d..44bfcbc3 100644 --- a/internal/loadups/man-page/loadup.1.md +++ b/internal/loadups/man-page/loadup.1.md @@ -52,7 +52,7 @@ Loadup does all of its work in a work directory (\/loadups/build). T If \ is a git directory, then a file is created in the loadups output directory called *gitinfo* which contains the git commit, git branch and git status information for the directory at the time the loadup is run. -Only one instance (per \) of loadup can be run at a time. There is lock file to prevent simultaneous loadups in the work directory (named ***lock***) that can be manually removed. The lock can also be automatically overridden (see the --override flag below). Alternatively, if a lock is encountered at run time, the user will be asked to choose whether to override or simply exit the loadup. +Only one instance (per \) of loadup can be run at a time. There is lock file to prevent simultaneous loadups in the work directory (named ***lock***) that can be manually removed. The lock can also be automatically overridden (see the \-\-override flag below). Alternatively, if a lock is encountered at run time, the user will be asked to choose whether to override or simply exit the loadup. Note: **MEDLEYDIR** is an environment variable set by the loadup script. It is set to the top level directory of the Medley installation that contains the specific loadup script that is invoked after all symbolic links are resolved. In the standard global installation this will @@ -61,12 +61,12 @@ hence MEDLEYDIR is computed on each invocation of loadup. OPTIONS ======= -**-z [+], \-\-man [+], \-man [+], -h [+], --help [+]** +**-z [+], \-\-man [+], \-man [+], -h [+], \-\-help [+]** : Print this manual page on the screen. If the **+** parameter is specified, then no pager is used when displaying the man page. **-t STAGE, \-\-target STAGE, -target STAGE** -: Run the sequential loadup procedure until the STAGE is complete, starting from the files created by the previously run STAGE specified in the --start option. +: Run the sequential loadup procedure until the STAGE is complete, starting from the files created by the previously run STAGE specified in the \-\-start option. >STAGE can be one of the following: @@ -78,9 +78,9 @@ displaying the man page. >>f, full, 4: Run the loadup sequence through Stage 4 (full.sysout). Full.sysout is copied into the loadups directory. ->>a, apps, 5: Run the loadup sequence through Stage 5 (apps.sysout). Also run the Aux stage as if --aux option had been specified. Apps.sysout and the Aux files are copied into the loadups directory. +>>a, apps, 5: Run the loadup sequence through Stage 5 (apps.sysout). Also run the Aux stage as if \-\-aux option had been specified. Apps.sysout and the Aux files are copied into the loadups directory. ->>a-, apps-, 5-: Run the loadup sequence through Stage 5 (apps.sysout). The Aux stage is not run unless otherwise specified. Apps.sysout is copied into the loadups directory. Also run the Aux stage as if --aux option had been specified. +>>a-, apps-, 5-: Run the loadup sequence through Stage 5 (apps.sysout). The Aux stage is not run unless otherwise specified. Apps.sysout is copied into the loadups directory. Also run the Aux stage as if \-\-aux option had been specified. **-s STAGE \-\-start STAGE, -start STAGE** @@ -105,22 +105,22 @@ displaying the man page. : Run the DB loadup stage, creating the *fuller.database* file. If this stage complete successfully, these files are copied into loadups. **-i, \-\-init, -init, -1** -: Synonym for "--target init" +: Synonym for "\-\-target init" **-m, \-\-mid, -mid, -2** -: Synonym for "--target mid" +: Synonym for "\-\-target mid" **-l, \-\-lisp, -lisp, -3** -: Synonym for "--target lisp" +: Synonym for "\-\-target lisp" **-f, \-\-full. -full, -4** -: Synonym for "--target full" +: Synonym for "\-\-target full" **-a, \-\-apps, -apps, -5** -: Synonym for "--target apps" +: Synonym for "\-\-target apps" **-a-, \-\-apps-, -apps-, -5-** -: Synonym for "--target apps" +: Synonym for "\-\-target apps" **-ov, \-\-override, -override** : Automatically override the lock that prevents two loadups from running simultaneously. If this flag is not set and an active lock is encountered, the user will be asked to choose whether to override or exit. @@ -149,11 +149,11 @@ working directory (and all files and subdirectories it contains) is deleted. files except for those contained in the working directory. If the **+** parameter is used, then instead of deleting just the versioned files, all files and subdirectories are deleted except for those contained in the working directory. If **+** is used and -there is no working directory and *--tag TAG* is also specified, +there is no working directory and *\-\-tag TAG* is also specified, then the tagged loadups directory (\/loadups/tagged/TAG) is also deleted. **-th [+], \-\-thin [+], -thin [+]** -: Equivalent to specifying both -tw [+] and -tl [+]. If *--tag TAG* is also specified and +: Equivalent to specifying both -tw [+] and -tl [+]. If *\-\-tag TAG* is also specified and the **+** parameter is used here, then the tagged loadups directory (\/loadups/tagged/TAG) is removed. @@ -168,21 +168,21 @@ running Medley in the absence of an Xwindows server. DEFAULTS ==== -The defaults for the Options context-dependent and somewhat complicated due to the goal of maintaining compatibility with legacy loadup scripts. All of the following defaults rules hold independent of the --maikodir (-d) option. +The defaults for the Options context-dependent and somewhat complicated due to the goal of maintaining compatibility with legacy loadup scripts. All of the following defaults rules hold independent of the \-\-maikodir (-d) option. -1. If none of --target, --start, --aux, and --db are specified, then: +1. If none of \-\-target, \-\-start, \-\-aux, and \-\-db are specified, then: ->1A. If neither --thinw nor --thinl are specified, the options default to: +>1A. If neither \-\-thinw nor \-\-thinl are specified, the options default to: ->> **--target full --start 0 --aux** +>> **\-\-target full \-\-start 0 \-\-aux** ->1B. If either --thinw or --thinl are specified, no loadups are run. +>1B. If either \-\-thinw or \-\-thinl are specified, no loadups are run. -2. If neither --start nor --target are specified but either -aux or -db or both are, then --start defaults to *full* and --target is irrelevant. +2. If neither \-\-start nor \-\-target are specified but either -aux or -db or both are, then \-\-start defaults to *full* and \-\-target is irrelevant. -3. If --start is specified and --target is not, then --target defaults to *full* +3. If \-\-start is specified and \-\-target is not, then \-\-target defaults to *full* -4. If --target is specified and --start is not, then --start defaults to *0* +4. If \-\-target is specified and \-\-start is not, then \-\-start defaults to *0* EXAMPLES ==== @@ -190,11 +190,11 @@ EXAMPLES **./loadup \-\-target full \-\-start lisp** : run loadup thru Stage 4 (full.sysout) starting from existing Stage 3 outputs (lisp.sysout). -**./loadup -5 --aux** : run loadup from the beginning thru Stage 5 (apps.sysout) then run the Aux "stage" to create *whereis.hash* and *exports.all* +**./loadup -5 \-\-aux** : run loadup from the beginning thru Stage 5 (apps.sysout) then run the Aux "stage" to create *whereis.hash* and *exports.all* **./loadup -db** : just run the DB "stage" starting from an existing full.sysout; do not run any of the sequential stages. -**./loadup --maikodir ~/il/newmaiko** : run loadup sequence from beginning to full plus the loadup Aux stage, while using *~/il/newmaiko* as the location for the lde executables when running Medley. +**./loadup \-\-maikodir ~/il/newmaiko** : run loadup sequence from beginning to full plus the loadup Aux stage, while using *~/il/newmaiko* as the location for the lde executables when running Medley. **./loadup -full** : run loadup sequence from beginning thru full diff --git a/internal/loadups/man-page/man_loadup.html b/internal/loadups/man-page/man_loadup.html index 54e80a8f..94868db4 100644 --- a/internal/loadups/man-page/man_loadup.html +++ b/internal/loadups/man-page/man_loadup.html @@ -83,11 +83,11 @@ the work directory after the loadup completes.

the loadups output directory called gitinfo which contains the git commit, git branch and git status information for the directory at the time the loadup is run.

-

Only one instance (per <MEDLEIDIR>) of loadup can be run at a +

Only one instance (per <MEDLEYDIR>) of loadup can be run at a time. There is lock file to prevent simultaneous loadups in the work directory (named lock) that can be manually removed. The lock can also be automatically overridden (see the -–override flag below). Alternatively, if a lock is encountered at run +--override flag below). Alternatively, if a lock is encountered at run time, the user will be asked to choose whether to override or simply exit the loadup.

Note: MEDLEYDIR is an environment variable set by @@ -99,7 +99,8 @@ installed in multiple places on any given machine and hence MEDLEYDIR is computed on each invocation of loadup.

OPTIONS

-
-z [+], --man [+], -man [+], -h [+], –help [+]
+
-z [+], --man [+], -man [+], -h [+], --help +[+]

Print this manual page on the screen. If the + parameter is specified, then no pager is used when displaying the man @@ -109,7 +110,7 @@ page.

Run the sequential loadup procedure until the STAGE is complete, starting from the files created by the previously run STAGE specified in -the –start option.

+the --start option.

STAGE can be one of the following:

i, init, 1: Run the loadup sequence through Stage 1 (init.dlinit). @@ -129,13 +130,13 @@ Full.sysout is copied into the loadups directory.

a, apps, 5: Run the loadup sequence through Stage 5 (apps.sysout). -Also run the Aux stage as if –aux option had been specified. Apps.sysout -and the Aux files are copied into the loadups directory.

+Also run the Aux stage as if --aux option had been specified. +Apps.sysout and the Aux files are copied into the loadups directory.

a-, apps-, 5-: Run the loadup sequence through Stage 5 (apps.sysout). The Aux stage is not run unless otherwise specified. Apps.sysout is -copied into the loadups directory. Also run the Aux stage as if –aux +copied into the loadups directory. Also run the Aux stage as if --aux option had been specified.

@@ -181,27 +182,27 @@ loadups.

-i, --init, -init, -1
-

Synonym for “–target initâ€

+

Synonym for “--target initâ€

-m, --mid, -mid, -2
-

Synonym for “–target midâ€

+

Synonym for “--target midâ€

-l, --lisp, -lisp, -3
-

Synonym for “–target lispâ€

+

Synonym for “--target lispâ€

-f, --full. -full, -4
-

Synonym for “–target fullâ€

+

Synonym for “--target fullâ€

-a, --apps, -apps, -5
-

Synonym for “–target appsâ€

+

Synonym for “--target appsâ€

-a-, --apps-, -apps-, -5-
-

Synonym for “–target appsâ€

+

Synonym for “--target appsâ€

-ov, --override, -override
@@ -245,13 +246,13 @@ contained in the working directory. If the + parameter is used, then instead of deleting just the versioned files, all files and subdirectories are deleted except for those contained in the working directory. If + is used and there is no working -directory and –tag TAG is also specified, then the tagged +directory and --tag TAG is also specified, then the tagged loadups directory (<MEDLEYDIR>/loadups/tagged/TAG) is also deleted.

-th [+], --thin [+], -thin [+]
-

Equivalent to specifying both -tw [+] and -tl [+]. If –tag +

Equivalent to specifying both -tw [+] and -tl [+]. If --tag TAG is also specified and the + parameter is used here, then the tagged loadups directory (<MEDLEYDIR>/loadups/tagged/TAG) is removed.

@@ -277,24 +278,24 @@ absence of an Xwindows server.

The defaults for the Options context-dependent and somewhat complicated due to the goal of maintaining compatibility with legacy loadup scripts. All of the following defaults rules hold independent of -the –maikodir (-d) option.

+the --maikodir (-d) option.

    -

  1. If none of –target, –start, –aux, and –db are specified, +

  2. If none of --target, --start, --aux, and --db are specified, then:

    -

    1A. If neither –thinw nor –thinl are specified, the options default +

    1A. If neither --thinw nor --thinl are specified, the options default to:

    -

    –target full –start 0 –aux

    +

    --target full --start 0 --aux

    -

    1B. If either –thinw or –thinl are specified, no loadups are +

    1B. If either --thinw or --thinl are specified, no loadups are run.

    3. -

  3. If neither –start nor –target are specified but either -aux or --db or both are, then –start defaults to full and –target is +

  4. If neither --start nor --target are specified but either -aux or +-db or both are, then --start defaults to full and --target is irrelevant.

    5. -

  5. If –start is specified and –target is not, then –target defaults -to full

    6. -

  6. If –target is specified and –start is not, then –start defaults -to 0

    7. +

  7. If --start is specified and --target is not, then --target +defaults to full

    8. +

  8. If --target is specified and --start is not, then --start +defaults to 0

EXAMPLES

./loadup -full -s lisp : run loadup thru Stage 4 @@ -302,12 +303,12 @@ to 0

./loadup --target full --start lisp : run loadup thru Stage 4 (full.sysout) starting from existing Stage 3 outputs (lisp.sysout).

-

./loadup -5 –aux : run loadup from the beginning +

./loadup -5 --aux : run loadup from the beginning thru Stage 5 (apps.sysout) then run the Aux “stage†to create whereis.hash and exports.all

./loadup -db : just run the DB “stage†starting from an existing full.sysout; do not run any of the sequential stages.

-

./loadup –maikodir ~/il/newmaiko : run loadup +

./loadup --maikodir ~/il/newmaiko : run loadup sequence from beginning to full plus the loadup Aux stage, while using ~/il/newmaiko as the location for the lde executables when running Medley.

diff --git a/internal/loadups/starter.sysout b/internal/loadups/starter.sysout index 19d5b6a4..21543ecf 100644 Binary files a/internal/loadups/starter.sysout and b/internal/loadups/starter.sysout differ diff --git a/library/CLIPBOARD b/library/CLIPBOARD index df92fffe..23454b56 100644 --- a/library/CLIPBOARD +++ b/library/CLIPBOARD @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Sep-2025 15:00:01"  -{DSK}kaplan>Local>medley3.5>working-medley>library>CLIPBOARD.;28 8305 +(FILECREATED "23-Feb-2026 12:35:55" {WMEDLEY}CLIPBOARD.;29 8228 :EDIT-BY rmk - :CHANGES-TO (FNS PUTCLIPBOARD CLIPBOARD-COPY-STREAM) + :CHANGES-TO (VARS CLIPBOARDCOMS) - :PREVIOUS-DATE "21-Apr-2024 09:12:04" {WMEDLEY}CLIPBOARD.;18) + :PREVIOUS-DATE "25-Sep-2025 15:00:01" {WMEDLEY}CLIPBOARD.;28) (PRETTYCOMPRINT CLIPBOARDCOMS) @@ -18,7 +17,7 @@ CLIPBOARD-PASTE-STREAM) (FNS SEDIT.COPYTOCLIPBOARD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD) - UNIXCOMM UNICODE) + UNIXCOMM) (P (INSTALL-CLIPBOARD))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) @@ -148,7 +147,7 @@ (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILESLOAD (SYSLOAD) - UNIXCOMM UNICODE) + UNIXCOMM) (INSTALL-CLIPBOARD) @@ -162,7 +161,7 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1167 6486 (INSTALL-CLIPBOARD 1177 . 2504) (GETCLIPBOARD 2506 . 2880) (PUTCLIPBOARD 2882 - . 4306) (PASTEFROMCLIPBOARD 4308 . 5226) (CLIPBOARD-COPY-STREAM 5228 . 5762) (CLIPBOARD-PASTE-STREAM -5764 . 6484)) (6487 8026 (SEDIT.COPYTOCLIPBOARD 6497 . 8024))))) + (FILEMAP (NIL (1098 6417 (INSTALL-CLIPBOARD 1108 . 2435) (GETCLIPBOARD 2437 . 2811) (PUTCLIPBOARD 2813 + . 4237) (PASTEFROMCLIPBOARD 4239 . 5157) (CLIPBOARD-COPY-STREAM 5159 . 5693) (CLIPBOARD-PASTE-STREAM +5695 . 6415)) (6418 7957 (SEDIT.COPYTOCLIPBOARD 6428 . 7955))))) STOP diff --git a/library/CLIPBOARD.LCOM b/library/CLIPBOARD.LCOM index b077be28..a883c160 100644 Binary files a/library/CLIPBOARD.LCOM and b/library/CLIPBOARD.LCOM differ diff --git a/library/MASTERSCOPE b/library/MASTERSCOPE index a6006ac2..4fc6d972 100644 --- a/library/MASTERSCOPE +++ b/library/MASTERSCOPE @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Aug-2025 13:45:51" {WMEDLEY}MASTERSCOPE.;30 197199 +(FILECREATED "16-Feb-2026 13:34:31" {WMEDLEY}MASTERSCOPE.;41 197959 :EDIT-BY rmk - :CHANGES-TO (FNS MSINTERPRET) + :CHANGES-TO (FNS MSOUTPUT) - :PREVIOUS-DATE " 5-Apr-2025 11:49:04" {WMEDLEY}MASTERSCOPE.;29) + :PREVIOUS-DATE " 8-Feb-2026 22:38:50" {WMEDLEY}MASTERSCOPE.;40) (PRETTYCOMPRINT MASTERSCOPECOMS) @@ -847,34 +847,25 @@ (T (CDR (FASSOC Y MSDATABASELST]) (MSSTOREDATA - [LAMBDA (FNNAME FNDATA) (* lmm " 1-JUN-81 23:19") + [LAMBDA (FNNAME FNDATA) (* ; "Edited 8-Feb-2026 18:42 by lmm") + (* 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) - + (SETQ MSDBEMPTY NIL) (* Database for FNNAME about to become + inconsistant - + mark it as changed) (PUTHASH FNNAME T MSCHANGEDARRAY) - - (* * Now update the database) + + (* * 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)) + 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.) + (PUTTABLE FNNAME T (CADR (FASSOC 'UNBOUND MSDATABASELST] + + (* ;; "Table UNBOUND 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]) @@ -911,7 +902,7 @@ ((CALL 25 . 50) (BIND 10 . 10) [NLAMBDA 10 . 10] - (NOBIND 10) + (UNBOUND 10) (RECORD 20 . 10) (CREATE 2 . 2) (FETCH 10 . 10) @@ -1120,9 +1111,10 @@ (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.") + [LAMBDA (VERB MOD) (* ; "Edited 8-Feb-2026 18:44 by lmm") + (* ; "Edited 30-Jun-87 10:32 by jrb:") + + (* ;; "The call to MSUSERVBTABLES checks a user hash table to allow extensions.") [COND ((LISTP VERB) @@ -1159,10 +1151,10 @@ (IS (SELECTQ MOD (FIELDS '((FETCH) (REPLACE))) - (FNS '(CALL NOBIND REF (CALL) + (FNS '(CALL UNBOUND REF (CALL) (APPLY))) - (KNOWN '(CALL NOBIND REF)) - (NIL '(CALL NOBIND REF (CALL) + (KNOWN '(CALL UNBOUND REF)) + (NIL '(CALL UNBOUND REF (CALL) (BIND) (REFFREE) (REF) @@ -1192,7 +1184,7 @@ (TYPE '((0))) NIL)) (KNOWN (SELECTQ MOD - (NIL '(CALL NOBIND REF)) + (NIL '(CALL UNBOUND REF)) NIL)) (PROG (SELECTQ MOD (NIL 'PROG) @@ -1258,23 +1250,20 @@ (DEFINEQ (BUILDGETRELQ - [LAMBDA (X) (* ; "Edited 16-Jun-87 12:36 by jrb:") - + [LAMBDA (X) (* ; "Edited 8-Feb-2026 19:24 by lmm") + (* ; "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] + [for REL in (MSVBTABLES (CAR X)) do [SETQ F1 `(GETTABLE ,VAR (,(CL:IF (CL:THIRD X) + 'CDDR + 'CADR) + (FASSOC ',REL MSDATABASELST] + (SETQ FORM (COND + (FORM (LIST 'UNION F1 FORM)) + (T F1] (RETURN (COND ((EQ VAR (CADR X)) FORM) @@ -2577,7 +2566,7 @@ (* ; "interactive routines") -(RPAQ MASTERSCOPEDATE "24-Aug-2025") +(RPAQ MASTERSCOPEDATE "16-Feb-2026") (ADDTOVAR HISTORYCOMS %.) (DEFINEQ @@ -2616,15 +2605,14 @@ (GO ERLP]) (MASTERSCOPEXEC - [LAMBDA (X LINE) (* ; "Edited 17-Jun-87 16:57 by jrb:") - (* Called via the LISPX in - MASTERSCOPE) + [LAMBDA (X LINE) (* ; "Edited 8-Feb-2026 18:46 by lmm") + (* ; "Edited 17-Jun-87 16:57 by jrb:") + (* Called via the LISPX in MASTERSCOPE) (* ; - "Merged from smL Loops Masterscope by JRB") - + "Merged from smL Loops Masterscope by JRB") (PROG (MASTERSCOPECOMMAND) (AND [OR [COND - ((NULL LINE) (* Single entry on line) + ((NULL LINE) (* ; "Single entry on line") (OR (NOT (LITATOM X)) (OR (NEQ (EVALV X) 'NOBIND) @@ -2633,17 +2621,14 @@ (FGETD X) (LISTP LINE) (OR [COND - ((NULL (CDR LINE)) (* "EDITF ] " OR SETQ - (A B) TYPE ENTRY) + ((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) - + (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) @@ -2651,11 +2636,8 @@ NIL) LISPXVALUE [AND (LISTP LISPXHIST) - (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] - - (* Make sure the event shows up with a %. - in it) - + (FRPLACA LISPXHIST (CONS '%. (CAR LISPXHIST] (* ; + "Make sure the event shows up with a . in it") (SETQ LISPXVALUE (MSINTERPRET MASTERSCOPECOMMAND)) (RETURN T]) ) @@ -3516,13 +3498,17 @@ (ERROR!]) (MSOUTPUT - [LAMBDA (FILE) (* ; "Edited 5-Apr-2025 11:48 by rmk") + [LAMBDA (FILE) (* ; "Edited 16-Feb-2026 13:34 by rmk") + (* ; "Edited 5-Feb-2026 01:01 by rmk") + (* ; "Edited 18-Nov-2025 14:01 by rmk") + (* ; "Edited 8-Nov-2025 23:21 by rmk") + (* ; "Edited 5-Apr-2025 11:48 by rmk") (* ; "Edited 14-Jul-2024 08:41 by rmk") (* ; "Edited 5-Jul-2024 11:54 by rmk") (* ; "Edited 12-Jun-90 20:43 by teruuchi") (LET ((LLENGTH FILELINELENGTH)) [COND - ((AND (LITATOM FILE) + [(AND (LITATOM FILE) (MEMB (U-CASE FILE) '(TEDIT :TEDIT)) (GETD (FUNCTION TEDIT))) @@ -3530,12 +3516,14 @@ (* ;;  "If no TEDIT, leave the current OUTPUT. The readtable for seprs etc is the current readtable.") - [SETQ FILE (TEXTSTREAM (TEDIT NIL 'Masterscope NIL `(LEAVETTY T TITLE Masterscope FONT - ,DEFAULTFONT BOUNDTABLE - ,(TEDIT.ATOMBOUND.READTABLE] + [SETQ FILE (OPENTEXTSTREAM NIL NIL `(FONT ,DEFAULTFONT BOUNDTABLE ,( + TEDIT.ATOMBOUND.READTABLE + ] (SETQ LLENGTH T) - (TEDIT.DEFER.UPDATES FILE '(READONLY QUIET)) - (RESETSAVE NIL (LIST 'CLOSEF FILE))) + (RESETSAVE NIL `(PROGN (CL:UNLESS RESETSTATE + (TEDIT ,FILE 'Masterscope NIL + '(TITLE Masterscope READONLY QUIET LEAVETTY T))) + (CLOSEF? ,FILE] ((OPENP FILE 'OUTPUT)) (T (SETQ FILE (OPENSTREAM FILE 'OUTPUT)) (RESETSAVE NIL (LIST 'CLOSEF FILE] @@ -3742,36 +3730,36 @@ (ADDTOVAR LAMA MSEDITE MSEDITF) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3263 19510 (UPDATEFN 3273 . 4890) (MSGETDEF 4892 . 6298) (MSNOTICEFILE 6300 . 8693) ( -MSSHOWUSE 8695 . 14676) (MSUPDATEFN1 14678 . 15366) (MSUPDATE 15368 . 17794) (MSNLAMBDACHECK 17796 . -18678) (MSCOLLECTDATA 18680 . 19508)) (19511 20410 (UPDATECHANGED 19521 . 19884) (UPDATECHANGED1 19886 - . 20408)) (20984 21407 (MSCLOSEFILES 20994 . 21405)) (22088 26520 (MSDESCRIBE 22098 . 24886) ( -MSDESCRIBE1 24888 . 25951) (FMAPRINT 25953 . 26518)) (26613 27053 (MSPRINTHELPFILE 26623 . 27051)) ( -27103 30241 (TEMPLATE 27113 . 28534) (GETTEMPLATE 28536 . 28671) (SETTEMPLATE 28673 . 30239)) (31111 -36035 (ADDTEMPLATEWORD 31121 . 31793) (MSADDANALYZE 31795 . 33293) (MSADDMODIFIER 33295 . 34376) ( -MSADDRELATION 34378 . 35125) (MSADDTYPE 35127 . 36033)) (37536 42757 (MSMARKCHANGE1 37546 . 38340) ( -MSINIT 38342 . 39523) (GETVERBTABLES 39525 . 40078) (MSSTOREDATA 40080 . 41759) (STORETABLE 41761 . -42755)) (44158 49228 (PARSERELATION 44168 . 44768) (PARSERELATION1 44770 . 46225) (GETRELATION 46227 - . 47256) (MAPRELATION 47258 . 48392) (TESTRELATION 48394 . 49226)) (49229 50869 (ADDHASH 49239 . -49717) (SUBHASH 49719 . 49947) (MAKEHASH 49949 . 50093) (MSREHASH 50095 . 50548) (EQMEMBHASH 50550 . -50867)) (51208 57423 (MSVBTABLES 51218 . 56997) (MSUSERVBTABLES 56999 . 57421)) (57506 59717 ( -BUILDGETRELQ 57516 . 58622) (BUILDTESTRELQ 58624 . 59715)) (59888 60276 (MSERASE 59898 . 60274)) ( -60277 64737 (DUMPDATABASE 60287 . 62852) (DUMPDATABASE1 62854 . 63199) (READATABASE 63201 . 64735)) ( -65819 94878 (MSCHECKBLOCKS 65829 . 69649) (MSCHECKBLOCK 69651 . 78271) (MSCHECKFNINBLOCK 78273 . 81273 -) (MSCHECKBLOCKBASIC 81275 . 83695) (MSCHECKBOUNDFREE 83697 . 85596) (GLOBALVARP 85598 . 85765) ( -PRINTERROR 85767 . 88983) (MSCHECKVARS1 88985 . 91938) (UNECCSPEC 91940 . 92218) (NECCSPEC 92220 . -92567) (SPECVARP 92569 . 93096) (SHORTLST 93098 . 93554) (DOERROR 93556 . 94266) (MSMSGPRINT 94268 . -94876)) (96022 110850 (MSPATHS 96032 . 99434) (MSPATHS1 99436 . 103671) (MSPATHS2 103673 . 107083) ( -MSONPATH 107085 . 108313) (MSPATHS4 108315 . 109397) (DASHES 109399 . 109925) (DOTABS 109927 . 110168) - (BELOWMARKER 110170 . 110633) (MSPATHSPRINTFN 110635 . 110848)) (111236 114660 (MSFIND 111246 . -111521) (MSEDITF 111523 . 112523) (MSEDITE 112525 . 113562) (EDITGETDEF 113564 . 114658)) (115602 -124203 (MSMARKCHANGED 115612 . 117336) (CHANGEMACRO 117338 . 118043) (CHANGEVAR 118045 . 118361) ( -CHANGEI.S. 118363 . 119696) (CHANGERECORD 119698 . 120569) (MSNEEDUNSAVE 120571 . 121563) (UNSAVEFNS -121565 . 124201)) (124636 128126 (%. 124646 . 124786) (MASTERSCOPE 124788 . 125314) (MASTERSCOPE1 -125316 . 126184) (MASTERSCOPEXEC 126186 . 128124)) (128165 167815 (MSINTERPRETSET 128175 . 156709) ( -MSINTERPA 156711 . 157245) (MSGETBLOCKDEC 157247 . 159760) (LISTHARD 159762 . 160980) (MSMEMBSET -160982 . 161127) (MSLISTSET 161129 . 161494) (MSHASHLIST 161496 . 161663) (MSHASHLIST1 161665 . 161991 -) (CHECKPATHS 161993 . 162633) (ONFILE 162635 . 167813)) (167816 191377 (MSINTERPRET 167826 . 183881) -(VERBNOTICELIST 183883 . 184993) (MSOUTPUT 184995 . 186505) (MSCHECKEMPTY 186507 . 187711) ( -CHECKFORCHANGED 187713 . 188233) (MSSOLVE 188235 . 191375))))) + (FILEMAP (NIL (3260 19507 (UPDATEFN 3270 . 4887) (MSGETDEF 4889 . 6295) (MSNOTICEFILE 6297 . 8690) ( +MSSHOWUSE 8692 . 14673) (MSUPDATEFN1 14675 . 15363) (MSUPDATE 15365 . 17791) (MSNLAMBDACHECK 17793 . +18675) (MSCOLLECTDATA 18677 . 19505)) (19508 20407 (UPDATECHANGED 19518 . 19881) (UPDATECHANGED1 19883 + . 20405)) (20981 21404 (MSCLOSEFILES 20991 . 21402)) (22085 26517 (MSDESCRIBE 22095 . 24883) ( +MSDESCRIBE1 24885 . 25948) (FMAPRINT 25950 . 26515)) (26610 27050 (MSPRINTHELPFILE 26620 . 27048)) ( +27100 30238 (TEMPLATE 27110 . 28531) (GETTEMPLATE 28533 . 28668) (SETTEMPLATE 28670 . 30236)) (31108 +36032 (ADDTEMPLATEWORD 31118 . 31790) (MSADDANALYZE 31792 . 33290) (MSADDMODIFIER 33292 . 34373) ( +MSADDRELATION 34375 . 35122) (MSADDTYPE 35124 . 36030)) (37533 42629 (MSMARKCHANGE1 37543 . 38337) ( +MSINIT 38339 . 39520) (GETVERBTABLES 39522 . 40075) (MSSTOREDATA 40077 . 41631) (STORETABLE 41633 . +42627)) (44031 49101 (PARSERELATION 44041 . 44641) (PARSERELATION1 44643 . 46098) (GETRELATION 46100 + . 47129) (MAPRELATION 47131 . 48265) (TESTRELATION 48267 . 49099)) (49102 50742 (ADDHASH 49112 . +49590) (SUBHASH 49592 . 49820) (MAKEHASH 49822 . 49966) (MSREHASH 49968 . 50421) (EQMEMBHASH 50423 . +50740)) (51081 57397 (MSVBTABLES 51091 . 56971) (MSUSERVBTABLES 56973 . 57395)) (57480 59783 ( +BUILDGETRELQ 57490 . 58688) (BUILDTESTRELQ 58690 . 59781)) (59954 60342 (MSERASE 59964 . 60340)) ( +60343 64803 (DUMPDATABASE 60353 . 62918) (DUMPDATABASE1 62920 . 63265) (READATABASE 63267 . 64801)) ( +65885 94944 (MSCHECKBLOCKS 65895 . 69715) (MSCHECKBLOCK 69717 . 78337) (MSCHECKFNINBLOCK 78339 . 81339 +) (MSCHECKBLOCKBASIC 81341 . 83761) (MSCHECKBOUNDFREE 83763 . 85662) (GLOBALVARP 85664 . 85831) ( +PRINTERROR 85833 . 89049) (MSCHECKVARS1 89051 . 92004) (UNECCSPEC 92006 . 92284) (NECCSPEC 92286 . +92633) (SPECVARP 92635 . 93162) (SHORTLST 93164 . 93620) (DOERROR 93622 . 94332) (MSMSGPRINT 94334 . +94942)) (96088 110916 (MSPATHS 96098 . 99500) (MSPATHS1 99502 . 103737) (MSPATHS2 103739 . 107149) ( +MSONPATH 107151 . 108379) (MSPATHS4 108381 . 109463) (DASHES 109465 . 109991) (DOTABS 109993 . 110234) + (BELOWMARKER 110236 . 110699) (MSPATHSPRINTFN 110701 . 110914)) (111302 114726 (MSFIND 111312 . +111587) (MSEDITF 111589 . 112589) (MSEDITE 112591 . 113628) (EDITGETDEF 113630 . 114724)) (115668 +124269 (MSMARKCHANGED 115678 . 117402) (CHANGEMACRO 117404 . 118109) (CHANGEVAR 118111 . 118427) ( +CHANGEI.S. 118429 . 119762) (CHANGERECORD 119764 . 120635) (MSNEEDUNSAVE 120637 . 121629) (UNSAVEFNS +121631 . 124267)) (124702 128312 (%. 124712 . 124852) (MASTERSCOPE 124854 . 125380) (MASTERSCOPE1 +125382 . 126250) (MASTERSCOPEXEC 126252 . 128310)) (128351 168001 (MSINTERPRETSET 128361 . 156895) ( +MSINTERPA 156897 . 157431) (MSGETBLOCKDEC 157433 . 159946) (LISTHARD 159948 . 161166) (MSMEMBSET +161168 . 161313) (MSLISTSET 161315 . 161680) (MSHASHLIST 161682 . 161849) (MSHASHLIST1 161851 . 162177 +) (CHECKPATHS 162179 . 162819) (ONFILE 162821 . 167999)) (168002 192137 (MSINTERPRET 168012 . 184067) +(VERBNOTICELIST 184069 . 185179) (MSOUTPUT 185181 . 187265) (MSCHECKEMPTY 187267 . 188471) ( +CHECKFORCHANGED 188473 . 188993) (MSSOLVE 188995 . 192135))))) STOP diff --git a/library/MASTERSCOPE.DFASL b/library/MASTERSCOPE.DFASL index 585c6b98..590dfb79 100644 Binary files a/library/MASTERSCOPE.DFASL and b/library/MASTERSCOPE.DFASL differ diff --git a/library/POSTSCRIPTSTREAM b/library/POSTSCRIPTSTREAM index dc945efb..c715c964 100644 --- a/library/POSTSCRIPTSTREAM +++ b/library/POSTSCRIPTSTREAM @@ -1,13 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "27-Jan-2026 17:57:49" {DSK}matt>Interlisp>medley>library>POSTSCRIPTSTREAM.;4 258423 +(FILECREATED "12-Feb-2026 12:19:03" {DSK}matt>Interlisp>medley>library>POSTSCRIPTSTREAM.;6 258522 :EDIT-BY "mth" - :CHANGES-TO (FNS POSTSCRIPT.STARTPAGE) + :CHANGES-TO (FNS PSCFONT.READFONT) - :PREVIOUS-DATE "27-Jan-2026 13:15:17" -{DSK}matt>Interlisp>medley>library>POSTSCRIPTSTREAM.;3) + :PREVIOUS-DATE "27-Jan-2026 17:57:49" +{DSK}matt>Interlisp>medley>library>POSTSCRIPTSTREAM.;5) (PRETTYCOMPRINT POSTSCRIPTSTREAMCOMS) @@ -574,22 +574,24 @@ (DEFINEQ (PSCFONT.READFONT - [LAMBDA (FONTFILENAME) (* ; "Edited 5-Oct-93 17:19 by rmk:") - (* ; "Edited 1-Sep-89 10:55 by jds") + [LAMBDA (FONTFILENAME) (* ; "Edited 12-Feb-2026 12:01 by mth") + (* ; "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.") + (* ;; "Read one of Matt Heffron's .PSC files, to get postscript font metrics. First check to see if incore cache has information indexed under the file's name.") (LET (FID W [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T] - (PF (create PSCFONT))) + (PF (create PSCFONT)) + (*PACKAGE* (CL:FIND-PACKAGE "INTERLISP"))) [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.") + (* ;; "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") + (* ;; "Body of the loop is empty, the test does all of the work") ) (replace (PSCFONT IL-FONTID) of PF with (CAR FID)) @@ -601,13 +603,12 @@ (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.") + (* ;; + "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))) + (replace (PSCFONT ASCENT) of PF with (- 1000 (fetch (PSCFONT DESCENT) OF PF))) (PUSH POSTSCRIPTFONTCACHE (CONS (L-CASE (FILENAMEFIELD FONTFILENAME 'NAME)) - (CREATE PSCFONT USING PF))) + (CREATE PSCFONT USING PF))) PF]) (PSCFONT.SPELLFILE @@ -4392,37 +4393,37 @@ (ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (22370 32689 (POSTSCRIPT.INIT 22380 . 29295) (POSTSCRIPT.PUTRGBCOLOR 29297 . 30319) ( -\PSC.COLOR.TO.RGB 30321 . 32687)) (33675 69097 (PSCFONT.READFONT 33685 . 35593) (PSCFONT.SPELLFILE -35595 . 36408) (PSCFONT.COERCEFILE 36410 . 37982) (PSCFONTFROMCACHE.SPELLFILE 37984 . 38969) ( -PSCFONTFROMCACHE.COERCEFILE 38971 . 40623) (PSCFONT.WRITEFONT 40625 . 41640) (READ-AFM-FILE 41642 . -47513) (CONVERT-AFM-FILES 47515 . 48727) (POSTSCRIPT.GETFONTID 48729 . 50124) (POSTSCRIPT.FONTCREATE -50126 . 63020) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 63022 . 65419) (POSTSCRIPT.FONTSAVAILABLE 65421 - . 67708) (POSTSCRIPT.FONTEXISTS? 67710 . 69095)) (69098 79007 (OPENPOSTSCRIPTSTREAM 69108 . 78673) ( -CLOSEPOSTSCRIPTSTREAM 78675 . 79005)) (79052 85378 (POSTSCRIPT.HARDCOPYW 79062 . 82169) ( -POSTSCRIPT.TEDIT 82171 . 82623) (POSTSCRIPTFILEP 82625 . 84113) (MAKEEPSFILE 84115 . 85376)) (85379 -129123 (POSTSCRIPT.BITMAPSCALE 85389 . 87845) (POSTSCRIPT.CLOSESTRING 87847 . 88400) ( -POSTSCRIPT.ENDPAGE 88402 . 89293) (POSTSCRIPT.OUTSTR 89295 . 90512) (POSTSCRIPT.PUTBITMAPBYTES 90514 - . 98985) (POSTSCRIPT.PUTCOMMAND 98987 . 99976) (POSTSCRIPT.SET-FAKE-LANDSCAPE 99978 . 104498) ( -POSTSCRIPT.SHOWACCUM 104500 . 106655) (POSTSCRIPT.STARTPAGE 106657 . 109359) (\POSTSCRIPTTAB 109361 . -110158) (\PS.BOUTFIXP 110160 . 111440) (\PS.SCALEHACK 111442 . 114085) (\PS.SCALEREGION 114087 . -114647) (\SCALEDBITBLT.PSC 114649 . 118959) (\SETPOS.PSC 118961 . 119442) (\SETXFORM.PSC 119444 . -122028) (\STRINGWIDTH.PSC 122030 . 122503) (\SWITCHFONTS.PSC 122505 . 127997) (\TERPRI.PSC 127999 . -129121)) (129158 183014 (\BITBLT.PSC 129168 . 129720) (\BLTSHADE.PSC 129722 . 134383) (\CHARWIDTH.PSC -134385 . 134892) (\CREATECHARSET.PSC 134894 . 136250) (\DRAWARC.PSC 136252 . 138630) (\DRAWCIRCLE.PSC -138632 . 140883) (\DRAWCURVE.PSC 140885 . 144729) (\DRAWELLIPSE.PSC 144731 . 147095) (\DRAWLINE.PSC -147097 . 149837) (\DRAWPOINT.PSC 149839 . 150415) (\DRAWPOLYGON.PSC 150417 . 153546) ( -\DSPBOTTOMMARGIN.PSC 153548 . 154235) (\DSPCLIPPINGREGION.PSC 154237 . 155612) (\DSPCOLOR.PSC 155614 - . 156545) (\DSPFONT.PSC 156547 . 160184) (\DSPLEFTMARGIN.PSC 160186 . 160872) (\DSPLINEFEED.PSC -160874 . 161464) (\DSPPUSHSTATE.PSC 161466 . 162926) (\DSPPOPSTATE.PSC 162928 . 166413) (\DSPRESET.PSC - 166415 . 167080) (\DSPRIGHTMARGIN.PSC 167082 . 167771) (\DSPROTATE.PSC 167773 . 168772) ( -\DSPSCALE.PSC 168774 . 169726) (\DSPSCALE2.PSC 169728 . 170568) (\DSPSPACEFACTOR.PSC 170570 . 171491) -(\DSPTOPMARGIN.PSC 171493 . 172064) (\DSPTRANSLATE.PSC 172066 . 174097) (\DSPXPOSITION.PSC 174099 . -174663) (\DSPYPOSITION.PSC 174665 . 175256) (\FILLCIRCLE.PSC 175258 . 177483) (\FILLPOLYGON.PSC 177485 - . 180722) (\FIXLINELENGTH.PSC 180724 . 182043) (\MOVETO.PSC 182045 . 182815) (\NEWPAGE.PSC 182817 . -183012)) (183070 205216 (\POSTSCRIPT.CHANGECHARSET 183080 . 183798) (\POSTSCRIPT.OUTCHARFN 183800 . -196070) (\POSTSCRIPT.PRINTSLUG 196072 . 197796) (\POSTSCRIPT.SPECIALOUTCHARFN 197798 . 200149) ( -\UPDATE.PSC 200151 . 201397) (\POSTSCRIPT.ACCENTFN 201399 . 202341) (\POSTSCRIPT.ACCENTPAIR 202343 . -205214)) (205314 206959 (\PSC.SPACEDISP 205324 . 205603) (\PSC.SPACEWID 205605 . 206224) (\PSC.SYMBOLS - 206226 . 206957)) (207068 210059 (\POSTSCRIPT.NSHASH 207078 . 210057))))) + (FILEMAP (NIL (22366 32685 (POSTSCRIPT.INIT 22376 . 29291) (POSTSCRIPT.PUTRGBCOLOR 29293 . 30315) ( +\PSC.COLOR.TO.RGB 30317 . 32683)) (33671 69196 (PSCFONT.READFONT 33681 . 35692) (PSCFONT.SPELLFILE +35694 . 36507) (PSCFONT.COERCEFILE 36509 . 38081) (PSCFONTFROMCACHE.SPELLFILE 38083 . 39068) ( +PSCFONTFROMCACHE.COERCEFILE 39070 . 40722) (PSCFONT.WRITEFONT 40724 . 41739) (READ-AFM-FILE 41741 . +47612) (CONVERT-AFM-FILES 47614 . 48826) (POSTSCRIPT.GETFONTID 48828 . 50223) (POSTSCRIPT.FONTCREATE +50225 . 63119) (\POSTSCRIPT.SPECIALFONT.SCALEDWIDTHS 63121 . 65518) (POSTSCRIPT.FONTSAVAILABLE 65520 + . 67807) (POSTSCRIPT.FONTEXISTS? 67809 . 69194)) (69197 79106 (OPENPOSTSCRIPTSTREAM 69207 . 78772) ( +CLOSEPOSTSCRIPTSTREAM 78774 . 79104)) (79151 85477 (POSTSCRIPT.HARDCOPYW 79161 . 82268) ( +POSTSCRIPT.TEDIT 82270 . 82722) (POSTSCRIPTFILEP 82724 . 84212) (MAKEEPSFILE 84214 . 85475)) (85478 +129222 (POSTSCRIPT.BITMAPSCALE 85488 . 87944) (POSTSCRIPT.CLOSESTRING 87946 . 88499) ( +POSTSCRIPT.ENDPAGE 88501 . 89392) (POSTSCRIPT.OUTSTR 89394 . 90611) (POSTSCRIPT.PUTBITMAPBYTES 90613 + . 99084) (POSTSCRIPT.PUTCOMMAND 99086 . 100075) (POSTSCRIPT.SET-FAKE-LANDSCAPE 100077 . 104597) ( +POSTSCRIPT.SHOWACCUM 104599 . 106754) (POSTSCRIPT.STARTPAGE 106756 . 109458) (\POSTSCRIPTTAB 109460 . +110257) (\PS.BOUTFIXP 110259 . 111539) (\PS.SCALEHACK 111541 . 114184) (\PS.SCALEREGION 114186 . +114746) (\SCALEDBITBLT.PSC 114748 . 119058) (\SETPOS.PSC 119060 . 119541) (\SETXFORM.PSC 119543 . +122127) (\STRINGWIDTH.PSC 122129 . 122602) (\SWITCHFONTS.PSC 122604 . 128096) (\TERPRI.PSC 128098 . +129220)) (129257 183113 (\BITBLT.PSC 129267 . 129819) (\BLTSHADE.PSC 129821 . 134482) (\CHARWIDTH.PSC +134484 . 134991) (\CREATECHARSET.PSC 134993 . 136349) (\DRAWARC.PSC 136351 . 138729) (\DRAWCIRCLE.PSC +138731 . 140982) (\DRAWCURVE.PSC 140984 . 144828) (\DRAWELLIPSE.PSC 144830 . 147194) (\DRAWLINE.PSC +147196 . 149936) (\DRAWPOINT.PSC 149938 . 150514) (\DRAWPOLYGON.PSC 150516 . 153645) ( +\DSPBOTTOMMARGIN.PSC 153647 . 154334) (\DSPCLIPPINGREGION.PSC 154336 . 155711) (\DSPCOLOR.PSC 155713 + . 156644) (\DSPFONT.PSC 156646 . 160283) (\DSPLEFTMARGIN.PSC 160285 . 160971) (\DSPLINEFEED.PSC +160973 . 161563) (\DSPPUSHSTATE.PSC 161565 . 163025) (\DSPPOPSTATE.PSC 163027 . 166512) (\DSPRESET.PSC + 166514 . 167179) (\DSPRIGHTMARGIN.PSC 167181 . 167870) (\DSPROTATE.PSC 167872 . 168871) ( +\DSPSCALE.PSC 168873 . 169825) (\DSPSCALE2.PSC 169827 . 170667) (\DSPSPACEFACTOR.PSC 170669 . 171590) +(\DSPTOPMARGIN.PSC 171592 . 172163) (\DSPTRANSLATE.PSC 172165 . 174196) (\DSPXPOSITION.PSC 174198 . +174762) (\DSPYPOSITION.PSC 174764 . 175355) (\FILLCIRCLE.PSC 175357 . 177582) (\FILLPOLYGON.PSC 177584 + . 180821) (\FIXLINELENGTH.PSC 180823 . 182142) (\MOVETO.PSC 182144 . 182914) (\NEWPAGE.PSC 182916 . +183111)) (183169 205315 (\POSTSCRIPT.CHANGECHARSET 183179 . 183897) (\POSTSCRIPT.OUTCHARFN 183899 . +196169) (\POSTSCRIPT.PRINTSLUG 196171 . 197895) (\POSTSCRIPT.SPECIALOUTCHARFN 197897 . 200248) ( +\UPDATE.PSC 200250 . 201496) (\POSTSCRIPT.ACCENTFN 201498 . 202440) (\POSTSCRIPT.ACCENTPAIR 202442 . +205313)) (205413 207058 (\PSC.SPACEDISP 205423 . 205702) (\PSC.SPACEWID 205704 . 206323) (\PSC.SYMBOLS + 206325 . 207056)) (207167 210158 (\POSTSCRIPT.NSHASH 207177 . 210156))))) STOP diff --git a/library/POSTSCRIPTSTREAM.LCOM b/library/POSTSCRIPTSTREAM.LCOM index 74ceb4d1..1778b1df 100644 Binary files a/library/POSTSCRIPTSTREAM.LCOM and b/library/POSTSCRIPTSTREAM.LCOM differ diff --git a/library/UNICODE b/library/UNICODE deleted file mode 100644 index cf86b540..00000000 --- a/library/UNICODE +++ /dev/null @@ -1,1503 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - -(FILECREATED "23-Oct-2025 08:31:21" {WMEDLEY}UNICODE.;211 82245 - - :EDIT-BY rmk - - :CHANGES-TO (FNS UTOMCODE UTF8.INCCODEFN UTOMCODE? UTF8.PEEKCCODEFN) - (VARS UNICODECOMS) - (MACROS UNICODE.SMALLP) - - :PREVIOUS-DATE "22-Oct-2025 23:28:51" {WMEDLEY}UNICODE.;210) - - -(PRETTYCOMPRINT UNICODECOMS) - -(RPAQQ UNICODECOMS - ( - (* ;; "Unicode external formats and MCCS-to-Unicode mapping functions. Must be loaded after UNICODE-TABLES.") - - (COMS (* ; "External formats") - (FNS UTF8.OUTCHARFN UTF8.SLUG.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN - \UTF8.BACKCCODEFN) - (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16BE.BACKCCODEFN) - (FNS UTF16LE.OUTCHARFN UTF16LE.INCCODEFN UTF16LE.PEEKCCODEFN \UTF16LE.BACKCCODEFN) - (FNS READBOM WRITEBOM) - (INITVARS (EXTERNALEOL 'LF)) - (FNS MAKE-UNICODE-FORMATS) - (P (MAKE-UNICODE-FORMATS EXTERNALEOL)) - (ADDVARS (*DEFAULT-EXTERNALFORMATS* (UNIX :UTF-8))) - (FNS UTF8.BINCODE \UTF8.FETCHCODE) - (FNS UTF8.VALIDATE NUTF8-BYTE1-BYTES NUTF8-CODE-BYTES NUTF8-STRING-BYTES N-MCHARS) - (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE \UTF8.GETBASEBYTE - UNICODE.SMALLP))) - - (* ;; "") - - - (* ;; "These come after the translation tables have been loaded, since the Unix file names needed to read the mapping files depend on the UTF8 string coercions. Those functions are defined as EVQ in UFS, cannot be used until the tables exist. This assumes that previous files have only 7-bit MCCS characters in their names.") - - (FNS MTOUCODE UTOMCODE MTOUCODE? UTOMCODE? MTOUSTRING UTOMSTRING MTOUTF8STRING UTF8TOMSTRING) - (FNS XTOUCODE UTOXCODE XTOUCODE? UTOXCODE? XTOUSTRING UTOXSTRING XTOUTF8STRING) - - (* ;; "") - - (COMS (* ; "Write Unicode mapping files") - (FNS WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER - WRITE-UNICODE-MAPPING-FILENAME) - (FNS XCCS-UTF8-AFTER-OPEN) - - (* ;; "Automate dumping of a documentation prefix") - - [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" - :RADIX 16)) - (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX - 16] - (VARS UNICODE-MAPPING-HEADER)) - (FNS UTF8HEXSTRING) - (COMS (* ; "debugging") - (FNS SHOWCHARS) - (DECLARE%: DOEVAL@LOAD DONTCOPY (MACROS HEXCHAR OCTALCHAR))) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - UNICODE-EXPORTS)) - (PROP (FILETYPE) - UNICODE))) - - - -(* ;; -"Unicode external formats and MCCS-to-Unicode mapping functions. Must be loaded after UNICODE-TABLES." -) - - - - -(* ; "External formats") - -(DEFINEQ - -(UTF8.OUTCHARFN - [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 24-Apr-2025 15:43 by rmk") - (* ; "Edited 20-Jan-2025 20:45 by rmk") - (* ; "Edited 31-Jan-2024 00:32 by rmk") - (* ; "Edited 8-Aug-2021 13:02 by rmk:") - (* ; "Edited 17-Aug-2020 08:45 by rmk:") - (* ; "Edited 30-Jan-2020 23:08 by rmk:") - - (* ;; "Perhaps the translation table should already do the mapping for EOL to LF, but that seems to be a separate property of the stream. Also, CRLF=2 bytes.") - - (* ;; "Print UTF8 sequence for CHARCODE. Do not do MCCS to Unicode translation if RAW.") - - (IF (EQ CHARCODE (CHARCODE EOL)) - THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) - (\BOUTEOL STREAM) - ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM) - (IPLUS16 1 DATUM)) - (FOR C INSIDE (CL:IF RAW - CHARCODE - (UNICODE.TRANSLATE CHARCODE *MCCSTOUNICODE*)) - 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.SLUG.OUTCHARFN - [LAMBDA (STREAM CODE RAW) (* ; "Edited 24-Apr-2025 15:43 by rmk") - (* ; "Edited 21-Jan-2025 18:37 by rmk") - (* ; "Edited 14-Jan-2025 12:39 by rmk") - - (* ;; "Produces Unicode Representative FFFD as a slug for MCCS unmapped characters") - - (UTF8.OUTCHARFN STREAM (OR (CL:IF RAW - CODE - (XTOUCODE? CODE)) - (CONSTANT (HEXNUM? "FFFD"))) - T]) - -(UTF8.INCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 23-Oct-2025 08:31 by rmk") - (* ; "Edited 24-Apr-2025 15:44 by rmk") - (* ; "Edited 2-Feb-2024 11:44 by rmk") - (* ; "Edited 30-Jan-2024 22:56 by rmk") - (* ; "Edited 6-Aug-2021 16:02 by rmk:") - (* ; "Edited 6-Aug-2020 17:13 by rmk:") - - (* ;; "Do not do UNICODE to MCSS translation if RAW.") - - (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (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 (ILEQ BYTE1 127) - then - (* ;; - "Test first: Ascii is the common case. EOL requires its own translation") - - (SELCHARQ BYTE1 - (CR (SELECTC (fetch (STREAM EOLCONVENTION) of STREAM) - (CR.EOLC (* ; "Also eq BYTE1") - (CHARCODE EOL)) - (CRLF.EOLC (if (EQ (CHARCODE LF) - (\PEEKBIN STREAM T)) - then (\BIN STREAM) - (CL:WHEN COUNTP (SETQ COUNT 2)) - (CHARCODE EOL) - else BYTE1)) - BYTE1)) - (LF (CL:IF (EQ LF.EOLC (fetch (STREAM EOLCONVENTION) - of STREAM)) - (CHARCODE EOL) - BYTE1)) - BYTE1) - elseif (ILEQ BYTE1 223) - then (* ; "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)) - elseif (ILEQ BYTE1 239) - 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 (* ; "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]) - (CL:UNLESS RAW - (SETQ CODE (UNICODE.TRANSLATE (UNICODE.SMALLP CODE) - *UNICODETOMCCS*))) - (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) - CODE]) - -(UTF8.PEEKCCODEFN - [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 23-Oct-2025 08:26 by rmk") - (* ; "Edited 24-Apr-2025 15:44 by rmk") - (* ; "Edited 2-Feb-2024 11:48 by rmk") - (* ; "Edited 14-Jun-2021 22:53 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 MCCS translation if RAW") - - (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE) - (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) - - (* ;; "Distinguish on header bytex") - - (CL:UNLESS BYTE1 (RETURN NIL)) - [if (ILEQ BYTE1 127) - then - (* ;; - "Test first: Ascii is the common case. No need to back up, since we peeked.") - - (SETQ CODE BYTE1) - elseif [ILEQ BYTE1 223 (* ; "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] - elseif (ILEQ BYTE1 239) - 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 CODE)) - (BIN STREAM) - (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (* ; - "PEEK the last, no need to back it up") - (\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 (* ; "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 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 CODE)) - (BIN STREAM) - (SETQ BYTE4 (\PEEKBIN STREAM NOERROR)) - (\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] - (CL:WHEN (AND CODE (NOT RAW)) - (SETQ CODE (UNICODE.TRANSLATE (UNICODE.SMALLP CODE) - *UNICODETOMCCS*))) - (RETURN CODE]) - -(\UTF8.BACKCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 19-Jul-2022 15:30 by rmk") - (* ; "Edited 6-Aug-2021 16:04 by rmk:") - - (* ;; "\BACKFILEPTR is NIL at beginning of FILE. Presumably a little bit more efficient if we decoded the UTF8 bytes backwards and didn't do the peek, but probably not worth the complexity. ") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (BIND (C _ 0) WHILE (IF (\BACKFILEPTR STREAM) - THEN (ADD C -1) - (EQ 2 (LRSH (\PEEKBIN STREAM) - 6)) - ELSE (CL:WHEN COUNTP (SETQ *BYTECOUNTER* C)) - (RETURN NIL)) REPEATUNTIL (EQ C -4) - FINALLY (CL:WHEN COUNTP (SETQ *BYTECOUNTER* C)) - (RETURN (UTF8.PEEKCCODEFN STREAM NIL RAW]) -) -(DEFINEQ - -(UTF16BE.OUTCHARFN - [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 24-Apr-2025 15:44 by rmk") - (* ; "Edited 31-Jan-2024 00:32 by rmk") - (* ; "Edited 8-Aug-2021 13:09 by rmk:") - (* ; "Edited 30-Jan-2020 23:08 by rmk:") - - (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do MCCS to UNICODE translation if RAW.") - - (* ;; "Not sure about EOL conversion if truly %"raw%"") - - (IF (EQ CHARCODE (CHARCODE EOL)) - THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) - ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM) - (IPLUS16 1 DATUM))) - (FOR C INSIDE (CL:IF RAW - CHARCODE - (UNICODE.TRANSLATE CHARCODE *MCCSTOUNICODE*)) DO (\WOUT STREAM C]) - -(UTF16BE.INCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:45 by rmk") - (* ; "Edited 10-Mar-2024 12:00 by rmk") - (* ; "Edited 6-Aug-2021 16:05 by rmk:") - - (* ;; - "Do not do UNICODE to MCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (LET (CODE BYTE1 BYTE2 COUNT) - (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM))) - (SMALLP (SETQ BYTE2 (\BIN STREAM] - THEN (SETQ COUNT 2) - (SETQ CODE (create WORD - HIBYTE _ (\BIN STREAM) - LOBYTE _ (\BIN STREAM))) - (CL:UNLESS RAW - (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOMCCS*))) - (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) - CODE - ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) - -(UTF16BE.PEEKCCODEFN - [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 24-Apr-2025 15:45 by rmk") - (* ; "Edited 10-Mar-2024 12:01 by rmk") - (* ; "Edited 14-Jun-2021 22:58 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 MCCS 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 (create WORD - HIBYTE _ BYTE1 - LOBYTE _ BYTE2)) - (CL:IF RAW - CODE - (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)) - ELSEIF NOERROR - THEN NIL) - ELSEIF NOERROR - THEN NIL - ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) - -(\UTF16BE.BACKCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:28 by rmk") - (* ; "Edited 10-Mar-2024 12:02 by rmk") - (* ; "Edited 19-Jul-2022 15:14 by rmk") - (* ; "Edited 6-Aug-2021 16:07 by rmk:") - - (* ;; "\BACKFILEPTR is NIL at beginning of FILE, do nothing.") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (CL:WHEN (\BACKFILEPTR STREAM) - (LET (CODE (BYTE2 (\PEEKBIN STREAM))) - (IF (\BACKFILEPTR STREAM) - THEN (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -2)) - (SETQ CODE (create WORD - HIBYTE _ (\PEEKBIN STREAM) - LOBYTE _ BYTE2)) - (CL:IF RAW - CODE - (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)) - ELSEIF COUNTP - THEN (SETQ *BYTECOUNTER* -1) - NIL)))]) -) -(DEFINEQ - -(UTF16LE.OUTCHARFN - [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 24-Apr-2025 15:45 by rmk") - (* ; "Edited 10-Mar-2024 11:58 by rmk") - (* ; "Edited 8-Aug-2021 13:09 by rmk:") - (* ; "Edited 30-Jan-2020 23:08 by rmk:") - - (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do MCCS to UNICODE translation if RAW.") - - (* ;; "Not sure about EOL conversion if truly %"raw%"") - - (IF (EQ CHARCODE (CHARCODE EOL)) - THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) - ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM) - (IPLUS16 1 DATUM))) - (FOR C INSIDE (CL:IF RAW - CHARCODE - (UNICODE.TRANSLATE CHARCODE *MCCSTOUNICODE*)) - DO (BOUT STREAM (fetch LOBYTE of CHARCODE)) - (BOUT STREAM (fetch HIBYTE of CHARCODE]) - -(UTF16LE.INCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:45 by rmk") - (* ; "Edited 10-Mar-2024 12:03 by rmk") - (* ; "Edited 6-Aug-2021 16:05 by rmk:") - - (* ;; - "Do not do UNICODE to MCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (LET (CODE BYTE1 BYTE2 COUNT) - (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM))) - (SMALLP (SETQ BYTE2 (\BIN STREAM] - THEN (SETQ COUNT 2) - (SETQ CODE (create WORD - LOBYTE _ (\BIN STREAM) - HIBYTE _ (\BIN STREAM))) - (CL:UNLESS RAW - (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOMCCS*))) - (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) - CODE - ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) - -(UTF16LE.PEEKCCODEFN - [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 24-Apr-2025 15:46 by rmk") - (* ; "Edited 10-Mar-2024 11:43 by rmk") - (* ; "Edited 14-Jun-2021 22:58 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 MCCS 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 BYTE2 8) - BYTE1)) - (CL:IF RAW - CODE - (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)) - ELSEIF NOERROR - THEN NIL) - ELSEIF NOERROR - THEN NIL - ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) - -(\UTF16LE.BACKCCODEFN - [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:28 by rmk") - (* ; "Edited 10-Mar-2024 12:04 by rmk") - (* ; "Edited 19-Jul-2022 15:14 by rmk") - (* ; "Edited 6-Aug-2021 16:07 by rmk:") - - (* ;; "\BACKFILEPTR is NIL at beginning of FILE, do nothing.") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (CL:WHEN (\BACKFILEPTR STREAM) - (LET (CODE (BYTE2 (\PEEKBIN STREAM))) - (IF (\BACKFILEPTR STREAM) - THEN (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -2)) - (SETQ CODE (create WORD - HIBYTE _ BYTE2 - LOBYTE _ (\PEEKBIN STREAM))) - (CL:IF RAW - CODE - (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)) - ELSEIF COUNTP - THEN (SETQ *BYTECOUNTER* -1) - NIL)))]) -) -(DEFINEQ - -(READBOM - [LAMBDA (STREAM COUNTP) (* ; "Edited 17-Jan-2025 11:29 by rmk") - (* ; "Edited 11-Mar-2024 23:53 by rmk") - (* ; "Edited 10-Mar-2024 13:01 by rmk") - - (* ;; "If COUNTP, this must be under a generic \INCCODE that binds *BYTECOUNTER*") - - (* ;; "Reads and decodes the BOM bytes. If BOM ispresent, the stream is left at the first following byte, otherwise the stream is reset to its position on entry (presumably 0).") - - (* ;; "I used the UNHEXTRING constants so that the hex bytes are visible in the code, maybe there's another function that does that?") - - (DECLARE (USEDFREE *BYTECOUNTER*)) - (SELECTC (\PEEKBIN STREAM T) - ((HEXNUM? "EF") - (BIN STREAM) - (if (EQ (CONSTANT (HEXNUM? "BB")) - (\PEEKBIN STREAM T)) - then (BIN STREAM) - (if (EQ (CONSTANT (HEXNUM? "BF")) - (\PEEKBIN STREAM T)) - then (BIN STREAM) - (CL:WHEN COUNTP (add *BYTECOUNTER* 3)) - :UTF-8 - else (\BACKFILEPTR STREAM)) - else (\BACKFILEPTR STREAM))) - ((HEXNUM? "FE") - (BIN STREAM) - (if (EQ (CONSTANT (HEXNUM? "FF")) - (\PEEKBIN STREAM T)) - then (BIN STREAM) - (CL:WHEN COUNTP (add *BYTECOUNTER* 2)) - :UTF-16BE - else (\BACKFILEPTR STREAM))) - ((HEXNUM? "FF") - (BIN STREAM) - (if (EQ (CONSTANT (HEXNUM? "FE")) - (\PEEKBIN STREAM T)) - then (BIN STREAM) - (CL:WHEN COUNTP (add *BYTECOUNTER* 2)) - :UTF-16LE - else (\BACKFILEPTR STREAM))) - NIL]) - -(WRITEBOM - [LAMBDA (STREAM FORMAT) (* ; "Edited 17-Jan-2025 11:29 by rmk") - (* ; "Edited 16-Mar-2024 20:53 by rmk") - (* ; "Edited 11-Mar-2024 23:53 by rmk") - (* ; "Edited 10-Mar-2024 13:01 by rmk") - - (* ;; "Writes a BOM that represents FORMAT (:UTF-8, :UTF16-BE, :UTF16-LE") - - (SELECTQ FORMAT - (:UTF-8 (BOUT STREAM (CONSTANT (HEXNUM? "EF"))) - (BOUT STREAM (CONSTANT (HEXNUM? "BB"))) - (BOUT STREAM (CONSTANT (HEXNUM? "BF")))) - (:UTF-16BE (BOUT STREAM (CONSTANT (HEXNUM? "FE"))) - (BOUT STREAM (CONSTANT (HEXNUM? "FF")))) - (:UTF-16LE (BOUT STREAM (CONSTANT (HEXNUM? "FF"))) - (BOUT STREAM (HEXNUM? "FE"))) - NIL]) -) - -(RPAQ? EXTERNALEOL 'LF) -(DEFINEQ - -(MAKE-UNICODE-FORMATS - [LAMBDA (EXTERNALEOL) (* ; "Edited 17-Jan-2025 18:38 by rmk") - (* ; "Edited 10-Mar-2024 11:55 by rmk") - (* ; "Edited 8-Dec-2023 15:19 by rmk") - (* ; "Edited 19-Jul-2022 15:36 by rmk") - (* ; "Edited 6-Aug-2021 16:08 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.") - - (MAKE-EXTERNALFORMAT :UTF-8 (FUNCTION UTF8.INCCODEFN) - (FUNCTION UTF8.PEEKCCODEFN) - (FUNCTION \UTF8.BACKCCODEFN) - (FUNCTION UTF8.OUTCHARFN) - NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) - (MAKE-EXTERNALFORMAT :UTF-8-RAW [FUNCTION (LAMBDA (STREAM COUNTP) - (UTF8.INCCODEFN STREAM COUNTP T] - [FUNCTION (LAMBDA (STREAM NOERROR) - (UTF8.PEEKCCODEFN STREAM NOERROR T] - [FUNCTION (LAMBDA (STREAM COUNTP) - (\UTF8.BACKCCODEFN STREAM COUNTP T] - [FUNCTION (LAMBDA (STREAM CHARCODE) - (UTF8.OUTCHARFN STREAM CHARCODE T] - NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) - (MAKE-EXTERNALFORMAT :UTF-16BE (FUNCTION UTF16BE.INCCODEFN) - (FUNCTION UTF16BE.PEEKCCODEFN) - (FUNCTION \UTF16BE.BACKCCODEFN) - (FUNCTION UTF16BE.OUTCHARFN) - NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) - (MAKE-EXTERNALFORMAT :UTF-16BE-RAW [FUNCTION (LAMBDA (STREAM COUNTP) - (UTF16BE.INCCODEFN STREAM COUNTP T] - [FUNCTION (LAMBDA (STREAM NOERROR) - (UTF16BE.PEEKCCODEFN STREAM NOERROR T] - [FUNCTION (LAMBDA (STREAM COUNTP) - (\UTF16BE.BACKCCODEFN STREAM COUNTP T] - [FUNCTION (LAMBDA (STREAM CHARCODE) - (UTF16BE.OUTCHARFN STREAM CHARCODE T] - NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) - (MAKE-EXTERNALFORMAT :UTF-16LE (FUNCTION UTF16LE.INCCODEFN) - (FUNCTION UTF16LE.PEEKCCODEFN) - (FUNCTION \UTF16LE.BACKCCODEFN) - (FUNCTION UTF16LE.OUTCHARFN) - NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) - (MAKE-EXTERNALFORMAT :UTF-16LE-RAW [FUNCTION (LAMBDA (STREAM COUNTP) - (UTF16LE.INCCODEFN STREAM COUNTP T] - [FUNCTION (LAMBDA (STREAM NOERROR) - (UTF16LE.PEEKCCODEFN STREAM NOERROR T] - [FUNCTION (LAMBDA (STREAM COUNTP) - (\UTF16LE.BACKCCODEFN STREAM COUNTP T] - [FUNCTION (LAMBDA (STREAM CHARCODE) - (UTF16LE.OUTCHARFN STREAM CHARCODE T] - NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) - (\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT using (FIND-FORMAT :UTF-8) - NAME _ :UTF-8-SLUG OUTCHARFN _ - (FUNCTION UTF8.SLUG.OUTCHARFN]) -) - -(MAKE-UNICODE-FORMATS EXTERNALEOL) - -(ADDTOVAR *DEFAULT-EXTERNALFORMATS* (UNIX :UTF-8)) -(DEFINEQ - -(UTF8.BINCODE - [LAMBDA (STREAM RAW) (* ; "Edited 24-Apr-2025 15:28 by rmk") - (* ; "Edited 4-Feb-2024 01:06 by rmk") - (* ; "Edited 1-Feb-2024 11:21 by rmk") - (* ; "Edited 28-Dec-2023 13:32 by rmk") - (* ; "Edited 6-Aug-2021 16:02 by rmk:") - (* ; "Edited 6-Aug-2020 17:13 by rmk:") - - (* ;; "Decodes a UTF8 character code by binning from STREAM ") - - (* ;; "The validity of STREAM is guaranteed by the caller (presumably TEDIT), we aren't testing here for the validity of the trailing bytes.") - - (* ;; "This doesn't do EOL conversion or translation, unlike UTF8.INCCODEFN.") - - (LET ((BYTE1 (BIN STREAM)) - CODE) - [SETQ CODE (if (ILEQ BYTE1 127) - then BYTE1 - elseif (ILEQ BYTE1 223) - then (* ; "2 bytes") - (LOGOR (LLSH (LOADBYTE BYTE1 0 5) - 6) - (LOADBYTE (BIN STREAM) - 0 6)) - elseif (ILEQ BYTE1 239) - then (* ; "3 bytes") - (LOGOR (LLSH (LOADBYTE BYTE1 0 4) - 12) - (LLSH (LOADBYTE (BIN STREAM) - 0 6) - 6) - (LOADBYTE (BIN STREAM) - 0 6)) - else (* ; "4 bytes") - (LOGOR (LLSH (LOADBYTE BYTE1 0 3) - 18) - (LLSH (LOADBYTE (BIN STREAM) - 0 6) - 12) - (LLSH (LOADBYTE (BIN STREAM) - 0 6) - 6) - (LOADBYTE (BIN STREAM) - 0 6] - (CL:IF RAW - CODE - (UNICODE.TRANSLATE CODE *UNICODETOMCCS*))]) - -(\UTF8.FETCHCODE - [LAMBDA (CODESIZE BUFFER BYTEOFFSET) (* ; "Edited 28-Dec-2023 13:32 by rmk") - (* ; "Edited 6-Aug-2021 16:02 by rmk:") - (* ; "Edited 6-Aug-2020 17:13 by rmk:") - - (* ;; "Decodes a UTF8 byte sequence of size CODESIZE in BUFFER starting at BYTEOFFSET.") - - (* ;; "The validity of the thesize, buffer, and offset are guaranteed by the caller.") - - (LET ((BYTE1 (\GETBASEBYTE BUFFER BYTEOFFSET)) - BYTE2 BYTE3 BYTE4) - (SELECTQ CODESIZE - (2 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET))) - (LOGOR (LLSH (LOADBYTE BYTE1 0 5) - 6) - (LOADBYTE BYTE2 0 6))) - (3 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET))) - (SETQ BYTE3 (\UTF8.GETBASEBYTE BUFFER (IPLUS 2 BYTEOFFSET))) - (LOGOR (LLSH (LOADBYTE BYTE1 0 4) - 12) - (LLSH (LOADBYTE BYTE2 0 6) - 6) - (LOADBYTE BYTE3 0 6))) - (4 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET))) - (SETQ BYTE3 (\UTF8.GETBASEBYTE BUFFER (IPLUS 2 BYTEOFFSET))) - (SETQ BYTE4 (\UTF8.GETBASEBYTE BUFFER (IPLUS 3 BYTEOFFSET))) - (LOGOR (LLSH (LOADBYTE BYTE1 0 3) - 18) - (LLSH (LOADBYTE BYTE2 0 6) - 12) - (LLSH (LOADBYTE BYTE3 0 6) - 6) - (LOADBYTE BYTE4 0 6))) - (1 BYTE1) - (SHOULDNT]) -) -(DEFINEQ - -(UTF8.VALIDATE - [LAMBDA (STREAM BYTE) (* ; "Edited 2-Feb-2024 12:03 by rmk") - (* ; "Edited 28-Dec-2023 11:57 by rmk") - (* ; "Edited 6-Aug-2021 16:02 by rmk:") - (* ; "Edited 6-Aug-2020 17:13 by rmk:") - - (* ;; "Returns the codesize if the bytes starting at STREAM's current position form a valid UTF-8 sequence.") - - (* ;; "If BYTE is provided, it is interpreted as the just-read header byte with the stream is positioned just after it.") - - (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error--otherwise an error will happen if the streams runs out of necessary bytes.") - - (* ;; "For valid sequences, returns the same value as UTF8-SIZE-FROM-BYTE1, but this reads/validates the rest of the bytes. On a non-NILreturn the stream is positioned before the header byte of the next putative code. The stream position is uncertain on a NIL return.") - - (* ;; "") - - (* ;; "Distinguish on the header byte BYTE. Not SMALLP presumably if ENDOFSTREAMOP did something unusual.") - - (CL:UNLESS BYTE - (SETQ BYTE (BIN STREAM))) - (CL:WHEN (SMALLP BYTE) - (if (ILEQ BYTE 127) - then 1 - elseif (ILEQ BYTE 223) - then (* ; " 2 bytes") - (CL:UNLESS (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] - (ILESSP BYTE 128)) - 2) - elseif (ILEQ BYTE 239) - then (* ; "3 bytes") - (CL:UNLESS (OR (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] - (ILESSP BYTE 128)) - (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] - (ILESSP BYTE 128))) - 3) - else (* ; "4 bytes") - (CL:UNLESS (OR (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] - (ILESSP BYTE 128)) - (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] - (ILESSP BYTE 128)) - (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] - (ILESSP BYTE 128))) - 4)))]) - -(NUTF8-BYTE1-BYTES - [LAMBDA (BYTE1) (* ; "Edited 3-Feb-2024 15:00 by rmk") - (* ; "Edited 8-Jan-2024 10:57 by rmk") - (* ; "Edited 28-Jun-2022 00:02 by rmk") - (* ; "Edited 10-Aug-2020 12:35 by rmk:") - - (* ;; "Returns the number of bytes in a UTF8 code representation whose first byte is BYTEE1. ") - - (IF (ILEQ BYTE1 127) - THEN 1 - ELSEIF (ILEQ BYTE1 223) - THEN 2 - ELSEIF (ILEQ BYTE1 239) - THEN 3 - ELSE 4]) - -(NUTF8-CODE-BYTES - [LAMBDA (CODE) (* ; "Edited 3-Feb-2024 14:42 by rmk") - (* ; "Edited 8-Jan-2024 10:57 by rmk") - (* ; "Edited 28-Jun-2022 00:02 by rmk") - (* ; "Edited 10-Aug-2020 12:35 by rmk:") - - (* ;; "Returns the number of bytes needed to encode in UTF8 a number headed by BYTE. ") - - (IF (ILESSP CODE 128) - THEN 1 - ELSEIF (ILESSP CODE 2048) - THEN (* ; "x800") - 2 - ELSEIF (ILESSP CODE 65536) - THEN (* ; "x10000") - 3 - ELSEIF (ILESSP CODE 2097152) - THEN (* ; "x200000") - 4 - ELSE (ERROR "INVALID UTF-8 CODE"]) - -(NUTF8-STRING-BYTES - [LAMBDA (STRING RAW) (* ; "Edited 2-Sep-2025 10:40 by rmk") - (* ; "Edited 24-Apr-2025 15:37 by rmk") - (* ; "Edited 3-Feb-2024 21:32 by rmk") - (* ; "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 MCCS string unless RAWFLG. ") - - (for I C from 1 while (SETQ C (NTHCHARCODE STRING I)) sum (NUTF8-CODE-BYTES (CL:IF RAW - C - (MTOUCODE C))]) - -(N-MCHARS - [LAMBDA (UTF8STRING) (* ; "Edited 9-Sep-2025 08:35 by rmk") - - (* ;; "Returns the number of MCCS characters coded in UTF8STRING") - - (for I B from 1 while (SETQ B (NTHCHARCODE UTF8STRING I)) by (NUTF8-BYTE1-BYTES B) count T]) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS UNICODE.TRANSLATE MACRO [OPENLAMBDA (CODE TRANSLATION-TABLE DONTFAKE RETURNALL) - - (* ;; "If RETURNALL and there are alternatives in the RANG, the list is returned. Othewise just the first one if the fake flag allows ") - - (LET [(RANGE (OR (GETHASH CODE TRANSLATION-TABLE) - (UNICODE.UNMAPPED CODE TRANSLATION-TABLE - DONTFAKE] - (CL:WHEN RANGE - (if (AND RETURNALL (CDR RANGE)) - then RANGE - else (SETQ RANGE (CAR RANGE)) - (CL:IF DONTFAKE - (TRUECODEP RANGE TRANSLATION-TABLE) - RANGE)))]) - -(PUTPROPS \UTF8.GETBASEBYTE MACRO ((BASE OFFSET ERROR?) (* ; - "Fetches the OFFSET'th byte from BASE, checking for UTF-8 validity if ERROR?") - (IF ERROR? - THEN (LET ((BYTE (\GETBASEBYTE BASE OFFSET))) - (CL:WHEN (ILESSP BYTE 128) - (ERROR "INVALID UTF8 BYTE" BYTE)) - BYTE) - ELSE (\GETBASEBYTE BASE OFFSET)))) - -(PUTPROPS UNICODE.SMALLP MACRO [OPENLAMBDA (UNICODE) (* ; - "Cananonicalizes a large UNICODE for EQ hash-testing") - (OR (SMALLP UNICODE) - (CAR (OR (MEMBER UNICODE *LARGEUNICODES*) - (PUSH *LARGEUNICODES* UNICODE]) -) -) - - - -(* ;; "") - - - - -(* ;; -"These come after the translation tables have been loaded, since the Unix file names needed to read the mapping files depend on the UTF8 string coercions. Those functions are defined as EVQ in UFS, cannot be used until the tables exist. This assumes that previous files have only 7-bit MCCS characters in their names." -) - -(DEFINEQ - -(MTOUCODE - [LAMBDA (MCODE) (* ; "Edited 4-Sep-2025 15:10 by rmk") - (* ; "Edited 24-Apr-2025 10:19 by rmk") - (* ; "Edited 9-Aug-2020 09:04 by rmk:") - (UNICODE.TRANSLATE MCODE *MCCSTOUNICODE*]) - -(UTOMCODE - [LAMBDA (UNICODE) (* ; "Edited 23-Oct-2025 08:23 by rmk") - (* ; "Edited 24-Apr-2025 10:17 by rmk") - (* ; "Edited 16-Jan-2025 23:46 by rmk") - (* ; "Edited 9-Aug-2020 09:04 by rmk:") - (UNICODE.TRANSLATE (UNICODE.SMALLP UNICODE) - *UNICODETOMCCS*]) - -(MTOUCODE? - [LAMBDA (MCODE) (* ; "Edited 4-Sep-2025 15:09 by rmk") - (* ; "Edited 24-Apr-2025 10:18 by rmk") - (* ; "Edited 20-Jan-2025 20:38 by rmk") - (* ; "Edited 18-Jan-2025 11:44 by rmk") - (* ; "Edited 15-Jan-2025 19:51 by rmk") - (* ; "Edited 14-Jan-2025 13:14 by rmk") - (* ; "Edited 9-Aug-2020 09:04 by rmk:") - - (* ;; "Returns the Unix range-code(s) corresponding to MCODE if there are true mapppings, otherwise NIL. Alternative codes are returned in a list, the code itself is returned for a singleton.") - - (UNICODE.TRANSLATE MCODE *MCCSTOUNICODE* T T]) - -(UTOMCODE? - [LAMBDA (UNICODE) (* ; "Edited 23-Oct-2025 08:24 by rmk") - (* ; "Edited 24-Apr-2025 10:18 by rmk") - (* ; "Edited 19-Jan-2025 21:14 by rmk") - (* ; "Edited 18-Jan-2025 11:46 by rmk") - (* ; "Edited 15-Jan-2025 19:51 by rmk") - (* ; "Edited 14-Jan-2025 13:14 by rmk") - (* ; "Edited 9-Aug-2020 09:04 by rmk:") - - (* ;; "Returns the MCCS range-code(s) corresponding to UNICODE if there are true mapppings, otherwise NIL. ") - - (* ;; - " NOTE: Alternative codes are returned in a list, the code itself is returned for a singleton.") - - (* ;; "Canonicalize unicodes outside of the 16-bit plane") - - (UNICODE.TRANSLATE (UNICODE.SMALLP UNICODE) - *UNICODETOMCCS* T T]) - -(MTOUSTRING - [LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 12:19 by rmk") - (* ; "Edited 29-Apr-2025 12:01 by rmk") - - (* ;; "Converts MCCS codes in MSTRING to Unicodes.") - - (for I MCODE (USTRING _ (CL:IF DESTRUCTIVE - MSTRING - (CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I)) - do (RPLCHARCODE USTRING I (MTOUCODE MCODE)) finally (RETURN USTRING]) - -(UTOMSTRING - [LAMBDA (USTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 12:18 by rmk") - (* ; "Edited 29-Apr-2025 12:00 by rmk") - - (* ;; "Converts Unicodes to MCCS codes in USTRING.") - - (for I UCODE (MSTRING _ (CL:IF DESTRUCTIVE - USTRING - (CONCAT USTRING))) from 1 while (SETQ UCODE (NTHCHARCODE USTRING I)) - do (RPLCHARCODE MSTRING I (UTOMCODE UCODE)) finally (RETURN MSTRING]) - -(MTOUTF8STRING - [LAMBDA (MSTRING) (* ; "Edited 9-Sep-2025 07:51 by rmk") - (* ; "Edited 4-Sep-2025 15:13 by rmk") - (* ; "Edited 2-Sep-2025 11:12 by rmk") - (* ; "Edited 24-Apr-2025 15:37 by rmk") - (* ; "Edited 3-Feb-2024 14:55 by rmk") - (* ; "Edited 10-Aug-2020 21:42 by rmk:") - - (* ;; - "Produces a string that contains the UTF8 bytes that represent the characters in MSTRING. ") - - (* ;; "The resulting string will not be directly interpretable inside Medley.") - - (if (if (STRINGP MSTRING) - then (OR (ffetch (STRINGP FATSTRINGP) of MSTRING) - (thereis C instring MSTRING suchthat (IGEQ C 128))) - elseif (LITATOM MSTRING) - then (OR (ffetch (LITATOM FATPNAMEP) of MSTRING) - (thereis C inatom MSTRING suchthat (IGEQ C 128))) - else T) - then (LET [(USTR (ALLOCSTRING (NUTF8-STRING-BYTES MSTRING] - (for I UCODE MCODE (SINDEX _ 0) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I)) - do (SETQ UCODE (MTOUCODE MCODE)) - (if (ILESSP UCODE 128) - then (RPLCHARCODE USTR (ADD SINDEX 1) - UCODE) - elseif (ILESSP UCODE 2048) - then (* ; "x800") - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 3 6) - (LRSH UCODE 6))) - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 2 6) - (LOADBYTE UCODE 0 6))) - elseif (ILESSP UCODE 65536) - then (* ; "x10000") - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 7 5) - (LRSH UCODE 12))) - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 2 6) - (LOADBYTE UCODE 6 6))) - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 2 6) - (LOADBYTE UCODE 0 6))) - elseif (ILESSP UCODE 2097152) - then (* ; "x200000") - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 15 4) - (LRSH UCODE 18))) - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 2 6) - (LOADBYTE UCODE 12 6))) - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 2 6) - (LOADBYTE UCODE 6 6))) - (RPLCHARCODE USTR (ADD SINDEX 1) - (LOGOR (LLSH 2 6) - (LOADBYTE UCODE 0 6))) - else (SHOULDNT))) - USTR) - else MSTRING]) - -(UTF8TOMSTRING - [LAMBDA (UTF8STRING) (* ; "Edited 22-Oct-2025 22:00 by rmk") - (* ; "Edited 16-Oct-2025 14:39 by rmk") - (* ; "Edited 9-Sep-2025 08:59 by rmk") - (CL:UNLESS (OR (STRINGP UTF8STRING) - (LITATOM UTF8STRING)) - (SETQ UTF8STRING (MKSTRING UTF8STRING))) - (CL:WHEN (ffetch (STRINGP FATSTRINGP) of UTF8STRING) - (\ILLEGAL.ARG UTF8STRING)) - (LET* ((NMCHARS (N-MCHARS UTF8STRING)) - (MSTRING (ALLOCSTRING NMCHARS))) - [for M NBYTES BYTE1 (BASE _ (ffetch (STRINGP BASE) of UTF8STRING)) from 1 to NMCHARS - as OFFSET from (fetch (STRINGP OFFST) of MSTRING) by NBYTES - do (SETQ BYTE1 (\GETBASEBYTE BASE OFFSET)) - (SETQ NBYTES (NUTF8-BYTE1-BYTES BYTE1)) - (RPLCHARCODE MSTRING M (UTOMCODE (\UTF8.FETCHCODE NBYTES BASE OFFSET] - MSTRING]) -) -(DEFINEQ - -(XTOUCODE - [LAMBDA (XCODE) (* ; "Edited 4-Sep-2025 15:09 by rmk") - (* ; "Edited 24-May-2025 23:16 by rmk") - (* ; "Edited 24-Apr-2025 15:27 by rmk") - (* ; "Edited 9-Aug-2020 09:04 by rmk:") - (UNICODE.TRANSLATE (XTOMCODE XCODE) - *MCCSTOUNICODE*]) - -(UTOXCODE - [LAMBDA (UNICODE) (* ; "Edited 24-May-2025 23:17 by rmk") - (* ; "Edited 24-Apr-2025 15:28 by rmk") - (* ; "Edited 16-Jan-2025 23:46 by rmk") - (* ; "Edited 9-Aug-2020 09:04 by rmk:") - (MTOXCODE (UNICODE.TRANSLATE UNICODE *UNICODETOMCCS*]) - -(XTOUCODE? - [LAMBDA (XCCSCODE) (* ; "Edited 24-May-2025 23:18 by rmk") - (* ; "Edited 24-Apr-2025 15:27 by rmk") - (* ; "Edited 20-Jan-2025 20:38 by rmk") - (* ; "Edited 18-Jan-2025 11:44 by rmk") - (* ; "Edited 15-Jan-2025 19:51 by rmk") - (* ; "Edited 14-Jan-2025 13:14 by rmk") - (* ; "Edited 9-Aug-2020 09:04 by rmk:") - - (* ;; "Returns the Unix range-code(s) corresponding to XCCSCODE if there are true mapppings, otherwise NIL. Alternative codes are returned in a list, the code itself is returned for a singleton.") - - (UNICODE.TRANSLATE (XTOMCODE XCCSCODE) - *MCCSTOUNICODE* T T]) - -(UTOXCODE? - [LAMBDA (UNICODE) (* ; "Edited 24-May-2025 23:19 by rmk") - (* ; "Edited 24-Apr-2025 15:28 by rmk") - (* ; "Edited 19-Jan-2025 21:14 by rmk") - (* ; "Edited 18-Jan-2025 11:46 by rmk") - (* ; "Edited 15-Jan-2025 19:51 by rmk") - (* ; "Edited 14-Jan-2025 13:14 by rmk") - (* ; "Edited 9-Aug-2020 09:04 by rmk:") - - (* ;; "Returns the XCCS range-code(s) corresponding to UNICODE if there are true mapppings, otherwise NIL. ") - - (* ;; - " NOTE: Alternative codes are returned in a list, the code itself is returned for a singleton.") - - (MTOXCODE (UNICODE.TRANSLATE UNICODE *UNICODETOMCCS* T T]) - -(XTOUSTRING - [LAMBDA (XSTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 12:00 by rmk") - (* ; "Edited 29-Apr-2025 12:01 by rmk") - - (* ;; "Converts XCCS codes in XSTRING to Unicodes.") - - (for I UCODE XCODE (USTRING _ (CL:IF DESTRUCTIVE - XSTRING - (CONCAT XSTRING))) from 1 while (SETQ XCODE (NTHCHARCODE - XSTRING I)) - do (RPLCHARCODE USTRING I (XTOUCODE XCODE)) finally (RETURN USTRING]) - -(UTOXSTRING - [LAMBDA (USTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 11:54 by rmk") - (* ; "Edited 29-Apr-2025 12:00 by rmk") - - (* ;; "Converts Unicodes in USTRING to XCCS codes.") - - (for I XCODE UCODE (XSTRING _ (CL:IF DESTRUCTIVE - USTRING - (CONCAT USTRING))) from 1 while (SETQ UCODE (NTHCHARCODE - USTRING I)) - unless (EQ UCODE (SETQ XCODE (UTOXCODE UCODE))) do (RPLCHARCODE XSTRING I XCODE) - finally (RETURN XSTRING]) - -(XTOUTF8STRING - [LAMBDA (XSTRING) (* ; "Edited 4-Sep-2025 18:37 by rmk") - (* ; "Edited 2-Sep-2025 11:37 by rmk") - (* ; "Edited 29-Apr-2025 12:53 by rmk") - (* ; "Edited 24-Apr-2025 15:42 by rmk") - (* ; "Edited 3-Feb-2024 14:55 by rmk") - (* ; "Edited 10-Aug-2020 21:42 by rmk:") - - (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XSTRING. Applies the ") - - (* ;; "The resulting string will not be interpretable inside Medley.") - - (for I C (MSTRING _ (CONCAT XSTRING)) from 1 while (SETQ C (NTHCHARCODE XSTRING I)) - do (RPLCHARCODE MSTRING I (XTOMCODE C)) finally (RETURN (MTOUTF8STRING MSTRING]) -) - - - -(* ;; "") - - - - -(* ; "Write Unicode mapping files") - -(DEFINEQ - -(WRITE-UNICODE-MAPPING - [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 4-Jan-2024 22:44 by rmk") - (* ; "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 :UTF-8-RAW) - (WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES) - (SORT IMAPPING T) - (FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING - DO (SETQ LEFTC (CAR M)) - (SETQ FIRSTRIGHTC (CADR M)) - (CL:UNLESS (EQ CSET (LRSH LEFTC 8)) - (SETQ CSET (LRSH LEFTC 8)) - (SETQ CSI (ASSOC CSET CSETINFO)) - (PRINTOUT STREAM T "# " .P2 (CADR CSI) - " " - (CADDR CSI) - T)) - (PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4) - %# - (FOR RIGHTC IN (CDR M) DO (PRINTOUT NIL " " "0x" (HEXSTRING RIGHTC 4))) - " # " - (SELECTC FIRSTRIGHTC - (UNDEFINEDCODE - (* ;; "FFFF") - - "UNDEFINED") - (MISSINGCODE - (* ;; "FFFE") - - "MISSING") - (IF (ILESSP FIRSTRIGHTC 32) - THEN (* ; "Control chars") - [CONCAT "^" (CHARACTER (IPLUS FIRSTRIGHTC (CHARCODE @] - ELSE (CHARACTER FIRSTRIGHTC))) - T)) - (FULLNAME STREAM)) - ELSEIF (NOT EMPTYOK) - THEN (PRINTOUT T "THERE ARE NO MAPPINGS") - (CL:WHEN INCLUDECHARSETS - (PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS) - T)) - NIL]) - -(WRITE-UNICODE-INCLUDED - [LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:") - - (* ;; "CSETINFO is a list of (num string name) for each included character set.") - - (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING) - - (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings") - - [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN - XCCS-SET-NAMES - COLLECT (CAR CSI))) - JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES) - (FIND N IN XCCS-SET-NAMES - SUCHTHAT (EQ C (CADR N))) - (HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C] - (IF (SETQ POS (STRPOS "-" (CAR KNOWN))) - THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING - (CAR KNOWN) - 1 - (SUB1 POS)) - :RADIX 8) - TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) - (ADD1 POS)) - :RADIX 8) - COLLECT (LIST I (OCTALSTRING I) - (CADR KNOWN))) - ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN) - :RADIX 8) - KNOWN] - (SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M) - 8) - ICSETS)) - COLLECT - - (* ;; "The attested subset of INCLUDED") - - (CL:UNLESS (MEMB CSI CSETINFO) - (PUSH CSETINFO CSI)) - M)) - - (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges") - - (SETQ CSETINFO (SORT CSETINFO T)) - [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO - COLLECT (CAR CSI)) WHILE CTAIL - COLLECT (SETQ START (CAR CTAIL)) - (SETQ END START) - (CONS START (WHILE [AND (CDR CTAIL) - (EQ END (SUB1 (CADR CTAIL] - COLLECT (SETQ CTAIL (CDR CTAIL)) - (SETQ END (CAR CTAIL] - - (* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name") - - [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES - JOIN (SETQ LAST (CAR (LAST R))) - (IF (EQ (CAR R) - LAST) - THEN (CONS (OCTALSTRING (CAR R))) - ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING - (CAR R)) - "-" - (OCTALSTRING LAST))) - XCCS-SET-NAMES)) - THEN (CONS (CADR KNOWN)) - ELSEIF (CDDR R) - THEN (CONS STR) - ELSE (LIST (OCTALSTRING (CAR R)) - (OCTALSTRING LAST] - (CL:VALUES IMAPPING CSETINFO RANGES]) - -(WRITE-UNICODE-MAPPING-HEADER - [LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 5-Jan-2024 13:24 by rmk") - (* ; "Edited 4-Aug-2020 17:38 by rmk:") - - (* ;; "Writes the standard per-file header information") - - (FOR LINE IN UNICODE-MAPPING-HEADER - DO (PRINTOUT STREAM "#" 2) - (SELECTQ LINE - (XCCSCHARACTERSETS - (PRINTOUT STREAM " XCCS charset") - (IF (CDR CSETINFO) - THEN (PRINTOUT STREAM "s:" -4) - (FOR R IN RANGES DO (PRINTOUT STREAM R " ")) - ELSE (* ; "Singleton") - (PRINTOUT STREAM ": " -4 (CADAR CSETINFO) - " " - (CADDAR CSETINFO))) - (TERPRI STREAM)) - (DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME NO.LEADING.SPACES) - ) - T)) - (PRINTOUT STREAM LINE T))) - (TERPRI STREAM]) - -(WRITE-UNICODE-MAPPING-FILENAME - [LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:") - (PACKFILENAME 'BODY [OR FILE (CONCATLIST - (CONS 'XCCS- (IF (CDR CSETINFO) - THEN (FOR RTAIL R ON RANGES - JOIN (SETQ R (CAR RTAIL)) - (SETQ R - (CL:IF (LISTP R) - (LIST (CAR R) - "-" - (CDR R)) - (CONS R))) - (CL:IF (CDR RTAIL) - (NCONC1 R ",")) - R) - ELSE (LIST (CADAR CSETINFO) - "=" - (CADDAR CSETINFO] - 'DIRECTORY - (CAR UNICODEDIRECTORIES) - 'EXTENSION - 'TXT]) -) -(DEFINEQ - -(XCCS-UTF8-AFTER-OPEN - [LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 3-Jan-2024 10:27 by rmk") - (* ; "Edited 13-Aug-2020 11:54 by rmk:") - - (* ;; - "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF-8. For development") - - (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM))) - [EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM) - 'EXTENSION] - (NOT (ASSOC 'EXTERNALFORMAT PARAMETERS))) - (STREAMPROP STREAM 'EXTERNALFORMAT :UTF-8))]) -) - - - -(* ;; "Automate dumping of a documentation prefix") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) - -(RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)) - - -(CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) - (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))) -) -) - -(RPAQQ UNICODE-MAPPING-HEADER - ("" " Name: XCCS (Version 2.0) to Unicode" " Unicode version: 3.0" - XCCSCHARACTERSETS " Table version: 0.1" " Table format: Format A" - DATE " Author: Ron Kaplan " "" - "This file contains mappings from the Xerox Character Code Standard (version" - "2.0, 1990) into Unicode 3.0. standard codes. That is an extension of the" - "version of XCCS corresponding to the fonts in the Medley system." "" - "The format of this file conforms to the format of the other Unicode-supplied" - "mapping files:" " Three white-space (tab or spaces) separated columns:" - " Column 1 is the XCCS code (as hex 0xXXXX)" - " Column 2 is the corresponding Unicode (as hex 0xXXXX)" - " Column 3 (after #) is a comment column. For convenience, it contains the" - " Unicode character itself and the Unicode character names when available." - "Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED" - "Unicode FFFE is used for XCCS codes that have not yet been filled in." - "(Column 3 = MISSING)" "" "This file is encoded in UTF-8, so that the Unicode characters" - "are properly displayed in Column 3 and can be edited by standard" - "Unicode-enabled editors (e.g. Mac Textedit)." "" - "This file can also be read by the function" - "READ-UNICODE-MAPPING in the UNICODE Medley library package." "" - "The entries are in XCCS order and grouped by character sets. In front of" - "the mappings, for convenience, there is a line with the octal XCCS" - "character set, after #." "" - "Note that a given XCCS code might map to codes in several different Unicode" - "positions, since there are repetitions in the Unicode standard." "" - "For more details, see the associated README.TXT file." "" - "Any comments or problems, contact ")) -(DEFINEQ - -(UTF8HEXSTRING - [LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:") - - (* ;; "Utility to produces the UTF8 hexstring representing CODE") - - (HEXSTRING (IF (ILESSP CHARCODE 128) - THEN CHARCODE - ELSEIF (ILESSP CHARCODE 2048) - THEN (* ; "x800") - (LOGOR (LLSH (LOGOR (LLSH 3 6) - (LRSH CHARCODE 6)) - 8) - (LOGOR (LLSH 2 6) - (LOADBYTE CHARCODE 0 6))) - ELSEIF (ILESSP CHARCODE 65536) - THEN (* ; "x10000") - (LOGOR (LLSH (LOGOR (LLSH 7 5) - (LRSH CHARCODE 12)) - 16) - (LLSH (LOGOR (LLSH 2 6) - (LOADBYTE CHARCODE 6 6)) - 8) - (LOGOR (LLSH 2 6) - (LOADBYTE CHARCODE 0 6))) - ELSEIF (ILESSP CHARCODE 2097152) - THEN (* ; "x200000") - (LOGOR (LLSH (LOGOR (LLSH 15 4) - (LRSH CHARCODE 18)) - 24) - (LLSH (LOGOR (LLSH 2 6) - (LOADBYTE CHARCODE 12 6)) - 16) - (LLSH (LOGOR (LLSH 2 6) - (LOADBYTE CHARCODE 6 6)) - 8) - (LOGOR (LLSH 2 6) - (LOADBYTE CHARCODE 0 6))) - ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) -) - - - -(* ; "debugging") - -(DEFINEQ - -(SHOWCHARS - [LAMBDA (FONT FROMCHAR TOCHAR ONELINE) (* ; "Edited 5-Oct-2025 17:41 by rmk") - (* ; "Edited 7-Sep-2025 20:29 by rmk") - (* ; "Edited 2-Sep-2025 10:26 by rmk") - (* ; "Edited 24-Jul-2025 11:30 by rmk") - (* ; "Edited 8-Jun-2025 20:05 by rmk") - (* ; "Edited 26-Jan-2024 14:18 by mth") - (* ; "Edited 1-Aug-2020 09:27 by rmk:") - [SETQ FONT (FONTCREATE (OR FONT '(CLASSIC 12] - (RESETLST - [LET ((OLDFONT (DSPFONT NIL T)) - CHARS) - (CL:UNLESS (CHARCODEP FROMCHAR) - (SETQ FROMCHAR (OR (CHARCODE.DECODE FROMCHAR T) - FROMCHAR))) - (SETQ CHARS (if (LISTP FROMCHAR) - elseif (CHARCODEP FROMCHAR) - then (CL:UNLESS (CHARCODEP TOCHAR) - (SETQ TOCHAR (OR (CHARCODE.DECODE TOCHAR) - FROMCHAR))) - (for C from FROMCHAR to TOCHAR collect C) - else (CHCON FROMCHAR))) - [RESETSAVE OLDFONT '(PROGN (DSPFONT OLDVALUE] - (TERPRI) - (for C in CHARS do (PRINTOUT T .FONT OLDFONT (CONCAT (OCTALSTRING (\CHARSET C)) - "," - (OCTALSTRING (\CHAR8CODE C))) - 10 .FONT FONT (CHARACTER C)) - (CL:UNLESS ONELINE (PRINTOUT T T]) - (TERPRI]) -) -(DECLARE%: DOEVAL@LOAD DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS HEXCHAR MACRO ((CODE) - (HEXSTRING CODE))) - -(PUTPROPS OCTALCHAR MACRO [(CODE) - (CONCAT (OCTALSTRING (\CHARSET CODE)) - "," - (OCTALSTRING (LOGAND CODE 255]) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY - -(FILESLOAD (LOADCOMP) - UNICODE-EXPORTS) -) - -(PUTPROPS UNICODE FILETYPE :TCOMPL) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3488 19026 (UTF8.OUTCHARFN 3498 . 6514) (UTF8.SLUG.OUTCHARFN 6516 . 7180) ( -UTF8.INCCODEFN 7182 . 13035) (UTF8.PEEKCCODEFN 13037 . 18044) (\UTF8.BACKCCODEFN 18046 . 19024)) ( -19027 23717 (UTF16BE.OUTCHARFN 19037 . 20056) (UTF16BE.INCCODEFN 20058 . 21183) (UTF16BE.PEEKCCODEFN -21185 . 22525) (\UTF16BE.BACKCCODEFN 22527 . 23715)) (23718 28441 (UTF16LE.OUTCHARFN 23728 . 24844) ( -UTF16LE.INCCODEFN 24846 . 25971) (UTF16LE.PEEKCCODEFN 25973 . 27249) (\UTF16LE.BACKCCODEFN 27251 . -28439)) (28442 31489 (READBOM 28452 . 30521) (WRITEBOM 30523 . 31487)) (31519 35084 ( -MAKE-UNICODE-FORMATS 31529 . 35082)) (35181 39675 (UTF8.BINCODE 35191 . 37879) (\UTF8.FETCHCODE 37881 - . 39673)) (39676 45303 (UTF8.VALIDATE 39686 . 42283) (NUTF8-BYTE1-BYTES 42285 . 43022) ( -NUTF8-CODE-BYTES 43024 . 44081) (NUTF8-STRING-BYTES 44083 . 44979) (N-MCHARS 44981 . 45301)) (47785 -57213 (MTOUCODE 47795 . 48182) (UTOMCODE 48184 . 48710) (MTOUCODE? 48712 . 49745) (UTOMCODE? 49747 . -50916) (MTOUSTRING 50918 . 51503) (UTOMSTRING 51505 . 52090) (MTOUTF8STRING 52092 . 56098) ( -UTF8TOMSTRING 56100 . 57211)) (57214 62916 (XTOUCODE 57224 . 57742) (UTOXCODE 57744 . 58252) ( -XTOUCODE? 58254 . 59315) (UTOXCODE? 59317 . 60400) (XTOUSTRING 60402 . 61095) (UTOXSTRING 61097 . -61838) (XTOUTF8STRING 61840 . 62914)) (62979 74247 (WRITE-UNICODE-MAPPING 62989 . 66739) ( -WRITE-UNICODE-INCLUDED 66741 . 71463) (WRITE-UNICODE-MAPPING-HEADER 71465 . 72713) ( -WRITE-UNICODE-MAPPING-FILENAME 72715 . 74245)) (74248 74924 (XCCS-UTF8-AFTER-OPEN 74258 . 74922)) ( -77449 79666 (UTF8HEXSTRING 77459 . 79664)) (79693 81735 (SHOWCHARS 79703 . 81733))))) -STOP diff --git a/library/UNICODE-TABLES b/library/UNICODE-TABLES index 71d05c08..cd429286 100644 --- a/library/UNICODE-TABLES +++ b/library/UNICODE-TABLES @@ -1,19 +1,22 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) -(FILECREATED "22-Oct-2025 23:28:42" {WMEDLEY}UNICODE-TABLES.;4 34028 +(FILECREATED "22-Feb-2026 10:44:33" {WMEDLEY}UNICODE-TABLES.;20 44960 :EDIT-BY rmk - :CHANGES-TO (VARS UNICODE-TABLESCOMS) + :CHANGES-TO (FNS ALL-UNICODE-MAPPINGS GET-MCCS-UNICODE-MAPPING INVERT-UNICODE-MAPPING + MAKE-UNICODE-TRANSLATION-TABLES MERGE-UNICODE-TRANSLATION-TABLES + READ-UNICODE-MAPPING-FILENAMES) + (VARS UNICODE-TABLESCOMS) - :PREVIOUS-DATE "16-Oct-2025 16:47:54" {WMEDLEY}UNICODE-TABLES.;3) + :PREVIOUS-DATE "22-Feb-2026 09:15:20" {WMEDLEY}UNICODE-TABLES.;16) (PRETTYCOMPRINT UNICODE-TABLESCOMS) (RPAQQ UNICODE-TABLESCOMS [ - (* ;; "Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence.") + (* ;; "This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. ") (COMS (* ; "Read Unicode mapping files") (INITVARS (UNICODEDIRECTORIES NIL)) @@ -22,22 +25,32 @@ (FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING)) (COMS (* ;  "Make translation tables for UTF external formats") - (FNS MAKE-UNICODE-TRANSLATION-TABLES XCCSTOMCCS-MAPPING - MERGE-UNICODE-TRANSLATION-TABLES UNICODE.UNMAPPED UNICODE-EXTEND-TRANSLATION?) + (FNS MAKE-UNICODE-TRANSLATION-TABLES GET-MCCS-UNICODE-MAPPING INVERT-UNICODE-MAPPING + XCCSTOMCCS-MAPPING) (FNS ALL-UNICODE-MAPPINGS XCCSJAPANESECHARSETS) - (INITVARS (*MCCSTOUNICODE*) - (*UNICODETOMCCS*) - (*MCCS-LOADED-CHARSETS*) - (*UNICODE-LOADED-CHARSETS*) - (*LARGEUNICODES*)) - [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES 'ALL] + (COMS (* ; "Write Unicode mapping files") + (FNS WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER + WRITE-UNICODE-MAPPING-FILENAME) + (FNS XCCS-UTF8-AFTER-OPEN) + + (* ;; "Automate dumping of a documentation prefix") + + [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" + :RADIX 16)) + (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" + :RADIX 16] + (VARS UNICODE-MAPPING-HEADER)) + (FNS UTF8HEXSTRING) + (COMS (* ; "debugging") + (FNS SHOWCHARS) + (DECLARE%: DOEVAL@LOAD DONTCOPY (MACROS HEXCHAR OCTALCHAR))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) UNICODE-EXPORTS]) (* ;; -"Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence." +"This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. " ) @@ -94,7 +107,8 @@ (DEFINEQ (READ-UNICODE-MAPPING-FILENAMES - [LAMBDA (FILESPEC) (* ; "Edited 16-Oct-2025 16:43 by rmk") + [LAMBDA (FILESPEC) (* ; "Edited 21-Feb-2026 18:14 by rmk") + (* ; "Edited 16-Oct-2025 16:43 by rmk") (* ; "Edited 4-Sep-2025 00:11 by rmk") (* ; "Edited 27-Jan-2025 16:46 by rmk") (* ; "Edited 21-Jan-2025 22:51 by rmk") @@ -107,51 +121,47 @@ (* ;; "FILESPEC can be a file name, character-set name, the name of a collection of character sets, an XCCS character code, or a list of those. Maps those into the names of files that contain the indicated Unicode mappings.") - (CL:REMOVE-DUPLICATES [for F X CSI inside (if (EQ FILESPEC 'ALL) - then - (* ;; + (for F X CSI inside (if (EQ FILESPEC 'ALL) + then + (* ;;  "Perhaps should figure out which files in the directories and subdirectories are relevant?") - (for N in XCCS-CHARSETS - collect (CAR N)) - else FILESPEC) - join - (* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)") + (for N in XCCS-CHARSETS collect (CAR N)) + else FILESPEC) + join + (* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)") - (OR (CL:WHEN (CHARCODEP F) (* ; + [OR (CL:WHEN (CHARCODEP F) (* ;  "An XCCS code can retrieve its character set") - (for D FN (FOCTAL _ (OCTALSTRING (LRSH F 8))) inside - UNICODEDIRECTORIES - when (SETQ FN (FILDIR (PACKFILENAME 'DIRECTORY D - 'BODY - (CONCAT 'XCCS- FOCTAL - '=*) - 'EXTENSION - 'TXT - 'VERSION ""))) - do (RETURN FN))) - (MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT - 'VERSION "") - T UNICODEDIRECTORIES)) - (for D inside UNICODEDIRECTORIES - when [SETQ $$VAL (OR (FILDIR (PACKFILENAME 'NAME - (CONCAT "XCCS-*=" F) - 'EXTENSION - 'TXT - 'VERSION "" 'BODY D)) - (FILDIR (PACKFILENAME 'NAME - (CONCAT "XCCS-" F "=*") - 'EXTENSION - 'TXT - 'VERSION "" 'BODY D] - do (RETURN $$VAL)) - (AND (SETQ CSI (ASSOC F XCCS-CHARSETS)) - (READ-UNICODE-MAPPING-FILENAMES (CDR CSI))) - (for D inside UNICODEDIRECTORIES - when (DIRECTORYNAMEP (SETQ D (CONCAT D ">" F ">"))) - join (FILDIR (CONCAT D ">*.TXT;"] - :TEST - (FUNCTION STRING.EQUAL]) + (for D FN (FOCTAL ↠(OCTALSTRING (LRSH F 8))) inside UNICODEDIRECTORIES + when (SETQ FN (DIRECTORY (PACKFILENAME 'DIRECTORY D 'BODY (CONCAT 'XCCS- + FOCTAL + '=*) + 'EXTENSION + 'TXT + 'VERSION ""))) do (RETURN FN))) + (MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT 'VERSION "") + T UNICODEDIRECTORIES)) + (for D inside UNICODEDIRECTORIES + when [SETQ $$VAL (OR (DIRECTORY (PACKFILENAME 'NAME (CONCAT "XCCS-*=" F) + 'EXTENSION + 'TXT + 'VERSION "" 'BODY D)) + (DIRECTORY (PACKFILENAME 'NAME (CONCAT "XCCS-" F "=*") + 'EXTENSION + 'TXT + 'VERSION "" 'BODY D] + do (RETURN $$VAL)) + (AND (SETQ CSI (ASSOC F XCCS-CHARSETS)) + (READ-UNICODE-MAPPING-FILENAMES (CDR CSI))) + (for D inside UNICODEDIRECTORIES when (DIRECTORYNAMEP (SETQ D + (CONCAT D ">" F ">"))) + join (DIRECTORY (CONCAT D ">*.TXT;"] + finally (* ; + "CL:REMOVE-DUPLICATES doesn't exist in MAKEINIT") + (RETURN (for FTAIL on $$VAL unless (thereis FF in (CDR FTAIL) + suchthat (STRING-EQUAL (CAR FTAIL) + FF)) collect (CAR FTAIL]) (READ-UNICODE-MAPPING [LAMBDA (FILESPEC PRINT NOERROR) (* ; "Edited 16-Oct-2025 11:25 by rmk") @@ -179,7 +189,7 @@ (* ;; "") (RESETLST - (for FILE STREAM [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] in ( + (for FILE STREAM [SEPBITTABLE ↠(MAKEBITTABLE (CHARCODE (TAB SPACE] in (  READ-UNICODE-MAPPING-FILENAMES FILESPEC) join @@ -221,7 +231,8 @@ (DEFINEQ (MAKE-UNICODE-TRANSLATION-TABLES - [LAMBDA (MAPPING REINSTALL) (* ; "Edited 11-Oct-2025 11:54 by rmk") + [LAMBDA (MAPPING REINSTALL) (* ; "Edited 21-Feb-2026 22:42 by rmk") + (* ; "Edited 11-Oct-2025 11:54 by rmk") (* ; "Edited 4-Sep-2025 00:30 by rmk") (* ; "Edited 24-Apr-2025 15:47 by rmk") (* ; "Edited 31-Jan-2025 17:46 by rmk") @@ -232,26 +243,13 @@ (* ; "Edited 3-Feb-2024 00:24 by rmk") (* ; "Edited 30-Jan-2024 09:54 by rmk") (* ; "Edited 21-Aug-2021 13:12 by rmk:") + (SETQ MAPPING (GET-MCCS-UNICODE-MAPPING MAPPING)) - (* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to XCCS-to-Unicode mapping files. This applies the XCCS-to-MCCS translations, and then updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).") - (* ; "Edited 17-Aug-2020 08:46 by rmk:") - (CL:UNLESS [AND (LISTP MAPPING) - (FOR PAIR R IN MAPPING AS I TO 10 - ALWAYS (AND (LISTP PAIR) - (CHARCODEP (CAR PAIR)) - [FIXP (SETQ R (CAR (MKLIST (CADR PAIR] - (CHARCODEP (IABS R] - - (* ;; "Seems like the argument is not already a list of mapping pairs (perhaps with a combiner), presumably a list of charsets to be read.") - - (SETQ MAPPING (READ-UNICODE-MAPPING MAPPING))) - (SETQ MAPPING (XCCSTOMCCS-MAPPING MAPPING)) - - (* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).") + (* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).") (* ;; "") - (* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *XCCSTOUNICODE* and *UNICODETOXCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).") + (* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *MCCSTOUNICODE* and *UNICODETOMCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).") (* ;; "") @@ -270,6 +268,55 @@ (SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE)) (MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING]) +(GET-MCCS-UNICODE-MAPPING + [LAMBDA (MAPPING) (* ; "Edited 22-Feb-2026 00:29 by rmk") + + (* ;; "MAPPING is the list of numeric code correspondence pairs mapping MCCS-to-Unicode, or a specification of XCCS-to-Unicode files to be read and converted to MCCS-to-UNICODE.") + + (SORT (if [AND (LISTP MAPPING) + (for PAIR R in MAPPING as I to 10 + always (AND (LISTP PAIR) + (CHARCODEP (CAR PAIR)) + [FIXP (SETQ R (CAR (MKLIST (CADR PAIR] + (CHARCODEP (IABS R] + then + (* ;; "The argument is already a list of MCCS-to-UNICODE mapping pairs") + + MAPPING + else + (* ;; "Mapping files are is read as XCCS-UNICODE, make it MCCS") + + (XCCSTOMCCS-MAPPING (READ-UNICODE-MAPPING MAPPING))) + T]) + +(INVERT-UNICODE-MAPPING + [LAMBDA (MAPPING) (* ; "Edited 22-Feb-2026 00:39 by rmk") + + (* ;; "MAPPING is a list of pairs that map domain codes to range codes (presumably MCCS to UNICODE). This produces an inverted list of pairs that map the range into the domain (Unicode to MCCS) ") + + (LET (INVERTED) + (SETQ INVERTED (SORT (for P D R OLDR in MAPPING eachtime (SETQ D (CAR P)) + (SETQ R (CADR P)) + + (* ;; + "We don't do combiners, but we are allowing non-SMALLP's") + unless (OR (LISTP D) + (LISTP R)) collect (LIST R D)) + T)) + + (* ;; "If MAPPING contains two pairs that map to the same U (e.g. (M1 U) and (M2 U)), we want the inverse table to collect them into a single pair (U M1 M2) instead of two pairs (U M1) (U M2), with the lowest M code first. Those pairs represent alternative inverse mappings. There are no duplicates/alternative table entries in the M-to-U direction.") + + (* ;; "The SORT above means that multiple inverted pairs for the same U will be next to each other in the list.") + + [for PTAIL PTAIL2 U MS on INVERTED eachtime (SETQ U (CAAR PTAIL)) + when (SETQ MS (for old PTAIL2 P2 on PTAIL eachtime (SETQ P2 (CADR PTAIL2)) + while (EQ U (CAR P2)) collect (CADR P2))) + do (RPLACD PTAIL (CDR PTAIL2)) + (RPLACD (CAR PTAIL) + (SORT (CONS (CADR (CAR PTAIL)) + MS] + INVERTED]) + (XCCSTOMCCS-MAPPING [LAMBDA (XTOUMAPPING) (* ; "Edited 11-Oct-2025 12:57 by rmk") @@ -292,152 +339,12 @@ XTOMCODES))) finally (push XTOUMAPPING (CHARCODE (DEL DEL))) (RETURN XTOUMAPPING]) - -(MERGE-UNICODE-TRANSLATION-TABLES - [LAMBDA (INVERSE MAPPING TABLE INVERSETABLE) (* ; "Edited 11-Oct-2025 10:24 by rmk") - (* ; "Edited 24-Apr-2025 15:28 by rmk") - (* ; "Edited 1-Feb-2025 21:42 by rmk") - (* ; "Edited 26-Jan-2025 12:58 by rmk") - (* ; "Edited 22-Jan-2025 08:20 by rmk") - (* ; "Edited 19-Jan-2025 15:58 by rmk") - (* ; "Edited 18-Jan-2025 11:49 by rmk") - (* ; "Edited 27-Mar-2024 12:10 by rmk") - (* ; "Edited 3-Feb-2024 12:46 by rmk") - (* ; "Edited 31-Jan-2024 10:06 by rmk") - - (* ;; "MAPPINGS is a list of pairs that map domain codes to range codes. TABLE and INVERSETABLE default to *MCCSTOUNICODE* *UNICODETOMCCS* respectively. ") - - (CL:UNLESS TABLE - [SETQ TABLE (OR *MCCSTOUNICODE* (SETQ *MCCSTOUNICODE* (HASHARRAY (LENGTH MAPPING]) - (CL:UNLESS INVERSETABLE - [SETQ INVERSETABLE (OR *UNICODETOMCCS* (SETQ *UNICODETOMCCS* (HASHARRAY (LENGTH MAPPING]) - (for M D R OLDR in MAPPING first (CL:IF INVERSE (swap TABLE INVERSETABLE)) - eachtime (SETQ D (CAR M)) - (SETQ R (CADR M)) - - (* ;; "We don't do combiners, but we are allowing non-SMALLP's") - unless (OR (LISTP D) - (LISTP R)) do - (* ;; "The (CONS R OLDR) deals with alternatives: (U X1) (U X2) => (U (X1 X2)), lowest code first. Those are only possible in the U-to-X direction when the tables contain (X1 U) and (X2 U). There are no duplicates/alternative table entries in the X-to-U direction.") - - (SETQ OLDR (GETHASH D TABLE)) - (CL:UNLESS (MEMB R OLDR) - (PUTHASH D (SORT (CONS R OLDR)) - TABLE)) - (swap D R) - (SETQ OLDR (GETHASH D INVERSETABLE)) - (CL:UNLESS (MEMB R OLDR) - (PUTHASH D (SORT (CONS R OLDR)) - INVERSETABLE))) - (LIST TABLE INVERSETABLE]) - -(UNICODE.UNMAPPED - [LAMBDA (CODE TABLE DONTFAKE) (* ; "Edited 24-Apr-2025 15:48 by rmk") - (* ; "Edited 22-Jan-2025 08:19 by rmk") - (* ; "Edited 19-Jan-2025 22:02 by rmk") - (* ; "Edited 18-Jan-2025 12:02 by rmk") - (* ; "Edited 2-Feb-2024 23:52 by rmk") - (* ; "Edited 31-Jan-2024 10:07 by rmk") - (* ; "Edited 11-Aug-2020 20:23 by rmk:") - - (* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODE has no fast mapping in TRANSLATION-TABLE.") - - (* ;; "") - - (* ;; "If we have not already installed the mapping segment for that code, we try to retrieve it from the numberic file. If that segment mapping doesn't exist or doesn't have an entry for CODE, we fake up a mapping with a negative range in both directions. One way or the other, there will be an entry for that segment in both mapping vectors.") - - (* ;; "") - - (PROG ((INVERSE (EQ TABLE *UNICODETOMCCS*)) - RANGE HASH) - - (* ;; "If we already looked up CODE's character set in a file, then we have already filled in its information in the translation table. If it didn't have a code for a particular character, then we fake it here. Faked codes are negative, so we can detect them easily, and interpret them with IABS.") - - (CL:WHEN (AND (UNICODE-EXTEND-TRANSLATION? CODE TABLE) - (SETQ RANGE (GETHASH CODE TABLE))) - - (* ;; "We might have gotten the segment that didn't have an entry for CODE.") - - (RETURN RANGE)) - - (* ;; "") - - (CL:UNLESS DONTFAKE - - (* ;; "Our attempt at extending the known tables did not provide a mapping for CODE. So we fake it up with the next unused private code in the code space. ") - - (* ;; "The number of possible faked mappings is determined by the number of private-use Unicodes, since the MCCS character space is pretty sparse. The codes don't have to come from the same part of the code space, and the NEXTCODEs are saved in global variables. The last available codes are constants.") - - (CL:WHEN (IEQP *NEXT-PRIVATE-MCCSCODE* LAST-PRIVATE-MCCSCODE) - (* ; - "Same number of available codes both ways") - (ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES")) - (if INVERSE - then (SETQ RANGE *NEXT-PRIVATE-MCCSCODE*) - (add *NEXT-PRIVATE-MCCSCODE* 1) - else (SETQ RANGE *NEXT-PRIVATE-UNICODE*) - (add *NEXT-PRIVATE-UNICODE* 1)) - (MERGE-UNICODE-TRANSLATION-TABLES INVERSE (CONS (LIST CODE RANGE))) - - (* ;; "CONS because of LIST convention so we can eventually distinguish combiners.") - - (RETURN (CONS RANGE)))]) - -(UNICODE-EXTEND-TRANSLATION? - [LAMBDA (CODE TABLE) (* ; "Edited 11-Oct-2025 09:49 by rmk") - (* ; "Edited 4-Sep-2025 00:34 by rmk") - (* ; "Edited 29-Jun-2025 16:44 by rmk") - (* ; "Edited 24-Apr-2025 15:49 by rmk") - (* ; "Edited 26-Jan-2025 11:26 by rmk") - (* ; "Edited 21-Jan-2025 22:31 by rmk") - (* ; "Edited 18-Jan-2025 12:40 by rmk") - (* ; "Edited 13-Jan-2025 23:50 by rmk") - (* ; "Edited 26-Aug-2024 16:49 by rmk") - (* ; "Edited 27-Mar-2024 23:02 by rmk") - (* ; "Edited 5-Feb-2024 13:48 by rmk") - (* ; "Edited 3-Feb-2024 12:40 by rmk") - - (* ;; "There is currently no mapping for CODE in TABLE, hopefully just because the relevant character-set mapping has not been installed. We infer from TABLE whether CODE is an MCCS or UNICODE code and look for the proper mapping table (forward or inverted) for its character set. ") - - (* ;; "We record which character sets we have already expanded so we don't do them again.") - - (LET ((CHARSET (\CHARSET CODE)) - (INVERSE (EQ TABLE *UNICODETOMCCS*)) - MAPPING FILE) - - (* ;; "If we already looked for CHARSET in the file and found anything, it has already been merged. Otherwise, it would just fail again") - - (CL:UNLESS (MEMB CHARSET (CL:IF INVERSE - *UNICODE-LOADED-CHARSETS* - *MCCS-LOADED-CHARSETS*)) - - (* ;; "Don't try this charset again.") - - (CL:IF INVERSE - (push *UNICODE-LOADED-CHARSETS* CHARSET) - (push *MCCS-LOADED-CHARSETS* CHARSET)) - (SETQ FILE (FINDFILE (CL:IF INVERSE - 'UNICODE-TO-MCCS-MAPPINGS - 'MCCS-TO-UNICODE-MAPPINGS) - T UNICODEDIRECTORIES)) - - (* ;; "The mappings files are indexed by CHARSET.") - - (CL:WHEN [AND FILE (SETQ MAPPING (CL:WITH-OPEN-FILE (STREAM FILE :INPUT) - (CL:WHEN (FILEPOS (CONCAT "[" CHARSET " ") - STREAM NIL NIL NIL T) - (READ STREAM] - - (* ;; - "Merge MAPPING into both tables, respecting the direction indicated by TABLE. ") - - (MERGE-UNICODE-TRANSLATION-TABLES INVERSE MAPPING) - T))]) ) (DEFINEQ (ALL-UNICODE-MAPPINGS - [LAMBDA (INVERTED FILE) (* ; "Edited 24-Apr-2025 15:51 by rmk") + [LAMBDA (INVERTED FILE) (* ; "Edited 22-Feb-2026 10:42 by rmk") + (* ; "Edited 24-Apr-2025 15:51 by rmk") (* ; "Edited 31-Jan-2025 17:46 by rmk") (* ; "Edited 26-Jan-2025 13:40 by rmk") (* ; "Edited 22-Jan-2025 14:07 by rmk") @@ -453,38 +360,32 @@ (* ;; "The first index level segments all the domain codes according to their character sets. The segments are sorted by character set, the pairs within each segment are sorted by their domain codes. ") (* ;; - "E.g. if INVERTED=NIL and given a XCCS code, the lookup for the corresponding Unicode(s) is") + "E.g. if INVERTED=NIL and given a MCCS code, the lookup for the corresponding Unicode(s) is") - (* ;; " (CADR (ASSOC MCCSCODE (\CHARSET MCCSCODE) INDEX)))).") + (* ;; " (CAR (GETMULTI INDEX (\CHARSET MCCSCODE) MCCSCODE).") (* ;; "If FILE is not NIL, the result is written to a file. If FILE is T, the file is either MCCS-TO-UNICODE-MAPPINGS.TXT or UNICODE-TO-MCCS-MAPPINGS.TXT, depending on INVERTED.") - (LET (INDEX) - (for PAIR DOMAIN RANGE CHARSET in (READ-UNICODE-MAPPING 'ALL) eachtime (SETQ DOMAIN - (CAR PAIR)) - (SETQ RANGE (CADR PAIR)) - - (* ;; - "(LISTP RANGE) is a combiner, ignored for now.") - unless (LISTP RANGE) do (CL:WHEN INVERTED (SWAP DOMAIN RANGE)) + (LET [INDEX (MAPPING (GET-MCCS-UNICODE-MAPPING 'ALL] + (for PAIR in (CL:IF INVERTED + (INVERT-UNICODE-MAPPING MAPPING) + MAPPING) unless (LISTP (CADR PAIR)) do + (* ;; + "(LISTP (CADR PAIR) is a combiner, ignored for now.") - (* ;; + (* ;;  "One segment for each high-byte character set. This aligns with UNICODE-EXTEND.TRANSLATION?") - [SETQ CHARSET (OR (ASSOC (\CHARSET DOMAIN) - INDEX) - (CAR (push INDEX (CONS (\CHARSET DOMAIN] + (* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CAR (GETMULTI)) is the first (and almost always) the only one.") - (* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CADR is the first (and almost always) the only one.") - - (pushnew [CDR (OR (ASSOC DOMAIN (CDR CHARSET)) - (CAR (push (CDR CHARSET) - (CONS DOMAIN] - RANGE)) + (PUSHMULTI-NEW INDEX + (\CHARSET (CAR PAIR)) + (CAR PAIR) + (CADR PAIR))) (* ;; "Push the charset mappings down an extra CONS, so that a subsequent READ will get them all after a FILEPOS search for super-paren [") - [for CS in INDEX do (for M in (CDR CS) when (CDDR M) do + (for CS in INDEX do (for M in (CDR CS) when (CDDR M) do (* ;;  "Sort the range alternatives, if any") @@ -494,7 +395,7 @@ (* ;; "Sort by domain codes and push down a level") (change (CDR CS) - (CONS (SORT DATUM T] + (SORT DATUM T))) (SETQ INDEX (SORT INDEX T)) (* ; "Sort character sets") (if FILE then (SETQ FILE (PACKFILENAME 'BODY (if (NEQ FILE T) @@ -544,18 +445,347 @@ (FULLNAME STREAM))))]) ) -(RPAQ? *MCCSTOUNICODE* ) -(RPAQ? *UNICODETOMCCS* ) -(RPAQ? *MCCS-LOADED-CHARSETS* ) +(* ; "Write Unicode mapping files") -(RPAQ? *UNICODE-LOADED-CHARSETS* ) +(DEFINEQ -(RPAQ? *LARGEUNICODES* ) -(DECLARE%: DONTEVAL@LOAD DOCOPY +(WRITE-UNICODE-MAPPING + [LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 4-Jan-2024 22:44 by rmk") + (* ; "Edited 16-Aug-2020 16:56 by rmk:") -(MAKE-UNICODE-TRANSLATION-TABLES 'ALL) + (* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.") + + (* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.") + + (* ;; "The output lines are of the form 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 :UTF-8-RAW) + (WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES) + (SORT IMAPPING T) + (FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING + DO (SETQ LEFTC (CAR M)) + (SETQ FIRSTRIGHTC (CADR M)) + (CL:UNLESS (EQ CSET (LRSH LEFTC 8)) + (SETQ CSET (LRSH LEFTC 8)) + (SETQ CSI (ASSOC CSET CSETINFO)) + (PRINTOUT STREAM T "# " .P2 (CADR CSI) + " " + (CADDR CSI) + T)) + (PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4) + %# + (FOR RIGHTC IN (CDR M) DO (PRINTOUT NIL " " "0x" (HEXSTRING RIGHTC 4))) + " # " + (SELECTC FIRSTRIGHTC + (UNDEFINEDCODE + (* ;; "FFFF") + + "UNDEFINED") + (MISSINGCODE + (* ;; "FFFE") + + "MISSING") + (IF (ILESSP FIRSTRIGHTC 32) + THEN (* ; "Control chars") + [CONCAT "↑" (CHARACTER (IPLUS FIRSTRIGHTC (CHARCODE @] + ELSE (CHARACTER FIRSTRIGHTC))) + T)) + (FULLNAME STREAM)) + ELSEIF (NOT EMPTYOK) + THEN (PRINTOUT T "THERE ARE NO MAPPINGS") + (CL:WHEN INCLUDECHARSETS + (PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS) + T)) + NIL]) + +(WRITE-UNICODE-INCLUDED + [LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:") + + (* ;; "CSETINFO is a list of (num string name) for each included character set.") + + (LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING) + + (* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings") + + [SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN XCCS-SET-NAMES + COLLECT (CAR CSI))) + JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES) + (FIND N IN XCCS-SET-NAMES + SUCHTHAT (EQ C (CADR N))) + (HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C] + (IF (SETQ POS (STRPOS "-" (CAR KNOWN))) + THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) + 1 + (SUB1 POS)) + :RADIX 8) + TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN) + (ADD1 POS)) + :RADIX 8) COLLECT (LIST I (OCTALSTRING I) + (CADR KNOWN))) + ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN) + :RADIX 8) + KNOWN] + (SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M) + 8) + ICSETS)) + COLLECT + + (* ;; "The attested subset of INCLUDED") + + (CL:UNLESS (MEMB CSI CSETINFO) + (PUSH CSETINFO CSI)) + M)) + + (* ;; "Sort as numbers, not octal strings, then group into consecutive ranges") + + (SETQ CSETINFO (SORT CSETINFO T)) + [SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO COLLECT (CAR CSI)) WHILE CTAIL + COLLECT (SETQ START (CAR CTAIL)) + (SETQ END START) + (CONS START (WHILE [AND (CDR CTAIL) + (EQ END (SUB1 (CADR CTAIL] + COLLECT (SETQ CTAIL (CDR CTAIL)) + (SETQ END (CAR CTAIL] + + (* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name") + + [SETQ RANGES (FOR R STR KNOWN LAST IN RANGES + JOIN (SETQ LAST (CAR (LAST R))) + (IF (EQ (CAR R) + LAST) + THEN (CONS (OCTALSTRING (CAR R))) + ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING + (CAR R)) + "-" + (OCTALSTRING LAST))) + XCCS-SET-NAMES)) + THEN (CONS (CADR KNOWN)) + ELSEIF (CDDR R) + THEN (CONS STR) + ELSE (LIST (OCTALSTRING (CAR R)) + (OCTALSTRING LAST] + (CL:VALUES IMAPPING CSETINFO RANGES]) + +(WRITE-UNICODE-MAPPING-HEADER + [LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 5-Jan-2024 13:24 by rmk") + (* ; "Edited 4-Aug-2020 17:38 by rmk:") + + (* ;; "Writes the standard per-file header information") + + (FOR LINE IN UNICODE-MAPPING-HEADER + DO (PRINTOUT STREAM "#" 2) + (SELECTQ LINE + (XCCSCHARACTERSETS + (PRINTOUT STREAM " XCCS charset") + (IF (CDR CSETINFO) + THEN (PRINTOUT STREAM "s:" -4) + (FOR R IN RANGES DO (PRINTOUT STREAM R " ")) + ELSE (* ; "Singleton") + (PRINTOUT STREAM ": " -4 (CADAR CSETINFO) + " " + (CADDAR CSETINFO))) + (TERPRI STREAM)) + (DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME NO.LEADING.SPACES) + ) + T)) + (PRINTOUT STREAM LINE T))) + (TERPRI STREAM]) + +(WRITE-UNICODE-MAPPING-FILENAME + [LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:") + (PACKFILENAME 'BODY [OR FILE (CONCATLIST + (CONS 'XCCS- (IF (CDR CSETINFO) + THEN (FOR RTAIL R ON RANGES + JOIN (SETQ R (CAR RTAIL)) + (SETQ R (CL:IF (LISTP R) + (LIST (CAR R) + "-" + (CDR R)) + (CONS R))) + (CL:IF (CDR RTAIL) + (NCONC1 R ",")) + R) + ELSE (LIST (CADAR CSETINFO) + "=" + (CADDAR CSETINFO] + 'DIRECTORY + (CAR UNICODEDIRECTORIES) + 'EXTENSION + 'TXT]) +) +(DEFINEQ + +(XCCS-UTF8-AFTER-OPEN + [LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 3-Jan-2024 10:27 by rmk") + (* ; "Edited 13-Aug-2020 11:54 by rmk:") + + (* ;; + "If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF-8. For development") + + (CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM))) + [EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM) + 'EXTENSION] + (NOT (ASSOC 'EXTERNALFORMAT PARAMETERS))) + (STREAMPROP STREAM 'EXTERNALFORMAT :UTF-8))]) +) + + + +(* ;; "Automate dumping of a documentation prefix") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) + +(RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)) + + +(CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16)) + (UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))) +) +) + +(RPAQQ UNICODE-MAPPING-HEADER + ("" " Name: XCCS (Version 2.0) to Unicode" " Unicode version: 3.0" + XCCSCHARACTERSETS " Table version: 0.1" " Table format: Format A" + DATE " Author: Ron Kaplan " "" + "This file contains mappings from the Xerox Character Code Standard (version" + "2.0, 1990) into Unicode 3.0. standard codes. That is an extension of the" + "version of XCCS corresponding to the fonts in the Medley system." "" + "The format of this file conforms to the format of the other Unicode-supplied" + "mapping files:" " Three white-space (tab or spaces) separated columns:" + " Column 1 is the XCCS code (as hex 0xXXXX)" + " Column 2 is the corresponding Unicode (as hex 0xXXXX)" + " Column 3 (after #) is a comment column. For convenience, it contains the" + " Unicode character itself and the Unicode character names when available." + "Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED" + "Unicode FFFE is used for XCCS codes that have not yet been filled in." + "(Column 3 = MISSING)" "" "This file is encoded in UTF-8, so that the Unicode characters" + "are properly displayed in Column 3 and can be edited by standard" + "Unicode-enabled editors (e.g. Mac Textedit)." "" + "This file can also be read by the function" + "READ-UNICODE-MAPPING in the UNICODE Medley library package." "" + "The entries are in XCCS order and grouped by character sets. In front of" + "the mappings, for convenience, there is a line with the octal XCCS" + "character set, after #." "" + "Note that a given XCCS code might map to codes in several different Unicode" + "positions, since there are repetitions in the Unicode standard." "" + "For more details, see the associated README.TXT file." "" + "Any comments or problems, contact ")) +(DEFINEQ + +(UTF8HEXSTRING + [LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:") + + (* ;; "Utility to produces the UTF8 hexstring representing CODE") + + (HEXSTRING (IF (ILESSP CHARCODE 128) + THEN CHARCODE + ELSEIF (ILESSP CHARCODE 2048) + THEN (* ; "x800") + (LOGOR (LLSH (LOGOR (LLSH 3 6) + (LRSH CHARCODE 6)) + 8) + (LOGOR (LLSH 2 6) + (LOADBYTE CHARCODE 0 6))) + ELSEIF (ILESSP CHARCODE 65536) + THEN (* ; "x10000") + (LOGOR (LLSH (LOGOR (LLSH 7 5) + (LRSH CHARCODE 12)) + 16) + (LLSH (LOGOR (LLSH 2 6) + (LOADBYTE CHARCODE 6 6)) + 8) + (LOGOR (LLSH 2 6) + (LOADBYTE CHARCODE 0 6))) + ELSEIF (ILESSP CHARCODE 2097152) + THEN (* ; "x200000") + (LOGOR (LLSH (LOGOR (LLSH 15 4) + (LRSH CHARCODE 18)) + 24) + (LLSH (LOGOR (LLSH 2 6) + (LOADBYTE CHARCODE 12 6)) + 16) + (LLSH (LOGOR (LLSH 2 6) + (LOADBYTE CHARCODE 6 6)) + 8) + (LOGOR (LLSH 2 6) + (LOADBYTE CHARCODE 0 6))) + ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE]) +) + + + +(* ; "debugging") + +(DEFINEQ + +(SHOWCHARS + [LAMBDA (FONT FROMCHAR TOCHAR ONELINE) (* ; "Edited 5-Oct-2025 17:41 by rmk") + (* ; "Edited 7-Sep-2025 20:29 by rmk") + (* ; "Edited 2-Sep-2025 10:26 by rmk") + (* ; "Edited 24-Jul-2025 11:30 by rmk") + (* ; "Edited 8-Jun-2025 20:05 by rmk") + (* ; "Edited 26-Jan-2024 14:18 by mth") + (* ; "Edited 1-Aug-2020 09:27 by rmk:") + [SETQ FONT (FONTCREATE (OR FONT '(CLASSIC 12] + (RESETLST + [LET ((OLDFONT (DSPFONT NIL T)) + CHARS) + (CL:UNLESS (CHARCODEP FROMCHAR) + (SETQ FROMCHAR (OR (CHARCODE.DECODE FROMCHAR T) + FROMCHAR))) + (SETQ CHARS (if (LISTP FROMCHAR) + elseif (CHARCODEP FROMCHAR) + then (CL:UNLESS (CHARCODEP TOCHAR) + (SETQ TOCHAR (OR (CHARCODE.DECODE TOCHAR) + FROMCHAR))) + (for C from FROMCHAR to TOCHAR collect C) + else (CHCON FROMCHAR))) + [RESETSAVE OLDFONT '(PROGN (DSPFONT OLDVALUE] + (TERPRI) + (for C in CHARS do (PRINTOUT T .FONT OLDFONT (CONCAT (OCTALSTRING (\CHARSET C)) + "," + (OCTALSTRING (\CHAR8CODE C))) + 10 .FONT FONT (CHARACTER C)) + (CL:UNLESS ONELINE (PRINTOUT T T]) + (TERPRI]) +) +(DECLARE%: DOEVAL@LOAD DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS HEXCHAR MACRO ((CODE) + (HEXSTRING CODE))) + +(PUTPROPS OCTALCHAR MACRO [(CODE) + (CONCAT (OCTALSTRING (\CHARSET CODE)) + "," + (OCTALSTRING (LOGAND CODE 255]) +) ) (DECLARE%: EVAL@COMPILE DONTCOPY @@ -563,9 +793,12 @@ UNICODE-EXPORTS) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3341 12542 (READ-UNICODE-MAPPING-FILENAMES 3351 . 8301) (READ-UNICODE-MAPPING 8303 . -12540)) (12609 26839 (MAKE-UNICODE-TRANSLATION-TABLES 12619 . 16379) (XCCSTOMCCS-MAPPING 16381 . 17598 -) (MERGE-UNICODE-TRANSLATION-TABLES 17600 . 20253) (UNICODE.UNMAPPED 20255 . 23579) ( -UNICODE-EXTEND-TRANSLATION? 23581 . 26837)) (26840 33676 (ALL-UNICODE-MAPPINGS 26850 . 32339) ( -XCCSJAPANESECHARSETS 32341 . 33674))))) + (FILEMAP (NIL (4107 12829 (READ-UNICODE-MAPPING-FILENAMES 4117 . 8586) (READ-UNICODE-MAPPING 8588 . +12827)) (12896 19704 (MAKE-UNICODE-TRANSLATION-TABLES 12906 . 15666) (GET-MCCS-UNICODE-MAPPING 15668 + . 16688) (INVERT-UNICODE-MAPPING 16690 . 18483) (XCCSTOMCCS-MAPPING 18485 . 19702)) (19705 26328 ( +ALL-UNICODE-MAPPINGS 19715 . 24991) (XCCSJAPANESECHARSETS 24993 . 26326)) (26373 37135 ( +WRITE-UNICODE-MAPPING 26383 . 30127) (WRITE-UNICODE-INCLUDED 30129 . 34441) ( +WRITE-UNICODE-MAPPING-HEADER 34443 . 35691) (WRITE-UNICODE-MAPPING-FILENAME 35693 . 37133)) (37136 +37812 (XCCS-UTF8-AFTER-OPEN 37146 . 37810)) (40337 42426 (UTF8HEXSTRING 40347 . 42424)) (42453 44495 ( +SHOWCHARS 42463 . 44493))))) STOP diff --git a/library/UNICODE-TABLES.LCOM b/library/UNICODE-TABLES.LCOM index d339e038..88ca0dcb 100644 Binary files a/library/UNICODE-TABLES.LCOM and b/library/UNICODE-TABLES.LCOM differ diff --git a/library/UNICODE.LCOM b/library/UNICODE.LCOM deleted file mode 100644 index b14e049a..00000000 Binary files a/library/UNICODE.LCOM and /dev/null differ diff --git a/library/UNIXCOMM b/library/UNIXCOMM index 02c27436..978d96cf 100644 --- a/library/UNIXCOMM +++ b/library/UNIXCOMM @@ -1,14 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 2-Sep-2025 12:06:52"  -{DSK}kaplan>Local>medley3.5>working-medley>library>UNIXCOMM.;14 14825 +(FILECREATED " 5-Feb-2026 18:38:23" {WMEDLEY}UNIXCOMM.;15 14717 :EDIT-BY rmk :CHANGES-TO (FNS FORK-UNIX) - :PREVIOUS-DATE "29-Apr-2025 22:45:47" -{DSK}kaplan>Local>medley3.5>working-medley>library>UNIXCOMM.;13) + :PREVIOUS-DATE " 2-Sep-2025 12:06:52" {WMEDLEY}UNIXCOMM.;14) (PRETTYCOMPRINT UNIXCOMMCOMS) @@ -74,13 +72,11 @@ else (SUBRCALL UNIX-HANDLECOMM 4]) (FORK-UNIX - [LAMBDA (STR) (* ; "Edited 2-Sep-2025 12:03 by rmk") + [LAMBDA (STR) (* ; "Edited 5-Feb-2026 18:38 by rmk") + (* ; "Edited 2-Sep-2025 12:03 by rmk") (* ; "Edited 29-Apr-2025 22:45 by rmk") (* ; "Edited 25-May-88 15:47 by drc:") - - (* ;; "MTOUBYTES converts MCCS codes to Unicodes, and then lays out the bytes of the UTF-8 encoding of those characters. ") - - (SUBRCALL UNIX-HANDLECOMM 0 (MTOUTF8STRING (\DTEST STR 'ONED-ARRAY]) + (SUBRCALL UNIX-HANDLECOMM 0 (MTOSYSSTRING (\DTEST STR 'ONED-ARRAY]) (UNIX-KILL [LAMBDA (CONN) (* ; "Edited 25-May-88 16:04 by drc:") @@ -321,10 +317,10 @@ (PUTPROPS UNIXCOMM FILETYPE COMPILE-FILE) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1903 7339 (FORK-SHELL 1913 . 3110) (FORK-UNIX 3112 . 3659) (UNIX-KILL 3661 . 3850) ( -UNIX-WRITE 3852 . 4563) (CREATE-SHELL-STREAM 4565 . 5449) (CREATE-PROCESS-STREAM 5451 . 6290) ( -UNIXCOMM-AROUNDEXITFN 6292 . 7337)) (7387 12578 (INITIALIZE-SHELL-DEVICE 7397 . 8825) ( -UNIX-GET-NEXT-BUFFER 8827 . 11027) (UNIX-BACKFILEPTR 11029 . 11441) (UNIX-STREAM-EOFP 11443 . 11924) ( -UNIX-STREAM-OUT 11926 . 12182) (UNIX-STREAM-CLOSE 12184 . 12576)) (12826 14532 ( -CREATE-UNIX-SOCKET-STREAM 12836 . 13642) (ACCEPT-UNIX-SOCKET-STREAM 13644 . 14530))))) + (FILEMAP (NIL (1821 7231 (FORK-SHELL 1831 . 3028) (FORK-UNIX 3030 . 3551) (UNIX-KILL 3553 . 3742) ( +UNIX-WRITE 3744 . 4455) (CREATE-SHELL-STREAM 4457 . 5341) (CREATE-PROCESS-STREAM 5343 . 6182) ( +UNIXCOMM-AROUNDEXITFN 6184 . 7229)) (7279 12470 (INITIALIZE-SHELL-DEVICE 7289 . 8717) ( +UNIX-GET-NEXT-BUFFER 8719 . 10919) (UNIX-BACKFILEPTR 10921 . 11333) (UNIX-STREAM-EOFP 11335 . 11816) ( +UNIX-STREAM-OUT 11818 . 12074) (UNIX-STREAM-CLOSE 12076 . 12468)) (12718 14424 ( +CREATE-UNIX-SOCKET-STREAM 12728 . 13534) (ACCEPT-UNIX-SOCKET-STREAM 13536 . 14422))))) STOP diff --git a/library/UNIXCOMM.DFASL b/library/UNIXCOMM.DFASL new file mode 100644 index 00000000..119a6d03 Binary files /dev/null and b/library/UNIXCOMM.DFASL differ diff --git a/library/UNIXPRINT b/library/UNIXPRINT index c637e5cb..9be14555 100644 --- a/library/UNIXPRINT +++ b/library/UNIXPRINT @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "25-Jan-2026 11:09:09" {WMEDLEY}UNIXPRINT.;15 11553 +(FILECREATED " 5-Feb-2026 18:37:09" {WMEDLEY}UNIXPRINT.;17 11663 :EDIT-BY rmk - :CHANGES-TO (FNS UnixPrint) + :CHANGES-TO (FNS UnixShellQuote) - :PREVIOUS-DATE "18-Jan-2026 08:44:40" {WMEDLEY}UNIXPRINT.;14) + :PREVIOUS-DATE "25-Jan-2026 11:09:09" {WMEDLEY}UNIXPRINT.;15) (PRETTYCOMPRINT UNIXPRINTCOMS) @@ -130,7 +130,8 @@ (UnixShellQuote [LAMBDA (STRING) - (DECLARE (LOCALVARS . T)) (* ; "Edited 18-Jan-2026 08:34 by rmk") + (DECLARE (LOCALVARS . T)) (* ; "Edited 5-Feb-2026 18:37 by rmk") + (* ; "Edited 18-Jan-2026 08:34 by rmk") (* ; "Edited 19-Apr-89 21:14 by TAL") (LET* ((X (CHCON STRING)) (CT X) @@ -155,9 +156,9 @@ (CHARCODE SPACE)) (T C)) (SETQ CT (CDR CT] - (MTOUTF8STRING (COND - (FLG (CONCATCODES X)) - (T STRING]) + (MTOSYSSTRING (CL:IF FLG + (CONCATCODES X) + STRING)]) (UnixTempFile [LAMBDA (Prefix DontOpen) (* ; "Edited 28-Apr-93 13:49 by rmk:") @@ -251,6 +252,6 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1046 10887 (UnixPrint 1056 . 6392) (UnixShellQuote 6394 . 7977) (UnixTempFile 7979 . -9202) (UnixPrintCommand 9204 . 10885))))) + (FILEMAP (NIL (1051 10997 (UnixPrint 1061 . 6397) (UnixShellQuote 6399 . 8087) (UnixTempFile 8089 . +9312) (UnixPrintCommand 9314 . 10995))))) STOP diff --git a/library/UNIXPRINT.DFASL b/library/UNIXPRINT.DFASL index 6b582ab0..8338e31b 100644 Binary files a/library/UNIXPRINT.DFASL and b/library/UNIXPRINT.DFASL differ diff --git a/library/lafite/LAFITE-INDENT b/library/lafite/LAFITE-INDENT index c6f15824..70948f71 100644 --- a/library/lafite/LAFITE-INDENT +++ b/library/lafite/LAFITE-INDENT @@ -1,13 +1,10 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "15-Feb-2025 14:11:54" {WMEDLEY}lafite>LAFITE-INDENT.;4 26926 +(FILECREATED "18-Feb-2026 15:47:08" {WMEDLEY}LAFITE>LAFITE-INDENT.;2 26210 :EDIT-BY rmk - :CHANGES-TO (FNS TEDIT-INDENT-BREAK-LONG-LINES TEDIT-INDENT-SELECTION TEDIT-OPEN-LINE - TEDIT-MAKE-LINES-EXPLICIT TEDIT-INDENT-SET-INDENT) - - :PREVIOUS-DATE "15-Feb-2025 09:21:58" {WMEDLEY}lafite>LAFITE-INDENT.;3) + :PREVIOUS-DATE "22-Jan-87 01:34:36" {WMEDLEY}LAFITE>LAFITE-INDENT.;1) (PRETTYCOMPRINT LAFITE-INDENTCOMS) @@ -133,10 +130,14 @@ max-length max-length]) (TEDIT-INDENT-BREAK-LONG-LINES - [LAMBDA (text-stream explicit-paragraph-breaks?) (* ; "Edited 15-Feb-2025 14:07 by rmk") - (* smL "21-Jan-87 16:03") - -(* ;;; "Break the current selection into explicit lines, each having no more than *TEDIT-INDENT-LINE-LENGTH* characters. --- If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in the current selection are removed. --- This is intended to be used in Lafite, where one wants to indent a piece of a forwarded document, but can be used in any TEdit document") + [LAMBDA (text-stream explicit-paragraph-breaks?) (* smL "21-Jan-87 16:03") + + (* * Break the current selection into explicit lines, each having no more than + *TEDIT-INDENT-LINE-LENGTH* characters. - + If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in + the current selection are removed. - + This is intended to be used in Lafite, where one wants to indent a piece of a + forwarded document, but can be used in any TEdit document) (LET ((selection (TEDIT.GETSEL text-stream))) (TEDIT-INDENT-REPLACE-SELECTION @@ -144,13 +145,11 @@ (CONCATLIST (for string on (TEDIT-INDENT-SEPERATE-PARAGRAPHS (TEDIT.SEL.AS.STRING text-stream selection) explicit-paragraph-breaks?) - bind [hanging-indent _ (AND [NOT (EQP (GETLD (CAR (GETSEL selection L1)) - LCHAR1) - (TEDIT.SELPROP selection 'CH#] - (DIFFERENCE (TEDIT.SELPROP selection - 'CH#) - (GETLD (CAR (GETSEL selection L1)) - LCHAR1] + bind [hanging-indent _ + (AND (NOT (EQP (fetch CHAR1 of (CAR (fetch L1 of selection))) + (fetch CH# of selection))) + (DIFFERENCE (fetch CH# of selection) + (fetch CHAR1 of (CAR (fetch L1 of selection] join (PROG1 (LIST (TEDIT-INDENT-ADD-INDENTATION (CAR string) "" *TEDIT-INDENT-LINE-LENGTH* hanging-indent) *eol-string*) @@ -185,10 +184,15 @@ 'RIGHT]) (TEDIT-INDENT-SELECTION - [LAMBDA (text-stream explicit-paragraph-breaks?) (* ; "Edited 15-Feb-2025 14:07 by rmk") - (* smL "21-Jan-87 16:00") - -(* ;;; "Indent the current selection by prefacing each line with the value of *TEDIT-INDENT-STRING*, and inserting line breaks after each *TEDIT-INDENT-LINE-LENGTH* characters. --- If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in the current selection are removed. --- This is intended to be used in Lafite, where one wants to indent a piece of a forwarded document, but can be used in any TEdit document") + [LAMBDA (text-stream explicit-paragraph-breaks?) (* smL "21-Jan-87 16:00") + + (* * Indent the current selection by prefacing each line with the value of + *TEDIT-INDENT-STRING*, and inserting line breaks after each + *TEDIT-INDENT-LINE-LENGTH* characters. - + If the flag *TEDIT-INDENT-KEEP-LINE-BREAKS* is false, existing line breaks in + the current selection are removed. - + This is intended to be used in Lafite, where one wants to indent a piece of a + forwarded document, but can be used in any TEdit document) (LET ((selection (TEDIT.GETSEL text-stream))) (TEDIT-INDENT-REPLACE-SELECTION @@ -196,13 +200,11 @@ (CONCATLIST (for string on (TEDIT-INDENT-SEPERATE-PARAGRAPHS (TEDIT.SEL.AS.STRING text-stream selection) explicit-paragraph-breaks?) - bind [hanging-indent _ (AND [NOT (EQP (GETLD (CAR (GETSEL selection L1)) - LCHAR1) - (TEDIT.SELPROP selection 'CH#] - (DIFFERENCE (TEDIT.SELPROP selection - 'CH#) - (GETLD (CAR (GETSEL selection L1)) - LCHAR1] + bind [hanging-indent _ + (AND (NOT (EQP (fetch CHAR1 of (CAR (fetch L1 of selection))) + (fetch CH# of selection))) + (DIFFERENCE (fetch CH# of selection) + (fetch CHAR1 of (CAR (fetch L1 of selection] join (PROG1 (LIST (TEDIT-INDENT-ADD-INDENTATION (CAR string) *TEDIT-INDENT-STRING* *TEDIT-INDENT-LINE-LENGTH* hanging-indent) @@ -232,19 +234,18 @@ else (\TEDIT-INDENT-SEPERATE-PARAGRAPHS string NIL]) (TEDIT-INDENT-SET-INDENT - [LAMBDA (text-stream) (* ; "Edited 15-Feb-2025 09:21 by rmk") - (* smL "12-Sep-86 17:09") + [LAMBDA (text-stream) (* smL "12-Sep-86 17:09") + + (* * Prompt the user for a new indentation string) -(* ;;; "Prompt the user for a new indentation string") - - (LET* ((window (\TEDIT.PRIMARYPANE text-stream)) + (LET* ((window (fetch \WINDOW of (TEXTOBJ text-stream))) (pwindow (if window then (GETPROMPTWINDOW (if (LISTP window) then (CAR window) else window)) else PROMPTWINDOW))) (CLEARW pwindow) - (SETQ *TEDIT-INDENT-STRING* (PROMPTFORWORD "New indent string: " *TEDIT-INDENT-STRING* NIL + (SETQ *TEDIT-INDENT-STRING* (PROMPTFORWORD "New indent string: " *TEDIT-INDENT-STRING* NIL pwindow NIL NIL (LIST (CHARCODE EOL]) (TEDIT-INDENT-STRIP-INDENTATION @@ -269,34 +270,36 @@ else string]) (TEDIT-MAKE-LINES-EXPLICIT - [LAMBDA (text-stream) (* ; "Edited 15-Feb-2025 09:20 by rmk") - (* smL " 8-Sep-86 18:20") - -(* ;;; "Take the current selection and replace all TEdit end-of-lines with explicit line breaks. --- This is intended to be used in Lafite, where it is sometimes nice to know that anyone receiving the msg will see the same line breaks that you see. see, but can be used in any TEdit document") + [LAMBDA (text-stream) (* smL " 8-Sep-86 18:20") + + (* * Take the current selection and replace all TEdit end-of-lines with + explicit line breaks. - + This is intended to be used in Lafite, where it is sometimes nice to know that + anyone receiving the msg will see the same line breaks that you see. + see, but can be used in any TEdit document) (LET ((selection (TEDIT.GETSEL text-stream))) - [for i in (bind (this-line _ (CAR (GETSEL selection L1))) - [last-line _ (CAR (LAST (GETSEL selection LN] - repeatuntil (PROGN (SETQ this-line (GETLD this-line NEXTLINE)) - (EQ this-line last-line)) collect (GETLD this-line LCHARLIM) - ) do (TEDIT.SETSEL text-stream i 1 'LEFT T) - (TEDIT.INSERT text-stream (CONSTANT (CHARACTER (CHARCODE EOL] + [for i in (bind (this-line _ (CAR (fetch L1 of selection))) + [last-line _ (CAR (LAST (fetch LN of selection] + repeatuntil (PROGN (SETQ this-line (fetch NEXTLINE of this-line)) + (EQ this-line last-line)) collect (fetch CHARLIM + of this-line)) + do (TEDIT.SETSEL text-stream i 1 'LEFT T) + (TEDIT.INSERT text-stream (CONSTANT (CHARACTER (CHARCODE EOL] (TEDIT.SETSEL text-stream selection NIL 'RIGHT]) (TEDIT-OPEN-LINE - [LAMBDA (text-stream) (* ; "Edited 15-Feb-2025 14:09 by rmk") - (* smL "17-Sep-86 11:13") - -(* ;;; "Open a new line at the current position.") + [LAMBDA (text-stream) (* smL "17-Sep-86 11:13") + + (* * Open a new line at the current position.) (LET ((selection (TEDIT.GETSEL text-stream))) - (TEDIT.INSERT text-stream (CONCAT *eol-string* (ALLOCSTRING - (DIFFERENCE (TEDIT.SELPROP selection - 'CH#) - (GETLD (CAR (GETSEL selection L1)) - LCHAR1)) - " "))) - (if (ZEROP (TEDIT.SELPROP selection 'LENGTH)) + (TEDIT.INSERT text-stream (CONCAT *eol-string* + (ALLOCSTRING [DIFFERENCE (fetch CH# of selection) + (fetch CHAR1 + of (CAR (fetch L1 of selection] + " "))) + (if (ZEROP (fetch DCH of selection)) then (TEDIT.SETSEL text-stream selection]) (TEDIT-REMOVE-INDENT @@ -433,12 +436,12 @@ "Break long lines by inserting explicit 's" ] (DECLARE%: DONTCOPY - (FILEMAP (NIL (4363 24314 (TEDIT-INDENT-ADD-INDENTATION 4373 . 6941) (TEDIT-INDENT-BREAK-LINE 6943 . -8876) (TEDIT-INDENT-BREAK-LONG-LINES 8878 . 10828) (TEDIT-INDENT-FIND-BREAKPOINT 10830 . 11653) ( -TEDIT-INDENT-REPLACE-SELECTION 11655 . 12212) (TEDIT-INDENT-SELECTION 12214 . 14283) ( -TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS 14285 . 14564) (TEDIT-INDENT-SEPERATE-PARAGRAPHS 14566 . -15295) (TEDIT-INDENT-SET-INDENT 15297 . 16143) (TEDIT-INDENT-STRIP-INDENTATION 16145 . 17365) ( -TEDIT-MAKE-LINES-EXPLICIT 17367 . 18517) (TEDIT-OPEN-LINE 18519 . 19453) (TEDIT-REMOVE-INDENT 19455 . -20225) (\TEDIT-INDENT-COUNT-SPACES 20227 . 20828) (\TEDIT-INDENT-FIND-PARAGRAPH-END 20830 . 21801) ( -\TEDIT-INDENT-SEPERATE-LINES 21803 . 22601) (\TEDIT-INDENT-SEPERATE-PARAGRAPHS 22603 . 24312))))) + (FILEMAP (NIL (4193 23598 (TEDIT-INDENT-ADD-INDENTATION 4203 . 6771) (TEDIT-INDENT-BREAK-LINE 6773 . +8706) (TEDIT-INDENT-BREAK-LONG-LINES 8708 . 10475) (TEDIT-INDENT-FIND-BREAKPOINT 10477 . 11300) ( +TEDIT-INDENT-REPLACE-SELECTION 11302 . 11859) (TEDIT-INDENT-SELECTION 11861 . 13762) ( +TEDIT-INDENT-SELECTION-KEEPING-LINEBREAKS 13764 . 14043) (TEDIT-INDENT-SEPERATE-PARAGRAPHS 14045 . +14774) (TEDIT-INDENT-SET-INDENT 14776 . 15550) (TEDIT-INDENT-STRIP-INDENTATION 15552 . 16772) ( +TEDIT-MAKE-LINES-EXPLICIT 16774 . 17979) (TEDIT-OPEN-LINE 17981 . 18737) (TEDIT-REMOVE-INDENT 18739 . +19509) (\TEDIT-INDENT-COUNT-SPACES 19511 . 20112) (\TEDIT-INDENT-FIND-PARAGRAPH-END 20114 . 21085) ( +\TEDIT-INDENT-SEPERATE-LINES 21087 . 21885) (\TEDIT-INDENT-SEPERATE-PARAGRAPHS 21887 . 23596))))) STOP diff --git a/library/lafite/LAFITE-INDENT.LCOM b/library/lafite/LAFITE-INDENT.LCOM index 21cd24f7..3f36b45a 100644 Binary files a/library/lafite/LAFITE-INDENT.LCOM and b/library/lafite/LAFITE-INDENT.LCOM differ diff --git a/library/lafite/LAFITE-PRIVATEDL b/library/lafite/LAFITE-PRIVATEDL index a6c0c484..b4c5e2af 100644 --- a/library/lafite/LAFITE-PRIVATEDL +++ b/library/lafite/LAFITE-PRIVATEDL @@ -1,30 +1,28 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED "19-Jan-87 23:56:51" {ERIS}LISPCORE>LAFITEPRIVATEDL.;1 10080 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - previous date%: "19-Jan-87 23:47:54" {PHYLUM}KOTO>LAFITEPRIVATEDL.;2) +(FILECREATED "18-Feb-2026 15:50:14" {WMEDLEY}lafite>LAFITE-PRIVATEDL.;2 9719 + + :EDIT-BY rmk + + :CHANGES-TO (FNS \GV.PARSERECIPIENTS1 \GV.PARSE.PRIVATE.DISTRIBUTION.LIST)) -(* " -Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. -") +(PRETTYCOMPRINT LAFITE-PRIVATEDLCOMS) -(PRETTYCOMPRINT LAFITEPRIVATEDLCOMS) - -(RPAQQ LAFITEPRIVATEDLCOMS ((* * LAFITEDL.EXT is the default extension for dl files when no extension - is specified) - (* * LAFITEDLDIRECTORIES is a list of directories to be searched after - the connected directory and the LAFITEDEFAULTHOST&DIR in order to - locate a dl file when no host or directory is specified) - (INITVARS (LAFITEDL.EXT 'DL) - (LAFITEDLDIRECTORIES NIL)) - (* * no functions are user callable) - (FNS \GV.PARSERECIPIENTS1 \GV.PARSE.PRIVATE.DISTRIBUTION.LIST) - (* Lafite's readtable for parsing addresses needs to have CR as a - SEPRCHAR so that lines from a text file can all be parsed at once. - This has no effect on normal operation since before private dls no CR - was ever passed to the parser) - (P (SETSYNTAX (CHARCODE CR) - 'SEPRCHAR ADDRESSPARSERRDTBL)))) +(RPAQQ LAFITE-PRIVATEDLCOMS + ((* * LAFITEDL.EXT is the default extension for dl files when no extension is specified) + (* * LAFITEDLDIRECTORIES is a list of directories to be searched after the connected + directory and the LAFITEDEFAULTHOST&DIR in order to locate a dl file when no host or + directory is specified) + (INITVARS (LAFITEDL.EXT 'DL) + (LAFITEDLDIRECTORIES NIL)) + (* * no functions are user callable) + (FNS \GV.PARSERECIPIENTS1 \GV.PARSE.PRIVATE.DISTRIBUTION.LIST) + (* Lafite's readtable for parsing addresses needs to have CR as a SEPRCHAR so that lines from + a text file can all be parsed at once. This has no effect on normal operation since before + private dls no CR was ever passed to the parser) + (P (SETSYNTAX (CHARCODE CR) + 'SEPRCHAR ADDRESSPARSERRDTBL)))) (* * LAFITEDL.EXT is the default extension for dl files when no extension is specified) (* * LAFITEDLDIRECTORIES is a list of directories to be searched after the connected directory and the @@ -39,7 +37,7 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (DEFINEQ (\GV.PARSERECIPIENTS1 - [LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:44") + [LAMBDA (FIELD REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:44") (* ;;; "INTERNALFLG = T means produce addresses to give Grapevine; NIL means give human-readable addresses") @@ -73,8 +71,8 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (CHARCODE %")) (HELP] (OR REGISTRY (SETQ REGISTRY DEFAULTREGISTRY)) - - (* ;; "first just collect all the atoms using a special readtable ") + + (* ;; "first just collect all the atoms using a special readtable ") (SETQ ADDRESSES (when (SETQ ADDR (until (OR (EOFP FIELDSTREAM) (EQ (SETQ TOKEN (READ FIELDSTREAM @@ -107,14 +105,13 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (EQ (CADDR ADDRESS) ';)) then - - (* ;; "it's a private dl --- foo:;") + (* ;; "it's a private dl --- foo:;") - (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST ADDRESS REGISTRY INTERNALFLG + (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST ADDRESS REGISTRY INTERNALFLG EDITWINDOW) else - - (* ;; "ADDRESS will only get rebound if there is an address with <>'s in it ") + (* ;; + "ADDRESS will only get rebound if there is an address with <>'s in it ") (SETQ VALIDRECIPIENT (\GV.PARSE.SINGLE.ADDRESS (COND @@ -128,8 +125,8 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. ((OR T INTERNALFLG (NULL REALADDRESS)) VALIDRECIPIENT) (T - - (* ;; "Need to figure out how to make GETREGISTRY of this work, and remove duplicates in MAKEANSWERFORM before we can enable this") + + (* ;; "Need to figure out how to make GETREGISTRY of this work, and remove duplicates in MAKEANSWERFORM before we can enable this") (\GV.REPACKADDRESS (APPEND (LDIFF ADDRESS OPEN) (LIST '< VALIDRECIPIENT @@ -137,7 +134,7 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (CDR CLOSE]) (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST - [LAMBDA (DL REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:45") + [LAMBDA (DL REGISTRY INTERNALFLG EDITWINDOW) (* N.H.Briggs "19-Jan-87 23:45") (LET* [(FILENAME (FINDFILE (PACKFILENAME.STRING 'BODY (CAR DL) 'EXTENSION LAFITEDL.EXT) T @@ -162,10 +159,10 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. file can all be parsed at once. This has no effect on normal operation since before private dls no CR was ever passed to the parser) + (SETSYNTAX (CHARCODE CR) 'SEPRCHAR ADDRESSPARSERRDTBL) -(PUTPROPS LAFITEPRIVATEDL COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1965 9682 (\GV.PARSERECIPIENTS1 1975 . 8562) (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST 8564 - . 9680))))) + (FILEMAP (NIL (1617 9389 (\GV.PARSERECIPIENTS1 1627 . 8273) (\GV.PARSE.PRIVATE.DISTRIBUTION.LIST 8275 + . 9387))))) STOP diff --git a/library/lafite/LAFITE-PRIVATEDL.LCOM b/library/lafite/LAFITE-PRIVATEDL.LCOM new file mode 100644 index 00000000..9792b71a Binary files /dev/null and b/library/lafite/LAFITE-PRIVATEDL.LCOM differ diff --git a/library/sketch/SKETCH b/library/sketch/SKETCH index 9feb5bf9..2935c983 100644 --- a/library/sketch/SKETCH +++ b/library/sketch/SKETCH @@ -1,13 +1,10 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) -(FILECREATED "24-Dec-2025 14:48:39" {WMEDLEY}SKETCH>SKETCH.;16 491600 +(FILECREATED "19-Feb-2026 22:27:48" {WMEDLEY}sketch>SKETCH.;17 509947 :EDIT-BY rmk - :CHANGES-TO (VARS SKETCHCOMS) - (FNS SK.INCLUDE.FILE SK.GET.IMAGEOBJ.FROM.FILE SKETCH.PUT SKETCH.FLUSH.EXISTING) - - :PREVIOUS-DATE "30-Nov-2025 10:10:57" {WMEDLEY}SKETCH>SKETCH.;11) + :PREVIOUS-DATE "24-Dec-2025 14:48:39" {WMEDLEY}sketch>SKETCH.;16) (PRETTYCOMPRINT SKETCHCOMS) @@ -285,7 +282,7 @@ (T "")) " then type 'RETURN'. -To abort loading the new version of Sketch, type '^'."]) +To abort loading the new version of Sketch, type '↑'."]) ) ) (DECLARE%: FIRST DOCOPY DONTEVAL@LOAD @@ -300,18 +297,17 @@ To abort loading the new version of Sketch, type '^'."]) (DEFINEQ (SKETCH.FROM.A.FILE - [LAMBDA NIL (* rrb "24-Jun-86 11:40") - - (* reads a file name from the user and calls sketch on it.) - + [LAMBDA NIL (* rrb "24-Jun-86 11:40") + (* reads a file name from the user and + calls sketch on it.) (PROG ((NAME (PopUpWindowAndGetAtom "Sketch file name: "))) (RETURN (AND NAME (SKETCH NAME]) (SK.PUT.ON.FILE [LAMBDA (SKETCHW) (* ; "Edited 6-Apr-87 18:18 by rrb") (* saves a sketch on a Tedit file.) - - (* also changes the name of the sketch to be the same as the name of the file.) + + (* also changes the name of the sketch to be the same as the name of the file.) (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW))) NOWNAME NEWNAME TEXTSTREAM) @@ -321,10 +317,8 @@ To abort loading the new version of Sketch, type '^'."]) (RETURN NIL)) (SETQ NEWNAME (SKETCH.PUT NEWNAME SKETCH SKETCHW)) [COND - ((AND NEWNAME (NEQ NOWNAME NEWNAME)) - - (* change the name of the sketch to be the same as the file name.) - + ((AND NEWNAME (NEQ NOWNAME NEWNAME)) (* change the name of the sketch to be + the same as the file name.) (replace (SKETCH SKETCHNAME) of SKETCH with NEWNAME) (* change the titles of the viewers  onto this sketch.) @@ -461,15 +455,14 @@ To abort loading the new version of Sketch, type '^'."]) (RETURN (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]) (SK.GET.FROM.FILE - [LAMBDA (SKETCHW) (* rrb " 1-Oct-86 18:24") - - (* retrieves a sketch from a file clobbering any existing sketch.) - + [LAMBDA (SKETCHW) (* rrb " 1-Oct-86 18:24") + (* retrieves a sketch from a file + clobbering any existing sketch.) (COND ((SK.CONFIRM.DESTRUCTION SKETCHW "Press LEFT to delete current elements before GET.") - - (* put the delete on the history list so that it can be undone. - This leaves the gotten file there as well but seems better than nothing.) + + (* put the delete on the history list so that it can be undone. + This leaves the gotten file there as well but seems better than nothing.) (SK.DELETE.ELEMENT2 (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH SKETCHW)) SKETCHW) @@ -479,21 +472,19 @@ To abort loading the new version of Sketch, type '^'."]) (T (STATUSPRINT SKETCHW "GET aborted. The INCLUDE subcommand to GET doesn't delete."]) (SKETCH.GET - [LAMBDA (FILENAME VIEWER) (* rrb "29-Jan-86 11:21") + [LAMBDA (FILENAME VIEWER) (* rrb "29-Jan-86 11:21") (* reads a sketch from a file.) (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of (SK.GET.IMAGEOBJ.FROM.FILE FILENAME VIEWER]) ) (DEFINEQ (SKETCH - [LAMBDA (SKETCH WINDOW) (* rrb "17-Sep-86 10:21") + [LAMBDA (SKETCH WINDOW) (* rrb "17-Sep-86 10:21") (* opens a sketch window onto the  sketch SKETCH) (COND - [(AND SKETCH (LITATOM SKETCH)) - - (* assume its a filename Get the region and scale from the file.) - + [(AND SKETCH (LITATOM SKETCH)) (* assume its a filename Get the + region and scale from the file.) (PROG ((SKIMAGEOBJ (SK.GET.IMAGEOBJ.FROM.FILE SKETCH)) SCREENREG READSKETCH) (SETQ SCREENREG (SK.SCALE.REGION (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKIMAGEOBJ) @@ -517,14 +508,145 @@ To abort loading the new version of Sketch, type '^'."]) NIL NIL T T]) (SKETCHW.CREATE -(LAMBDA (SKETCH SKETCHREGION SCREENREGION TITLE INITIALSCALE BRINGUPMENU INITIALGRID) (* ; "Edited 25-Apr-88 15:18 by drc:") (* ;;; "creates a sketch window and returns it.") (PROG (W SCALE SKPROC SKETCHSTRUCTURE) (SETQ SKETCHSTRUCTURE (SK.CHECK.SKETCH.VERSION (COND ((NULL SKETCH) (SKETCH.CREATE NIL)) ((LITATOM SKETCH) (* ; "treat it like a file name") (SKETCH.GET SKETCH)) ((type? SKETCH SKETCH) SKETCH) ((type? IMAGEOBJ SKETCH) (* ; "pull things out of the image object.") (SETQ SKPROC (IMAGEOBJPROP SKETCH (QUOTE OBJECTDATUM))) (OR (REGIONP SKETCHREGION) (SETQ SKETCHREGION (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SKPROC))) (OR (NUMBERP INITIALSCALE) (SETQ INITIALSCALE (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of SKPROC))) (OR (NUMBERP INITIALGRID) (SETQ INITIALGRID (fetch (SKETCHIMAGEOBJ SKIO.GRID) of SKPROC))) (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of SKPROC)) ((AND (LITATOM (CAR SKETCH)) (for ELT in (CDR SKETCH) always (GLOBALELEMENTP ELT))) (* ; "old form, probably written out by notecards, update to new form.") (PROG (X) (SETQ X (SKIO.UPDATE.FROM.OLD.FORM SKETCH)) (* ; "smash sketch so this won't have to happen every time.") (RPLACA SKETCH (CAR X)) (RPLACD SKETCH (CDR X)) (RETURN X))) (T (\ILLEGAL.ARG SKETCH))))) (SETQ W (COND ((WINDOWP SCREENREGION) (AND TITLE (WINDOWPROP SCREENREGION (QUOTE TITLE) TITLE)) SCREENREGION) (T (CREATEW (COND ((REGIONP SCREENREGION)) (T (CREATEREGION LASTMOUSEX LASTMOUSEY 20 20))) (OR TITLE (SK.WINDOW.TITLE SKETCHSTRUCTURE)) NIL T)))) (SK.SET.UP.MENUS W (NOT (OPENWP SCREENREGION)) BRINGUPMENU) (COND ((OR (REGIONP SCREENREGION) (WINDOWP SCREENREGION)) (* ; "user gave a region, don't interact") NIL) (T (* ; "let prompting for reshape show room for both menu and window.") (SHAPEW W))) (* ;; "set the right margin so that text will never run into it. This can be removed when character positions are kept in points so \DSPPRINTCHAR doesn't have to look at the right margin.") (DSPRIGHTMARGIN 64000 W) (WINDOWPROP W (QUOTE SKETCH) SKETCHSTRUCTURE) (WINDOWPROP W (QUOTE SCALE) (SETQ SCALE (COND ((NUMBERP INITIALSCALE)) ((REGIONP SKETCHREGION) (* ; "determine the scale and offsets so that the given region of the sketch fits into the given window.") (FQUOTIENT (fetch (REGION HEIGHT) of SKETCHREGION) (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL W)))) ((NULL SKETCHREGION) INITIAL.SCALE) (T (\ILLEGAL.ARG SKETCHREGION))))) (* ; "check to make sure a context exists on the sketch because before July 1985 it didn't exist.") (WINDOWPROP W (QUOTE SKETCHCONTEXT) (OR (GETSKETCHPROP SKETCHSTRUCTURE (QUOTE SKETCHCONTEXT)) (PUTSKETCHPROP SKETCHSTRUCTURE (QUOTE SKETCHCONTEXT) (CREATE.DEFAULT.SKETCH.CONTEXT)))) (COND ((REGIONP SKETCHREGION) (* ; "if given a region, translate to it.") (WXOFFSET (IMINUS (FIX (QUOTIENT (fetch (REGION LEFT) of SKETCHREGION) SCALE))) W) (WYOFFSET (IMINUS (FIX (QUOTIENT (fetch (REGION BOTTOM) of SKETCHREGION) SCALE))) W))) (SK.UPDATE.REGION.VIEWED W) (* ; "calculate the sketch region being viewed before mapping the sketch into it.") (MAP.SKETCHSPEC.INTO.VIEWER SKETCHSTRUCTURE W) (SK.CREATE.HOTSPOT.CACHE W) (WINDOWPROP W (QUOTE GRIDFACTOR) (COND ((NUMBERP INITIALGRID) (LEASTPOWEROF2GT INITIALGRID)) (T (SK.DEFAULT.GRIDFACTOR W)))) (WINDOWPROP W (QUOTE USEGRID) (COND (INITIALGRID T))) (WINDOWPROP W (QUOTE BUTTONEVENTFN) (FUNCTION WB.BUTTON.HANDLER)) (WINDOWPROP W (QUOTE COPYBUTTONEVENTFN) (FUNCTION SK.COPY.BUTTONEVENTFN)) (WINDOWPROP W (QUOTE COPYINSERTFN) (FUNCTION SK.COPY.INSERTFN)) (WINDOWPROP W (QUOTE RIGHTBUTTONFN) (FUNCTION WB.BUTTON.HANDLER)) (WINDOWPROP W (QUOTE CURSOROUTFN) (FUNCTION SKETCHW.OUTFN)) (WINDOWPROP W (QUOTE REPAINTFN) (FUNCTION SKETCHW.REPAINTFN)) (WINDOWADDPROP W (QUOTE RESHAPEFN) (FUNCTION SKETCHW.RESHAPEFN)) (WINDOWADDPROP W (QUOTE SHRINKFN) (FUNCTION SK.RETURN.TTY)) (WINDOWPROP W (QUOTE ICONFN) (FUNCTION SK.SHRINK.ICONCREATE)) (WINDOWADDPROP W (QUOTE EXPANDFN) (FUNCTION SK.TAKE.TTY)) (WINDOWPROP W (QUOTE SCROLLFN) (FUNCTION SKETCHW.SCROLLFN)) (WINDOWPROP W (QUOTE HARDCOPYFN) (FUNCTION SKETCHW.HARDCOPYFN)) (* ; "I'm not sure why this ever gets called but it did once so to be sure, turn it off.") (WINDOWPROP W (QUOTE PAGEFULLFN) (FUNCTION NILL)) (WINDOWPROP W (QUOTE PROCESS) (SETQ SKPROC (ADD.PROCESS (LIST (FUNCTION WB.EDITOR) (KWOTE W)) (QUOTE RESTARTABLE) T (QUOTE TTYENTRYFN) (QUOTE SK.TTYENTRYFN) (QUOTE TTYEXITFN) (QUOTE SK.TTYEXITFN)))) (WINDOWPROP W (QUOTE SCROLLEXTENTUSE) T) (WINDOWADDPROP W (QUOTE CLOSEFN) (FUNCTION SKETCHW.CLOSEFN) T) (OPENW W) (ADD.SKETCH.VIEWER SKETCHSTRUCTURE W) (SKETCHW.REPAINTFN W) (RETURN W))) -) + [LAMBDA (SKETCH SKETCHREGION SCREENREGION TITLE INITIALSCALE BRINGUPMENU INITIALGRID) + (* ; "Edited 25-Apr-88 15:18 by drc:") + +(* ;;; "creates a sketch window and returns it.") + + (PROG (W SCALE SKPROC SKETCHSTRUCTURE) + [SETQ SKETCHSTRUCTURE (SK.CHECK.SKETCH.VERSION (COND + ((NULL SKETCH) + (SKETCH.CREATE NIL)) + ((LITATOM SKETCH) + (* ; "treat it like a file name") + (SKETCH.GET SKETCH)) + ((type? SKETCH SKETCH) + SKETCH) + ((type? IMAGEOBJ SKETCH) + (* ; + "pull things out of the image object.") + (SETQ SKPROC (IMAGEOBJPROP SKETCH + 'OBJECTDATUM)) + (OR (REGIONP SKETCHREGION) + (SETQ SKETCHREGION + (fetch (SKETCHIMAGEOBJ SKIO.REGION) + of SKPROC))) + (OR (NUMBERP INITIALSCALE) + (SETQ INITIALSCALE + (fetch (SKETCHIMAGEOBJ SKIO.SCALE) + of SKPROC))) + (OR (NUMBERP INITIALGRID) + (SETQ INITIALGRID + (fetch (SKETCHIMAGEOBJ SKIO.GRID) + of SKPROC))) + (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) + of SKPROC)) + ((AND (LITATOM (CAR SKETCH)) + (for ELT in (CDR SKETCH) + always (GLOBALELEMENTP ELT))) + (* ; + "old form, probably written out by notecards, update to new form.") + (PROG (X) + (SETQ X (SKIO.UPDATE.FROM.OLD.FORM + SKETCH)) + (* ; + "smash sketch so this won't have to happen every time.") + (RPLACA SKETCH (CAR X)) + (RPLACD SKETCH (CDR X)) + (RETURN X))) + (T (\ILLEGAL.ARG SKETCH] + [SETQ W (COND + ((WINDOWP SCREENREGION) + (AND TITLE (WINDOWPROP SCREENREGION 'TITLE TITLE)) + SCREENREGION) + (T (CREATEW (COND + ((REGIONP SCREENREGION)) + (T (CREATEREGION LASTMOUSEX LASTMOUSEY 20 20))) + (OR TITLE (SK.WINDOW.TITLE SKETCHSTRUCTURE)) + NIL T] + (SK.SET.UP.MENUS W (NOT (OPENWP SCREENREGION)) + BRINGUPMENU) + (COND + ((OR (REGIONP SCREENREGION) + (WINDOWP SCREENREGION)) (* ; + "user gave a region, don't interact") + NIL) + (T (* ; + "let prompting for reshape show room for both menu and window.") + (SHAPEW W))) + + (* ;; "set the right margin so that text will never run into it. This can be removed when character positions are kept in points so \DSPPRINTCHAR doesn't have to look at the right margin.") + + (DSPRIGHTMARGIN 64000 W) + (WINDOWPROP W 'SKETCH SKETCHSTRUCTURE) + [WINDOWPROP W 'SCALE (SETQ SCALE (COND + ((NUMBERP INITIALSCALE)) + [(REGIONP SKETCHREGION) + (* ; + "determine the scale and offsets so that the given region of the sketch fits into the given window.") + (FQUOTIENT (fetch (REGION HEIGHT) of SKETCHREGION) + (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION + NIL W] + ((NULL SKETCHREGION) + INITIAL.SCALE) + (T (\ILLEGAL.ARG SKETCHREGION] + (* ; + "check to make sure a context exists on the sketch because before July 1985 it didn't exist.") + [WINDOWPROP W 'SKETCHCONTEXT (OR (GETSKETCHPROP SKETCHSTRUCTURE 'SKETCHCONTEXT) + (PUTSKETCHPROP SKETCHSTRUCTURE 'SKETCHCONTEXT ( + CREATE.DEFAULT.SKETCH.CONTEXT + ] + (COND + ((REGIONP SKETCHREGION) (* ; + "if given a region, translate to it.") + (WXOFFSET (IMINUS (FIX (QUOTIENT (fetch (REGION LEFT) of SKETCHREGION) + SCALE))) + W) + (WYOFFSET (IMINUS (FIX (QUOTIENT (fetch (REGION BOTTOM) of SKETCHREGION) + SCALE))) + W))) + (SK.UPDATE.REGION.VIEWED W) (* ; + "calculate the sketch region being viewed before mapping the sketch into it.") + (MAP.SKETCHSPEC.INTO.VIEWER SKETCHSTRUCTURE W) + (SK.CREATE.HOTSPOT.CACHE W) + [WINDOWPROP W 'GRIDFACTOR (COND + ((NUMBERP INITIALGRID) + (LEASTPOWEROF2GT INITIALGRID)) + (T (SK.DEFAULT.GRIDFACTOR W] + (WINDOWPROP W 'USEGRID (COND + (INITIALGRID T))) + (WINDOWPROP W 'BUTTONEVENTFN (FUNCTION WB.BUTTON.HANDLER)) + (WINDOWPROP W 'COPYBUTTONEVENTFN (FUNCTION SK.COPY.BUTTONEVENTFN)) + (WINDOWPROP W 'COPYINSERTFN (FUNCTION SK.COPY.INSERTFN)) + (WINDOWPROP W 'RIGHTBUTTONFN (FUNCTION WB.BUTTON.HANDLER)) + (WINDOWPROP W 'CURSOROUTFN (FUNCTION SKETCHW.OUTFN)) + (WINDOWPROP W 'REPAINTFN (FUNCTION SKETCHW.REPAINTFN)) + (WINDOWADDPROP W 'RESHAPEFN (FUNCTION SKETCHW.RESHAPEFN)) + (WINDOWADDPROP W 'SHRINKFN (FUNCTION SK.RETURN.TTY)) + (WINDOWPROP W 'ICONFN (FUNCTION SK.SHRINK.ICONCREATE)) + (WINDOWADDPROP W 'EXPANDFN (FUNCTION SK.TAKE.TTY)) + (WINDOWPROP W 'SCROLLFN (FUNCTION SKETCHW.SCROLLFN)) + (WINDOWPROP W 'HARDCOPYFN (FUNCTION SKETCHW.HARDCOPYFN)) + (* ; + "I'm not sure why this ever gets called but it did once so to be sure, turn it off.") + (WINDOWPROP W 'PAGEFULLFN (FUNCTION NILL)) + [WINDOWPROP W 'PROCESS (SETQ SKPROC (ADD.PROCESS (LIST (FUNCTION WB.EDITOR) + (KWOTE W)) + 'RESTARTABLE T 'TTYENTRYFN 'SK.TTYENTRYFN + 'TTYEXITFN + 'SK.TTYEXITFN] + (WINDOWPROP W 'SCROLLEXTENTUSE T) + (WINDOWADDPROP W 'CLOSEFN (FUNCTION SKETCHW.CLOSEFN) + T) + (OPENW W) + (ADD.SKETCH.VIEWER SKETCHSTRUCTURE W) + (SKETCHW.REPAINTFN W) + (RETURN W]) (SKETCH.RESET - [LAMBDA (SKETCH) (* rrb "11-Dec-85 11:24") - - (* resets a sketch structure and all of the viewers onto it.) - + [LAMBDA (SKETCH) (* rrb "11-Dec-85 11:24") + (* resets a sketch structure and all + of the viewers onto it.) (PROG ((SKSTRUC (INSURE.SKETCH SKETCH))) (* delete all sketch elements) (replace (SKETCH SKETCHTCELL) of SKSTRUC with (CONS)) (for VIEWER in (ALL.SKETCH.VIEWERS SKSTRUC) do (SKED.CLEAR.SELECTION VIEWER) @@ -541,19 +663,18 @@ To abort loading the new version of Sketch, type '^'."]) (WINDOWPROP VIEWER 'SKETCHCHANGED NIL]) (SKETCHW.FIG.CHANGED - [LAMBDA (W) (* rrb "29-Nov-84 17:59") - - (* W is a sketch window that is being reshaped. - Mark this fact in case it came out of a document.) + [LAMBDA (W) (* rrb "29-Nov-84 17:59") + + (* W is a sketch window that is being reshaped. + Mark this fact in case it came out of a document.) (OR (WINDOWPROP W 'SKETCHCHANGED) (WINDOWPROP W 'SKETCHCHANGED 'OLD]) (SK.WINDOW.TITLE - [LAMBDA (SKETCH) (* rrb " 7-May-85 14:00") - - (* returns the window title of a window onto a sketch.) - + [LAMBDA (SKETCH) (* rrb " 7-May-85 14:00") + (* returns the window title of a + window onto a sketch.) (COND ((fetch (SKETCH SKETCHNAME) of SKETCH) (CONCAT "Viewer onto " (fetch (SKETCH SKETCHNAME) of SKETCH))) @@ -561,23 +682,22 @@ To abort loading the new version of Sketch, type '^'."]) (EDITSLIDE [LAMBDA (SKETCH LANDSCAPE) (* ; "Edited 20-Feb-87 10:44 by rrb") - - (* creates a sketch in a window the size of a screen.) - + (* creates a sketch in a window the + size of a screen.) (SKETCHW.CREATE SKETCH NIL (COND (LANDSCAPE (GETBOXREGION 780 612)) (T (GETBOXREGION 612 770))) NIL NIL T 16.0]) (EDITSKETCH - [LAMBDA (SLIDENAME) (* rrb "14-Nov-84 17:15") + [LAMBDA (SLIDENAME) (* rrb "14-Nov-84 17:15") (* edits a named sketch) (SKETCHW.CREATE (SETQ SLIDENAME (OR SLIDENAME (GENSYM "SLIDE"))) NIL NIL NIL NIL T 16.0) SLIDENAME]) (ADD.SKETCH.TO.VIEWER - [LAMBDA (SKETCHTOADD VIEWER ABOUTDEFAULTS?) (* rrb "20-Mar-86 15:55") + [LAMBDA (SKETCHTOADD VIEWER ABOUTDEFAULTS?) (* rrb "20-Mar-86 15:55") (* adds the element in SKETCHTOADD to  the sketch TOSKETCH) (PROG ([ADDSKETCH (COND @@ -594,12 +714,12 @@ To abort loading the new version of Sketch, type '^'."]) (COND ((OR (NULL ABOUTDEFAULTS?) (MENU (create MENU - ITEMS _ '((Yes T "Will use the defaults of the retrieved sketch." + ITEMS ↠'((Yes T "Will use the defaults of the retrieved sketch." ) (No NIL "Will not change the defaults.")) - CENTERFLG _ T - TITLE _ "Use the defaults from the retrieved sketch?" - MENUCOLUMNS _ 2))) + CENTERFLG ↠T + TITLE ↠"Use the defaults from the retrieved sketch?" + MENUCOLUMNS ↠2))) (PUTSKETCHPROP TOSKETCH 'SKETCHCONTEXT DEFAULTS) (WINDOWPROP VIEWER 'SKETCHCONTEXT DEFAULTS] (SK.ADD.ELEMENTS.TO.SKETCH (fetch (SKETCH SKETCHELTS) of ADDSKETCH) @@ -614,12 +734,12 @@ To abort loading the new version of Sketch, type '^'."]) (PUTSKETCHPROP TOSKETCH SKPROP (GETSKETCHPROP ADDSKETCH SKPROP]) (SK.ADD.ELEMENTS.TO.SKETCH - [LAMBDA (ELTS SKW) (* rrb "10-Mar-86 16:50") + [LAMBDA (ELTS SKW) (* rrb "10-Mar-86 16:50") (* adds a list of elements to a sketch) (for ELT in ELTS do - - (* clear the priority so that they get a priority based on their position in - the new sketch.) + + (* clear the priority so that they get a priority based on their position in the + new sketch.) (SK.SET.ELEMENT.PRIORITY ELT NIL) (SK.ADD.ELEMENT ELT SKW]) @@ -630,7 +750,7 @@ To abort loading the new version of Sketch, type '^'."]) (* ; "allows the user to set a default") (* allows the user to set a default) (\CURSOR.IN.MIDDLE.MENU (create MENU - ITEMS _ '[(Line SKETCH.SET.BRUSH.SIZE + ITEMS ↠'[(Line SKETCH.SET.BRUSH.SIZE "Sets the characteristics of the default brush." (SUBITEMS (Size SKETCH.SET.BRUSH.SIZE "Sets the size of the default brush" @@ -708,16 +828,16 @@ To abort loading the new version of Sketch, type '^'."]) ("All figures" SK.SET.FEEDBACK.ALWAYS "Most elements are shown while they are being entered. This will be slow for arcs and curves."] - CENTERFLG _ T - WHENSELECTEDFN _ (FUNCTION SK.POPUP.SELECTIONFN) - MENUFONT _ (FONTPROP (FONTCREATE BOLDFONT) + CENTERFLG ↠T + WHENSELECTEDFN ↠(FUNCTION SK.POPUP.SELECTIONFN) + MENUFONT ↠(FONTPROP (FONTCREATE BOLDFONT) 'SPEC]) (SK.POPUP.SELECTIONFN - [LAMBDA (ITEM MENU) (* rrb " 3-Sep-85 14:27") - - (* * calls the function appropriate for the item selected from the command menu - associated with a figure window.) + [LAMBDA (ITEM MENU) (* rrb " 3-Sep-85 14:27") + + (* * calls the function appropriate for the item selected from the command menu + associated with a figure window.) (* uses SKW freely from enclosing call  to MENU.) (CLOSEPROMPTWINDOW SKW) @@ -725,16 +845,16 @@ This will be slow for arcs and curves."] SKW]) (GETSKETCHWREGION - [LAMBDA (SKETCHWINDOW) (* rrb "11-Jul-86 15:48") + [LAMBDA (SKETCHWINDOW) (* rrb "11-Jul-86 15:48") (UNSCALE.REGION (GETWREGION SKETCHWINDOW) (VIEWER.SCALE SKETCHWINDOW]) (SK.ADD.ELEMENT - [LAMBDA (GELT SKETCHW DONTCLEARCURSOR GROUPFLG DONTCALLWHENADDEDFN) + [LAMBDA (GELT SKETCHW DONTCLEARCURSOR GROUPFLG DONTCALLWHENADDEDFN) (* rrb "30-Aug-86 15:08") - - (* adds a new element to a sketch window and handles propagation to all other - figure windows) + + (* adds a new element to a sketch window and handles propagation to all other + figure windows) (COND (GELT (PROG ([GELTTOADD (COND @@ -755,24 +875,24 @@ This will be slow for arcs and curves."] (RETURN ADDEDELT]) (SK.ADD.PRIORITY.ELEMENT.TO.SKETCH - [LAMBDA (SKETCH ELEMENT PRIORITY) (* rrb "10-Mar-86 18:48") - - (* * adds an element to a sketch at its place according to PRIORITY.) + [LAMBDA (SKETCH ELEMENT PRIORITY) (* rrb "10-Mar-86 18:48") + + (* * adds an element to a sketch at its place according to PRIORITY.) (PROG ((SKELTSCELL (fetch (SKETCH SKETCHTCELL) of SKETCH))) (RETURN (COND ([OR (NULL (CAR SKELTSCELL)) (NOT (LESSP PRIORITY (SK.ELEMENT.PRIORITY (CADR SKELTSCELL] - - (* special cases of no elements or this element being greater than any others. - This means the other part of the COND doesn't have to worry about the TCONC - format.) + + (* special cases of no elements or this element being greater than any others. + This means the other part of the COND doesn't have to worry about the TCONC + format.) (TCONC SKELTSCELL ELEMENT)) [(LESSP PRIORITY (SK.ELEMENT.PRIORITY (CAAR SKELTSCELL))) - - (* special check for first element. This allows the others to be handled by - replacing the tail of the element before.) + + (* special check for first element. This allows the others to be handled by + replacing the tail of the element before.) (RPLACA SKELTSCELL (CONS ELEMENT (CAR SKELTSCELL] (T (for SKELTTAIL on (CAR SKELTSCELL) when (LESSP PRIORITY (SK.ELEMENT.PRIORITY @@ -781,41 +901,40 @@ This will be slow for arcs and curves."] (RETURN ELEMENT]) (SK.ELTS.BY.PRIORITY - [LAMBDA (GELTA GELTB) (* rrb "10-Mar-86 17:57") - - (* * sort function for sketch global elements that sorts by priority.) + [LAMBDA (GELTA GELTB) (* rrb "10-Mar-86 17:57") + + (* * sort function for sketch global elements that sorts by priority.) (ILESSP (SK.ELEMENT.PRIORITY GELTA) (SK.ELEMENT.PRIORITY GELTB]) (SK.ORDER.ELEMENTS - [LAMBDA (GSKETCHELEMENTS) (* rrb "10-Mar-86 16:30") - - (* * puts a list of sketch global elements in order by priority.) + [LAMBDA (GSKETCHELEMENTS) (* rrb "10-Mar-86 16:30") + + (* * puts a list of sketch global elements in order by priority.) (SORT GSKETCHELEMENTS (FUNCTION SK.ELTS.BY.PRIORITY]) (SK.ADD.PRIORITY.LOCAL.ELEMENT.TO.SKETCH - [LAMBDA (LOCALSKETCHELTS LOCALELEMENT) (* rrb "26-Mar-86 10:21") - - (* * adds an element to a sketch at its place according to PRIORITY.) + [LAMBDA (LOCALSKETCHELTS LOCALELEMENT) (* rrb "26-Mar-86 10:21") + + (* * adds an element to a sketch at its place according to PRIORITY.) (PROG [(PRIORITY (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of LOCALELEMENT] (RETURN (COND ([OR (NULL (CDAR LOCALSKETCHELTS)) (NOT (LESSP PRIORITY (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of (CADR LOCALSKETCHELTS] - - (* special cases of no elements in which case the local elements has only a - name or this element being greater than any others. - This means the other part of the COND doesn't have to worry about the TCONC - format.) + + (* special cases of no elements in which case the local elements has only a name + or this element being greater than any others. + This means the other part of the COND doesn't have to worry about the TCONC + format.) (TCONC LOCALSKETCHELTS LOCALELEMENT)) - (T - - (* the first element of LOCALSKETCHELTS is the name of the sketch.) - + (T (* the first element of + LOCALSKETCHELTS is the name of the + sketch.) (for SKELTTAIL on (CAR LOCALSKETCHELTS) when [LESSP PRIORITY (SK.ELEMENT.PRIORITY (fetch (SCREENELT GLOBALPART) of (CADR SKELTTAIL] @@ -823,21 +942,20 @@ This will be slow for arcs and curves."] (RETURN LOCALELEMENT]) (SK.ADD.ELEMENTS - [LAMBDA (ELEMENTS SKW) (* rrb "10-Mar-86 17:57") - - (* adds a list of global elements to a viewer but doesn't make an entry on the - history list.) - - (* sorts the elements so that their relative priority remains the same.) + [LAMBDA (ELEMENTS SKW) (* rrb "10-Mar-86 17:57") + (* adds a list of global elements to a viewer but doesn't make an entry on the + history list.) + (* sorts the elements so that their + relative priority remains the same.) (for ELT in (SK.ORDER.ELEMENTS ELEMENTS) do (SK.SET.ELEMENT.PRIORITY ELT NIL) (SK.ADD.ELEMENT ELT SKW]) (SK.CHECK.WHENADDEDFN - [LAMBDA (VIEWER GELT) (* rrb "19-Oct-85 17:36") - - (* checks if the sketch has a when added fn and if so, calls it and interprets - the result. Returns a list of the elements that should be deleted.) + [LAMBDA (VIEWER GELT) (* rrb "19-Oct-85 17:36") + + (* checks if the sketch has a when added fn and if so, calls it and interprets + the result. Returns a list of the elements that should be deleted.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) ADDFN RESULT) @@ -853,34 +971,32 @@ This will be slow for arcs and curves."] (T (RETURN GELT]) (SK.APPLY.MENU.COMMAND - [LAMBDA (COMMAND SKETCHW) (* rrb " 3-Jan-85 13:17") - - (* calls the function appropriate for the item selected from the command menu - associated with a figure window.) - - (* This is a separate function so it can be called by both pop up and fixed - menu operations.) + [LAMBDA (COMMAND SKETCHW) (* rrb " 3-Jan-85 13:17") + + (* calls the function appropriate for the item selected from the command menu + associated with a figure window.) + + (* This is a separate function so it can be called by both pop up and fixed menu + operations.) (COND ((NULL COMMAND) NIL) - ((type? SKETCHTYPE COMMAND) - - (* if the selected item is an element type, add an instance.) - + ((type? SKETCHTYPE COMMAND) (* if the selected item is an element + type, add an instance.) (SKETCHW.ADD.INSTANCE COMMAND SKETCHW)) [(LISTP COMMAND) (* EVAL it) (EVAL (APPEND COMMAND (CONS (KWOTE SKETCHW] (T (APPLY* COMMAND SKETCHW]) (SK.DELETE.ELEMENT1 - [LAMBDA (OLDGELT SKETCHW GROUPFLG) (* rrb "19-Oct-85 17:09") - - (* deletes an element to a sketch window and handles propagation to all other - figure windows) - - (* GROUPFLG indicates that this is part of a group operation and hence display - and image object deleted fns don't need to be called.) + [LAMBDA (OLDGELT SKETCHW GROUPFLG) (* rrb "19-Oct-85 17:09") + + (* deletes an element to a sketch window and handles propagation to all other + figure windows) + + (* GROUPFLG indicates that this is part of a group operation and hence display + and image object deleted fns don't need to be called.) (PROG ((SKETCH (SKETCH.FROM.VIEWER SKETCHW)) LOCALELT) (* delete the element to the sketch.) @@ -898,10 +1014,9 @@ This will be slow for arcs and curves."] (RETURN OLDGELT]) (SK.MARK.DIRTY - [LAMBDA (SKETCH) (* rrb " 1-Oct-86 18:15") - - (* marks a sketch as having been changed. - Puts a flag on its viewers.) + [LAMBDA (SKETCH) (* rrb " 1-Oct-86 18:15") + (* marks a sketch as having been + changed. Puts a flag on its viewers.) (* checks first because this is faster  than always putting.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) do (OR (EQ (WINDOWPROP SKW 'SKETCHCHANGED) @@ -909,18 +1024,15 @@ This will be slow for arcs and curves."] (WINDOWPROP SKW 'SKETCHCHANGED T]) (SK.MARK.UNDIRTY - [LAMBDA (SKETCH) (* rrb "29-Nov-84 18:03") - - (* marks a sketch as having been changed. - Puts a flag on its viewers.) - + [LAMBDA (SKETCH) (* rrb "29-Nov-84 18:03") + (* marks a sketch as having been + changed. Puts a flag on its viewers.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) do (WINDOWPROP SKW 'SKETCHCHANGED 'OLD]) (SK.MENU.AND.RETURN.FIELD - [LAMBDA (ELEMENTTYPE) (* rrb "11-May-84 16:03") - - (* returns a field list of the field to be changed.) - + [LAMBDA (ELEMENTTYPE) (* rrb "11-May-84 16:03") + (* returns a field list of the field + to be changed.) (PROG ((ITEMS (CHANGEABLEFIELDITEMS ELEMENTTYPE))) (RETURN (COND ((NULL ITEMS) @@ -928,20 +1040,20 @@ This will be slow for arcs and curves."] [(NULL (CDR ITEMS)) (EVAL (CADR (CAR ITEMS] (T (MENU (create MENU - ITEMS _ ITEMS - CENTERFLG _ T - TITLE _ "Choose which property to change"]) + ITEMS ↠ITEMS + CENTERFLG ↠T + TITLE ↠"Choose which property to change"]) (SKETCH.SET.BRUSH.SHAPE - [LAMBDA (W) (* rrb "11-Dec-84 15:31") + [LAMBDA (W) (* rrb "11-Dec-84 15:31") (* Sets the shape of the current brush) (PROG [(NEWSHAPE (PAINTW.READBRUSHSHAPE)) (NOWBRUSH (fetch (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT] (RETURN (AND NEWSHAPE (replace (SKETCHCONTEXT SKETCHBRUSH) of (WINDOWPROP W 'SKETCHCONTEXT) - with (create BRUSH using NOWBRUSH BRUSHSHAPE _ NEWSHAPE]) + with (create BRUSH using NOWBRUSH BRUSHSHAPE ↠NEWSHAPE]) (SKETCH.SET.BRUSH.SIZE - [LAMBDA (W) (* rrb "12-Jan-85 10:13") + [LAMBDA (W) (* rrb "12-Jan-85 10:13") (* sets the size of the current brush) (SK.SET.DEFAULT.BRUSH.SIZE [READBRUSHSIZE (fetch (BRUSH BRUSHSIZE) of (fetch (SKETCHCONTEXT SKETCHBRUSH) @@ -949,10 +1061,10 @@ This will be slow for arcs and curves."] W]) (SKETCHW.CLOSEFN - [LAMBDA (SKW) (* rrb " 1-Oct-86 17:44") - - (* close function for a viewer. Removes itself from the list of viewers.) - + [LAMBDA (SKW) (* rrb " 1-Oct-86 17:44") + (* close function for a viewer. + Removes itself from the list of + viewers.) (PROG (PROCINFO) [COND [(SETQ PROCINFO (WINDOWPROP SKW 'DOCUMENTINFO)) (* this window came from a tedit @@ -966,9 +1078,9 @@ This will be slow for arcs and curves."] (COND ([OR (TTY.PROCESSP (THIS.PROCESS)) (TTY.PROCESSP (WINDOWPROP SKW 'PROCESS] - - (* if this process or the sketch process has the tty, give it back to the Tedit - that this window came from.) + + (* if this process or the sketch process has the tty, give it back to the Tedit + that this window came from.) (AND [PROCESSP (SETQ PROCINFO (WINDOWPROP (fetch (SKETCHDOCUMENTINFO FROMTEDITWINDOW) @@ -984,11 +1096,11 @@ This will be slow for arcs and curves."] (WINDOWADDPROP SKW 'OPENFN 'SKETCHW.REOPENFN]) (SK.CONFIRM.DESTRUCTION - [LAMBDA (VIEWER MSG) (* rrb " 1-Oct-86 17:37") - - (* some destructive operation is about to take place, if the viewer is dirty, - confirm that this is what is intended. If so, return T. - If not, NIL.) + [LAMBDA (VIEWER MSG) (* rrb " 1-Oct-86 17:37") + + (* some destructive operation is about to take place, if the viewer is dirty, + confirm that this is what is intended. If so, return T. + If not, NIL.) (COND ((OR (WINDOWPROP VIEWER 'DONTQUERYCHANGES) @@ -1007,45 +1119,43 @@ This will be slow for arcs and curves."] (T NIL]) (SKETCHW.OUTFN - [LAMBDA (SKW) (* rrb "24-Jan-85 10:06") - - (* the cursor is leaving the window, updates any structures that may be spread - out for efficiency.) + [LAMBDA (SKW) (* rrb "24-Jan-85 10:06") + + (* the cursor is leaving the window, updates any structures that may be spread + out for efficiency.) NIL]) (SKETCHW.REOPENFN - [LAMBDA (SKW) (* rrb " 7-Feb-84 11:31") - - (* reopenfn for viewers. Adds it back onto the list of global viewers.) - + [LAMBDA (SKW) (* rrb " 7-Feb-84 11:31") + (* reopenfn for viewers. + Adds it back onto the list of global + viewers.) (ADD.SKETCH.VIEWER (WINDOWPROP SKW 'SKETCH) SKW) (WINDOWPROP SKW 'PROCESS (ADD.PROCESS (LIST (FUNCTION WB.EDITOR) (KWOTE SKW]) (MAKE.LOCAL.SKETCH - [LAMBDA (SKETCH SKETCHREGION SCALE STREAM EVERYTHINGFLG) (* rrb "22-Apr-85 16:45") - - (* * calculate the local parts for the region of the sketch at a given scale. - EVERYTHINGFLG provides a way to override the inside check. - This is necessary because the inside check works on local elements. - When the inside check is change to work on global elements, this can be - removed.) + [LAMBDA (SKETCH SKETCHREGION SCALE STREAM EVERYTHINGFLG) (* rrb "22-Apr-85 16:45") + + (* * calculate the local parts for the region of the sketch at a given scale. + EVERYTHINGFLG provides a way to override the inside check. + This is necessary because the inside check works on local elements. + When the inside check is change to work on global elements, this can be removed.) (for SKELT in (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH SKETCH)) when (OR EVERYTHINGFLG (SK.INSIDE.REGION SKELT SKETCHREGION)) collect (SK.LOCAL.FROM.GLOBAL SKELT STREAM SCALE]) (MAP.SKETCHSPEC.INTO.VIEWER - [LAMBDA (SKETCH SKW) (* rrb "12-May-85 17:02") - - (* creates the local parts of a sketch and puts it onto the viewer.) - + [LAMBDA (SKETCH SKW) (* rrb "12-May-85 17:02") + (* creates the local parts of a sketch + and puts it onto the viewer.) (PROG ((SKREGION (WINDOWPROP SKW 'REGION.VIEWED)) SPECS) - - (* local specs are kept as a TCONC cell so that additions to the end are fast.) + + (* local specs are kept as a TCONC cell so that additions to the end are fast.) (RETURN (WINDOWPROP SKW 'SKETCHSPECS (CONS [SETQ SPECS (CONS (fetch (SKETCH SKETCHNAME) of SKETCH) @@ -1058,29 +1168,27 @@ This will be slow for arcs and curves."] (LAST SPECS]) (SKETCHW.REPAINTFN - [LAMBDA (W REG STOPIFMOUSEDOWN NEWGRIDFLG) (* rrb "21-Feb-86 10:38") + [LAMBDA (W REG STOPIFMOUSEDOWN NEWGRIDFLG) (* rrb "21-Feb-86 10:38") (* redisplays the sketch in a window) (* for now ignore the region.) - - (* if STOPIFMOUSEDOWN is T, it displays some but stops if the button left or - middle button is still down and returns STOPPED) + + (* if STOPIFMOUSEDOWN is T, it displays some but stops if the button left or + middle button is still down and returns STOPPED) (DSPOPERATION 'PAINT W) - (DSPRIGHTMARGIN 65000 W) - - (* I don't know exactly how scrolling ever gets turned on but it has.) - + (DSPRIGHTMARGIN 65000 W) (* I don't know exactly how scrolling + ever gets turned on but it has.) (DSPSCROLL 'OFF W) (PROG1 (SKETCHW.REPAINTFN1 W REG (AND STOPIFMOUSEDOWN (SETUPTIMER AUTOZOOM.REPAINT.TIME)) NEWGRIDFLG) (SKED.SELECTION.FEEDBACK W]) (SKETCHW.REPAINTFN1 - [LAMBDA (SKW REGION TIMER NEWGRIDFLG) (* rrb "11-Jul-86 15:51") - - (* Draws all of the local elements in the sketch window SKW. - internal function to SKETCHW.REPAINTFN This entry is provided so that - SK.DRAWFIGURE.IF can RETFROM it if the timer has expired and a button is down.) + [LAMBDA (SKW REGION TIMER NEWGRIDFLG) (* rrb "11-Jul-86 15:51") + + (* Draws all of the local elements in the sketch window SKW. + internal function to SKETCHW.REPAINTFN This entry is provided so that + SK.DRAWFIGURE.IF can RETFROM it if the timer has expired and a button is down.) (MAPSKETCHSPECS (LOCALSPECS.FROM.VIEWER SKW) (COND @@ -1094,25 +1202,25 @@ This will be slow for arcs and curves."] (SK.DISPLAY.GRID.POINTS SKW NEWGRIDFLG]) (SK.DRAWFIGURE.IF - [LAMBDA (SCREENELT STREAM REGION SCALE) (* rrb "22-Jan-85 11:34") - - (* draws an element of a sketch in a window. - If the free variable TIMER has expired and a button is down, it RETFROMs the - repainting function.) + [LAMBDA (SCREENELT STREAM REGION SCALE) (* rrb "22-Jan-85 11:34") + + (* draws an element of a sketch in a window. + If the free variable TIMER has expired and a button is down, it RETFROMs the + repainting function.) (PROG1 (SK.DRAWFIGURE SCREENELT STREAM REGION SCALE) - (AND TIMER (MOUSESTATE (OR LEFT MIDDLE)) - (TIMEREXPIRED? TIMER) - (RETFROM 'SKETCHW.REPAINTFN1 'STOPPED]) + (AND TIMER (MOUSESTATE (OR LEFT MIDDLE)) + (TIMEREXPIRED? TIMER) + (RETFROM 'SKETCHW.REPAINTFN1 'STOPPED)))]) (SKETCHW.SCROLLFN - [LAMBDA (SKW XDELTA YDELTA CONTINUOUSFLG) (* rrb "11-Jul-86 15:51") - - (* scroll function for a sketch window. It must check to see which elements - need to get added and deleted from the ones currently viewed as a result of the - scrolling. Also if an element gets added, the clipping region must be expanded - because part of the display of the object may be in the already visible part of - the window.) + [LAMBDA (SKW XDELTA YDELTA CONTINUOUSFLG) (* rrb "11-Jul-86 15:51") + + (* scroll function for a sketch window. It must check to see which elements need + to get added and deleted from the ones currently viewed as a result of the + scrolling. Also if an element gets added, the clipping region must be expanded + because part of the display of the object may be in the already visible part of + the window.) (PROG ([SKETCH (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH (SKETCH.FROM.VIEWER SKW] (NOWREG (DSPCLIPPINGREGION NIL SKW)) @@ -1148,22 +1256,20 @@ This will be slow for arcs and curves."] (fetch (REGION WIDTH) of NOWREG) (fetch (REGION HEIGHT) of NOWREG))) (SETQ SCALE (VIEWER.SCALE SKW] - - (* update the current image to contain the things that will be there after the - scroll, then scroll.) + + (* update the current image to contain the things that will be there after the + scroll, then scroll.) [for GELT in SKETCH do (SETQ INNEW? (SK.INSIDE.REGION GELT NEWREGION)) (COND [(SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART GELT SKW)) - - (* if it is not supposed to be in the new region, remove it.) - + (* if it is not supposed to be in the + new region, remove it.) (OR INNEW? (COND ((REGIONSINTERSECTP NEWLOCALREGION (SK.ITEM.REGION LOCALELT)) - - (* part of image may overlap the part of sketch that is still showing) - + (* part of image may overlap the part + of sketch that is still showing) (SK.ERASE.AND.DELETE.ITEM LOCALELT SKW)) (T (SK.DELETE.ITEM LOCALELT SKW] (INNEW? (* just came in) @@ -1174,11 +1280,11 @@ This will be slow for arcs and curves."] (for GELT in NEWONES do (SKETCH.ADD.AND.DISPLAY1 GELT SKW SCALE]) (SKETCHW.RESHAPEFN - [LAMBDA (SKW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* rrb "11-Jul-86 15:51") - - (* reshape function for a sketch window. - It must check to see which elements need to get added and deleted from the ones - currently viewed as a result of the reshaping.) + [LAMBDA (SKW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* rrb "11-Jul-86 15:51") + + (* reshape function for a sketch window. It must check to see which elements need + to get added and deleted from the ones currently viewed as a result of the + reshaping.) (PROG ([SKETCH (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH (SKETCH.FROM.VIEWER SKW] (NOWREG (DSPCLIPPINGREGION NIL SKW)) @@ -1188,22 +1294,20 @@ This will be slow for arcs and curves."] (RESHAPEBYREPAINTFN SKW OLDIMAGE IMAGEREGION OLDSCREENREGION) [SETQ NEWREGION (UNSCALE.REGION (SETQ NEWLOCALREGION (DSPCLIPPINGREGION NIL SKW)) (SETQ SCALE (VIEWER.SCALE SKW] - - (* update the current image to contain the things that will be there after the - scroll, then scroll.) + + (* update the current image to contain the things that will be there after the + scroll, then scroll.) [for GELT in SKETCH do (SETQ INNEW? (SK.INSIDE.REGION GELT NEWREGION)) (COND [(SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART GELT SKW)) - - (* if it is not supposed to be in the new region, remove it.) - + (* if it is not supposed to be in the + new region, remove it.) (OR INNEW? (COND ((REGIONSINTERSECTP NEWLOCALREGION (SK.ITEM.REGION LOCALELT)) - - (* part of image may overlap the part of sketch that is still showing) - + (* part of image may overlap the part + of sketch that is still showing) (SK.ERASE.AND.DELETE.ITEM LOCALELT SKW)) (T (SK.DELETE.ITEM LOCALELT SKW] (INNEW? (* just came in) @@ -1213,11 +1317,11 @@ This will be slow for arcs and curves."] (for GELT in NEWONES do (SKETCH.ADD.AND.DISPLAY1 GELT SKW SCALE]) (SK.UPDATE.EVENT.SELECTION - [LAMBDA (HOTSPOTCACHE X1 Y1 X2 Y2 SCALE WINDOW COPYMODE DELETEMODE) + [LAMBDA (HOTSPOTCACHE X1 Y1 X2 Y2 SCALE WINDOW COPYMODE DELETEMODE) (* rrb "31-Jan-85 11:35") - - (* * internal function to SK.COPY.BUTTONEVENTFN that determines the elements - within the given bounds and selects or deselects them.) + + (* * internal function to SK.COPY.BUTTONEVENTFN that determines the elements + within the given bounds and selects or deselects them.) (PROG (SELITEMS) (RETURN (COND @@ -1243,12 +1347,12 @@ This will be slow for arcs and curves."] DELETEMODE]) (LIGHTGRAYWINDOW - [LAMBDA (WINDOW) (* rrb "28-Jun-84 10:27") + [LAMBDA (WINDOW) (* rrb "28-Jun-84 10:27") (DSPFILL NIL 1 'INVERT WINDOW) WINDOW]) (SK.ADD.SPACES - [LAMBDA (STRLST) (* rrb "19-Jul-85 15:11") + [LAMBDA (STRLST) (* rrb "19-Jul-85 15:11") (* adds eols between the elements of  STRLST) (for STR in STRLST join (COND @@ -1262,15 +1366,15 @@ This will be slow for arcs and curves."] "]) (SK.SKETCH.MENU - [LAMBDA (SKW) (* rrb "12-Sep-85 11:50") + [LAMBDA (SKW) (* rrb "12-Sep-85 11:50") (* brings up the normal sketch command  menu.) (SK.MIDDLE.TITLEFN SKW T]) (SK.CHECK.IMAGEOBJ.WHENDELETEDFN - [LAMBDA (GELT SKETCHW) (* rrb "19-Oct-85 17:10") - - (* check to see if a when deleted function needs to be applied and applies it.) + [LAMBDA (GELT SKETCHW) (* rrb "19-Oct-85 17:10") + + (* check to see if a when deleted function needs to be applied and applies it.) (SELECTQ (fetch (GLOBALPART GTYPE) of GELT) (SKIMAGEOBJ (* deleting an image object apply @@ -1282,7 +1386,7 @@ This will be slow for arcs and curves."] NIL]) (SK.APPLY.IMAGEOBJ.WHENDELETEDFN - [LAMBDA (GELT SKETCHW) (* rrb "30-Jul-85 15:35") + [LAMBDA (GELT SKETCHW) (* rrb "30-Jul-85 15:35") (* applies the when deleted function  for an image object.) (PROG (IMAGEOBJ FN) @@ -1292,21 +1396,20 @@ This will be slow for arcs and curves."] INDIVIDUALGLOBALPART) of GELT))) 'WHENDELETEDFN)) - (NEQ FN 'NILL)) - - (* documentation calls for passing text streams as well but there aren't any.) - + (NEQ FN 'NILL)) (* documentation calls for passing + text streams as well but there aren't + any.) (APPLY* FN IMAGEOBJ SKETCHW]) (SK.RETURN.TTY - [LAMBDA (W) (* rrb "29-Aug-85 11:09") + [LAMBDA (W) (* rrb "29-Aug-85 11:09") (* gives up the tty when the window is  shrunken.) (AND (TTY.PROCESSP (WINDOWPROP W 'PROCESS)) (TTY.PROCESS T]) (SK.TAKE.TTY - [LAMBDA (W) (* rrb "29-Aug-85 11:10") + [LAMBDA (W) (* rrb "29-Aug-85 11:10") (* takes the tty when the window is  expanded) (TTY.PROCESS (WINDOWPROP W 'PROCESS]) @@ -1322,11 +1425,11 @@ This will be slow for arcs and curves."] [LAMBDA (ITEMS TITLE) (* ; "Edited 6-Nov-2025 22:36 by rmk") (* rrb "14-Jul-86 13:43") (create MENU - ITEMS _ ITEMS - CENTERFLG _ T - WHENSELECTEDFN _ (FUNCTION SKETCHW.SELECTIONFN) - MENUFONT _ (FONTCREATE BOLDFONT) - TITLE _ TITLE]) + ITEMS ↠ITEMS + CENTERFLG ↠T + WHENSELECTEDFN ↠(FUNCTION SKETCHW.SELECTIONFN) + MENUFONT ↠(FONTCREATE BOLDFONT) + TITLE ↠TITLE]) (SKETCH.COMMANDMENU.ITEMS [LAMBDA (ADDFIXITEM ELEMENTTYPES VIEWER) (* rrb "24-Sep-86 18:11") @@ -1587,34 +1690,35 @@ This will be slow for arcs and curves."] '((inspect INSPECT.SKETCH "Calls the Inspector on the figure data structures."]) (CREATE.SKETCHW.COMMANDMENU - [LAMBDA (MENUTITLE ADDFIXITEM ELEMENTTYPES VIEWER) (* rrb " 6-May-86 15:22") + [LAMBDA (MENUTITLE ADDFIXITEM ELEMENTTYPES VIEWER) (* rrb " 6-May-86 15:22") (* returns the control menu for a  figure window.) (SKETCH.COMMANDMENU (SKETCH.COMMANDMENU.ITEMS ADDFIXITEM ELEMENTTYPES VIEWER) MENUTITLE]) (SKETCHW.SELECTIONFN - [LAMBDA (ITEM MENU) (* rrb "31-Jan-86 11:34") - - (* calls the function appropriate for the item selected from the command menu - associated with a figure window.) + [LAMBDA (ITEM MENU) (* rrb "31-Jan-86 11:34") + + (* calls the function appropriate for the item selected from the command menu + associated with a figure window.) (PROG [(SKW (WINDOWPROP (WFROMMENU MENU) 'MAINWINDOW] - (RETURN (RESETLST (COND - ((OBTAIN.MONITORLOCK (SKETCH.MONITORLOCK SKW) - T T) (* clear the prompt window if there is + (RETURN (RESETLST + (COND + ((OBTAIN.MONITORLOCK (SKETCH.MONITORLOCK SKW) + T T) (* clear the prompt window if there is  one.) - (CLOSEPROMPTWINDOW SKW) (* reset the line being drawn if there + (CLOSEPROMPTWINDOW SKW) (* reset the line being drawn if there  is one.) - (RESET.LINE.BEING.INPUT SKW) - (SK.APPLY.MENU.COMMAND (CADR ITEM) - SKW)) - (T (STATUSPRINT SKW " -" "Sketch operation in progress. Please wait."]) + (RESET.LINE.BEING.INPUT SKW) + (SK.APPLY.MENU.COMMAND (CADR ITEM) + SKW)) + (T (STATUSPRINT SKW " +" "Sketch operation in progress. Please wait."))))]) (SKETCH.MONITORLOCK - [LAMBDA (VIEWER) (* rrb "31-Jan-86 10:20") + [LAMBDA (VIEWER) (* rrb "31-Jan-86 10:20") (* returns the monitorlock for a  sketch) (OR (WINDOWPROP VIEWER 'MONITORLOCK) @@ -1623,10 +1727,9 @@ This will be slow for arcs and curves."] (RETURN LOCK]) (SK.EVAL.AS.PROCESS - [LAMBDA (FORM VIEWER) (* rrb "31-Jan-86 11:23") - - (* evals a form that grabs the sketch lock on its viewer in a process.) - + [LAMBDA (FORM VIEWER) (* rrb "31-Jan-86 11:23") + (* evals a form that grabs the sketch + lock on its viewer in a process.) (COND ((THIS.PROCESS) (ADD.PROCESS (LIST 'SK.EVAL.WITH.LOCK (KWOTE FORM) @@ -1638,20 +1741,18 @@ This will be slow for arcs and curves."] (\EVAL FORM]) (SK.EVAL.WITH.LOCK - [LAMBDA (FORM VIEWER) (* rrb "31-Jan-86 11:22") - - (* evals FORM in a context where it has the lock on VIEWER) - + [LAMBDA (FORM VIEWER) (* rrb "31-Jan-86 11:22") + (* evals FORM in a context where it + has the lock on VIEWER) (WITH.MONITOR (SKETCH.MONITORLOCK VIEWER) (EVAL FORM]) ) (DEFINEQ (SK.FIX.MENU - [LAMBDA (SKETCHW DONTOPENFLG) (* rrb "23-Sep-86 17:59") - - (* attaches the menu on the right side of the viewer.) - + [LAMBDA (SKETCHW DONTOPENFLG) (* rrb "23-Sep-86 17:59") + (* attaches the menu on the right side + of the viewer.) (PROG (MENUW) (OR (SETQ MENUW (SK.INSURE.HAS.MENU SKETCHW)) (RETURN)) (* clear the popup menu cache.) @@ -1669,20 +1770,18 @@ This will be slow for arcs and curves."] (OR DONTOPENFLG (OPENW MENUW]) (SK.SET.UP.MENUS - [LAMBDA (SKETCHW DONTOPENFLG MENUSPEC) (* rrb "23-Sep-86 17:59") + [LAMBDA (SKETCHW DONTOPENFLG MENUSPEC) (* rrb "23-Sep-86 17:59") (* attached the sketch menu to the  window.) (PROG (FIXEDMENUW POPUPMENUW FIXIT?) (COND - ((NULL MENUSPEC) - - (* mark window so both menus will come up if needed.) - + ((NULL MENUSPEC) (* mark window so both menus will come + up if needed.) (SETQ FIXEDMENUW (SETQ POPUPMENUW T))) ((type? MENU MENUSPEC) - - (* put the given menu as the fixed one and establish the standard one as the - SKETCHPOPUPMENU) + + (* put the given menu as the fixed one and establish the standard one as the + SKETCHPOPUPMENU) (SETQ FIXEDMENUW (MENUWINDOW MENUSPEC T)) (SETQ POPUPMENUW T) @@ -1714,21 +1813,19 @@ This will be slow for arcs and curves."] (AND FIXIT? (SK.FIX.MENU SKETCHW DONTOPENFLG]) (SK.INSURE.HAS.MENU - [LAMBDA (SKETCHW) (* rrb "23-Sep-86 17:59") + [LAMBDA (SKETCHW) (* rrb "23-Sep-86 17:59") (* makes sure a sketch window has a  menu.) (PROG [(FIXEDMENU (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU] [COND ((EQ (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU) - T) - - (* no fixed menu yet but wants standard one, create it) - + T) (* no fixed menu yet but wants + standard one, create it) (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU (SETQ FIXEDMENU (SK.CREATE.STANDARD.MENU SKETCHW] (RETURN FIXEDMENU]) (SK.CREATE.STANDARD.MENU - [LAMBDA (VIEWER) (* rrb "23-Sep-86 17:52") + [LAMBDA (VIEWER) (* rrb "23-Sep-86 17:52") (* creates the standard sketch viewer  fixed menu window.) (RESETFORM (CURSOR WAITINGCURSOR) @@ -1736,49 +1833,44 @@ This will be slow for arcs and curves."] T]) (SK.ADD.ITEM.TO.MENU - [LAMBDA (OLDMENU NEWITEM) (* rrb "23-Sep-86 09:53") - - (* returns a menu that is like OLDMENU but has one additional item NEWITEM) - - (* clober enough fields to get the menu to redraw itself correctly.) - - (create MENU using OLDMENU ITEMS _ (APPEND (fetch (MENU ITEMS) of OLDMENU) + [LAMBDA (OLDMENU NEWITEM) (* rrb "23-Sep-86 09:53") + (* returns a menu that is like OLDMENU + but has one additional item NEWITEM) + (* clober enough fields to get the + menu to redraw itself correctly.) + (create MENU using OLDMENU ITEMS ↠(APPEND (fetch (MENU ITEMS) of OLDMENU) (LIST NEWITEM)) - MENUCOLUMNS _ NIL MENUROWS _ NIL IMAGE _ NIL MENUGRID _ + MENUCOLUMNS ↠NIL MENUROWS ↠NIL IMAGE ↠NIL MENUGRID ↠(create REGION - LEFT _ 0 - BOTTOM _ 0]) + LEFT ↠0 + BOTTOM ↠0]) (SK.GET.VIEWER.POPUP.MENU - [LAMBDA (SKETCHW) (* rrb "24-Sep-86 10:31") - - (* gets the popup menu for a viewer. If the sketch menu is open, it creates a - standard one. If the sketch menu isn't open, it adds the fix menu item to it - and pops it up. It is cleared each time the menu is fixed.) + [LAMBDA (SKETCHW) (* rrb "24-Sep-86 10:31") + + (* gets the popup menu for a viewer. If the sketch menu is open, it creates a + standard one. If the sketch menu isn't open, it adds the fix menu item to it and + pops it up. It is cleared each time the menu is fixed.) (OR (WINDOWPROP SKETCHW 'SKETCHPOPUPMENUCACHE) (PROG [(SKETCHMENU (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU] [COND [(OR (NULL SKETCHMENU) (OPENWP SKETCHMENU)) - - (* window doesn't want a fixed menu or its fixed menu is already open, check - for a popup one) + + (* window doesn't want a fixed menu or its fixed menu is already open, check for + a popup one) (COND ((EQ (SETQ SKETCHMENU (WINDOWPROP SKETCHW 'SKETCHPOPUPMENU)) T) (WINDOWPROP SKETCHW 'SKETCHPOPUPMENU (SETQ SKETCHMENU (SK.CREATE.STANDARD.MENU SKETCHW] - (T - - (* use the fixed menu with an item added to fix the menu.) - + (T (* use the fixed menu with an item + added to fix the menu.) [COND - ((EQ SKETCHMENU T) - - (* no fixed menu yet but wants standard one, create it) - + ((EQ SKETCHMENU T) (* no fixed menu yet but wants + standard one, create it) (WINDOWPROP SKETCHW 'SKETCHFIXEDMENU (SETQ SKETCHMENU (  SK.CREATE.STANDARD.MENU SKETCHW] @@ -1792,10 +1884,10 @@ This will be slow for arcs and curves."] (RETURN SKETCHMENU]) (SK.CLEAR.POPUP.MENU - [LAMBDA (MENUW) (* rrb "24-Sep-86 10:34") - - (* clears the cache of pop up window so that the fixed menu will be used if the - user middle buttons.) + [LAMBDA (MENUW) (* rrb "24-Sep-86 10:34") + + (* clears the cache of pop up window so that the fixed menu will be used if the + user middle buttons.) (PROG NIL (WINDOWPROP (OR (MAINWINDOW MENUW) @@ -1810,9 +1902,9 @@ This will be slow for arcs and curves."] (DEFINEQ (SKETCH.CREATE - [LAMBDA ARGS (* rrb " 6-Nov-85 11:16") + [LAMBDA ARGS (* rrb " 6-Nov-85 11:16") (PROG [(SKETCH (create SKETCH - SKETCHNAME _ (AND (GREATERP ARGS 0) + SKETCHNAME ↠(AND (GREATERP ARGS 0) (ARG ARGS 1] (PUTSKETCHPROP SKETCH 'SKETCHCONTEXT (CREATE.DEFAULT.SKETCH.CONTEXT)) (PUTSKETCHPROP SKETCH 'VERSION SKETCH.VERSION) (* pick out the props that are @@ -1824,7 +1916,7 @@ This will be slow for arcs and curves."] (RETURN SKETCH]) (GETSKETCHPROP - [LAMBDA (SKETCH PROPERTY) (* rrb " 3-Mar-86 14:37") + [LAMBDA (SKETCH PROPERTY) (* rrb " 3-Mar-86 14:37") (* retrieves the property of a sketch) (PROG ((SKETCH (INSURE.SKETCH SKETCH)) SKETCHCONTEXT) @@ -1862,11 +1954,11 @@ This will be slow for arcs and curves."] PROPERTY]) (PUTSKETCHPROP - [LAMBDA (SKETCH PROPERTY VALUE) (* rrb " 3-Mar-86 13:58") - - (* stores a property on a sketch Returns VALUE. - Knows about the form of a sketch and does value checking - (or should.)) + [LAMBDA (SKETCH PROPERTY VALUE) (* rrb " 3-Mar-86 13:58") + + (* stores a property on a sketch Returns VALUE. + Knows about the form of a sketch and does value checking + (or should.)) (PROG ((SKETCH (INSURE.SKETCH SKETCH)) SKETCHCONTEXT PLIST) @@ -1877,13 +1969,13 @@ This will be slow for arcs and curves."] (BRUSH (replace (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT with VALUE)) (SHAPE (replace (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT) - BRUSHSHAPE _ VALUE))) + BRUSHSHAPE ↠VALUE))) (SIZE (replace (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT) - BRUSHSIZE _ VALUE))) + BRUSHSIZE ↠VALUE))) (COLOR (replace (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT with (create BRUSH using (fetch (SKETCHCONTEXT SKETCHBRUSH) of SKETCHCONTEXT) - BRUSHCOLOR _ VALUE))) + BRUSHCOLOR ↠VALUE))) (FONT (replace (SKETCHCONTEXT SKETCHFONT) of SKETCHCONTEXT with VALUE)) (TEXTALIGNMENT (replace (SKETCHCONTEXT SKETCHTEXTALIGNMENT) of SKETCHCONTEXT with VALUE)) @@ -1896,13 +1988,13 @@ This will be slow for arcs and curves."] (TEXTURE (replace (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT with (create SKFILLING using (fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT) - FILLING.TEXTURE _ VALUE))) + FILLING.TEXTURE ↠VALUE))) ((BACKCOLOR FILLINGCOLOR) (replace (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT with (create SKFILLING using (fetch (SKETCHCONTEXT SKETCHFILLING) of SKETCHCONTEXT ) - FILLING.COLOR _ VALUE))) + FILLING.COLOR ↠VALUE))) (LINEMODE (replace (SKETCHCONTEXT SKETCHLINEMODE) of SKETCHCONTEXT with VALUE)) (ARCDIRECTION (replace (SKETCHCONTEXT SKETCHARCDIRECTION) of SKETCHCONTEXT with VALUE)) (MOVEMODE (replace (SKETCHCONTEXT SKETCHMOVEMODE) of SKETCHCONTEXT with VALUE)) @@ -1914,23 +2006,23 @@ This will be slow for arcs and curves."] (RETURN VALUE]) (CREATE.DEFAULT.SKETCH.CONTEXT - [LAMBDA NIL (* rrb "23-Sep-86 10:40") + [LAMBDA NIL (* rrb "23-Sep-86 10:40") (* returns a default sketch context) (create SKETCHCONTEXT - SKETCHBRUSH _ SK.DEFAULT.BRUSH - SKETCHFONT _ [OR SK.DEFAULT.FONT (SK.FONT.LIST (DEFAULTFONT 'DISPLAY] - SKETCHTEXTALIGNMENT _ SK.DEFAULT.TEXT.ALIGNMENT - SKETCHARROWHEAD _ (create ARROWHEAD - ARROWTYPE _ SK.DEFAULT.ARROW.TYPE - ARROWANGLE _ SK.DEFAULT.ARROW.ANGLE - ARROWLENGTH _ SK.DEFAULT.ARROW.LENGTH) - SKETCHDASHING _ SK.DEFAULT.DASHING - SKETCHUSEARROWHEAD _ NIL - SKETCHTEXTBOXALIGNMENT _ SK.DEFAULT.TEXTBOX.ALIGNMENT - SKETCHFILLING _ (SK.CREATE.DEFAULT.FILLING) - SKETCHLINEMODE _ T - SKETCHINPUTSCALE _ 1 - SKETCHDRAWINGMODE _ SK.DEFAULT.OPERATION]) + SKETCHBRUSH ↠SK.DEFAULT.BRUSH + SKETCHFONT ↠[OR SK.DEFAULT.FONT (SK.FONT.LIST (DEFAULTFONT 'DISPLAY] + SKETCHTEXTALIGNMENT ↠SK.DEFAULT.TEXT.ALIGNMENT + SKETCHARROWHEAD ↠(create ARROWHEAD + ARROWTYPE ↠SK.DEFAULT.ARROW.TYPE + ARROWANGLE ↠SK.DEFAULT.ARROW.ANGLE + ARROWLENGTH ↠SK.DEFAULT.ARROW.LENGTH) + SKETCHDASHING ↠SK.DEFAULT.DASHING + SKETCHUSEARROWHEAD ↠NIL + SKETCHTEXTBOXALIGNMENT ↠SK.DEFAULT.TEXTBOX.ALIGNMENT + SKETCHFILLING ↠(SK.CREATE.DEFAULT.FILLING) + SKETCHLINEMODE ↠T + SKETCHINPUTSCALE ↠1 + SKETCHDRAWINGMODE ↠SK.DEFAULT.OPERATION]) ) (PUTPROPS SKETCH.CREATE ARGNAMES (NIL (NAME . DEFAULTS&VALUES) . U)) @@ -1942,15 +2034,15 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.COPY.BUTTONEVENTFN - [LAMBDA (WINDOW) (* rrb "11-Jul-86 15:51") - - (* * handles the button event when a copy key and/or the delete is held down. - allows the user to select a group of the sketch elements from the sketch - WINDOW. This is very similar to SK.SELECT.MULTIPLE.ITEMS) - - (* the selection protocol is left to add, right to delete. - Multiple clicking in the same place upscales for both select and deselect. - Sweeping will select or deselect all of the items in the swept out area.) + [LAMBDA (WINDOW) (* rrb "11-Jul-86 15:51") + + (* * handles the button event when a copy key and/or the delete is held down. + allows the user to select a group of the sketch elements from the sketch WINDOW. + This is very similar to SK.SELECT.MULTIPLE.ITEMS) + + (* the selection protocol is left to add, right to delete. + Multiple clicking in the same place upscales for both select and deselect. + Sweeping will select or deselect all of the items in the swept out area.) (COND ([AND (TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS)) @@ -1980,10 +2072,8 @@ This will be slow for arcs and curves."] (T 'COPYSELECT] (DELETEMODE 'DELETE) (T (* keys aren't still down.) - (RETURN] - - (* create the cache for the elements that allow the current operation.) - + (RETURN] (* create the cache for the elements + that allow the current operation.) (SETQ HOTSPOTCACHE (SK.HOTSPOT.CACHE.FOR.OPERATION WINDOW OPERATION)) (COND ((NOT (SK.HAS.SOME.HOTSPOTS HOTSPOTCACHE)) (* no items don't do anything.) @@ -2003,39 +2093,33 @@ This will be slow for arcs and curves."] ((AND (LASTMOUSESTATE UP) (SK.BUTTONEVENT.OVERP COPYMODE DELETEMODE)) (SK.TAKE.MARKS.DOWN WINDOW HOTSPOTCACHE) - (RETURN))) - - (* MIDDLEONLYFLG is used to note case of picking characters out of a sketch.) - + (RETURN))) (* MIDDLEONLYFLG is used to note case + of picking characters out of a sketch.) (SETQ MIDDLEONLYFLG (LASTMOUSESTATE (ONLY MIDDLE))) SELECTLP (GETMOUSESTATE) (COND - ((SK.BUTTONEVENT.OVERP COPYMODE DELETEMODE) - - (* user let up copy key. Put sketch into input buffer.) - + ((SK.BUTTONEVENT.OVERP COPYMODE DELETEMODE) (* user let up copy key. + Put sketch into input buffer.) (SETQ RETURNVAL (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (GO EXIT)) ([AND (LASTMOUSESTATE (NOT UP)) (OR (NOT (INSIDEP (WINDOWPROP WINDOW 'REGION) LASTMOUSEX LASTMOUSEY)) (NOT (SK.BUTTONEVENT.SAME.KEYS COPYMODE DELETEMODE] - - (* if a button is down, and either the keystate is different from entry or the - cursor is out of the window, stop this event.) + + (* if a button is down, and either the keystate is different from entry or the + cursor is out of the window, stop this event.) (SETQ RETURNVAL NIL) - (GO EXIT))) - - (* cursor is still inside or buttons are up, leave sketch selected.) - + (GO EXIT))) (* cursor is still inside or buttons + are up, leave sketch selected.) (SETQ NEWY (LASTMOUSEY WINDOW)) (SETQ NEWX (LASTMOUSEX WINDOW)) (COND ((NEQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) - - (* a button has gone up or down, mark this as the origin of a new box to sweep.) + + (* a button has gone up or down, mark this as the origin of a new box to sweep.) (SETQ ORIGX NEWX) (SETQ ORIGY NEWY) @@ -2053,10 +2137,9 @@ This will be slow for arcs and curves."] (for SELITEM in (LOCALSPECS.FROM.VIEWER WINDOW) do (SK.ADD.SELECTION SELITEM WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE] - (T - - (* thing selected is a the whole sketch, clear everything and start over.) - + (T (* thing selected is a the whole + sketch, clear everything and start + over.) (for SELITEM in (LOCALSPECS.FROM.VIEWER WINDOW) do (SK.REMOVE.SELECTION SELITEM WINDOW (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE))) @@ -2065,16 +2148,16 @@ This will be slow for arcs and curves."] (SETQ PREVMOUSEBUTTONS) (GO STARTOVERLP] [(LASTMOUSESTATE (NOT UP)) - - (* add or delete the element if any that the point is in. - This uses a different method which takes into account the size of the selection - knots which the area sweep doesn't.) + + (* add or delete the element if any that the point is in. + This uses a different method which takes into account the size of the selection + knots which the area sweep doesn't.) (COND ((SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE (create POSITION - XCOORD _ NEWX - YCOORD _ NEWY))) + XCOORD ↠NEWX + YCOORD ↠NEWY))) (COND ([OR (AND (LASTMOUSESTATE (ONLY LEFT)) (NOT (SETQ MIDDLEONLYFLG))) @@ -2093,17 +2176,13 @@ This will be slow for arcs and curves."] ((OR (IGREATERP (IABS (IDIFFERENCE ORIGX NEWX)) SK.NO.MOVE.DISTANCE) (IGREATERP (IABS (IDIFFERENCE ORIGY NEWY)) - SK.NO.MOVE.DISTANCE)) - - (* make the first pick move further so that it is easier to multiple click.) - - (SETQ MOVEDMUCHFLG T))) - - (* cursor has moved more than the minimum amount since last noticed.) - - (* add or delete any with in the swept out area.) - - (SK.UPDATE.EVENT.SELECTION HOTSPOTCACHE ORIGX ORIGY NEWX NEWY SCALE WINDOW COPYMODE + SK.NO.MOVE.DISTANCE)) (* make the first pick move further so + that it is easier to multiple click.) + (SETQ MOVEDMUCHFLG T))) (* cursor has moved more than the + minimum amount since last noticed.) + (* add or delete any with in the swept + out area.) + (SK.UPDATE.EVENT.SELECTION HOTSPOTCACHE ORIGX ORIGY NEWX NEWY SCALE WINDOW COPYMODE DELETEMODE))) (SETQ OLDX NEWX) (SETQ OLDY NEWY) @@ -2115,11 +2194,9 @@ This will be slow for arcs and curves."] (SK.BUTTONEVENT.MARK COPYMODE DELETEMODE))) (SK.TAKE.MARKS.DOWN WINDOW HOTSPOTCACHE) - (CLOSEPROMPTWINDOW WINDOW) - - (* if middle was the only button used to select, return only the text - characters.) - + (CLOSEPROMPTWINDOW WINDOW) (* if middle was the only button used + to select, return only the text + characters.) (RETURN (AND RETURNVAL (COND [(TTY.PROCESSP (WINDOWPROP WINDOW 'PROCESS)) (* the results will be going to this @@ -2133,7 +2210,7 @@ This will be slow for arcs and curves."] (MIDDLEONLYFLG (* if middle only, just get the  characters.) - (COPYINSERT (SK.BUILD.IMAGEOBJ RETURNVAL + (COPYINSERT (SK.BUILD.IMAGEOBJ RETURNVAL WINDOW T))) (T (SK.COPY.ELEMENTS RETURNVAL WINDOW] (DELETEMODE (* delete them) @@ -2142,10 +2219,9 @@ This will be slow for arcs and curves."] MIDDLEONLYFLG]) (SK.BUTTONEVENT.MARK - [LAMBDA (COPYFLG DELETEFLG) (* rrb "29-Dec-84 19:02") - - (* returns the mark that should be put on the points when they are selected.) - + [LAMBDA (COPYFLG DELETEFLG) (* rrb "29-Dec-84 19:02") + (* returns the mark that should be put + on the points when they are selected.) (COND (DELETEFLG (COND (COPYFLG MOVESELECTIONMARK) @@ -2153,60 +2229,53 @@ This will be slow for arcs and curves."] (T COPYSELECTIONMARK]) (SK.BUILD.IMAGEOBJ - [LAMBDA (SCRELTS SKW CHARSONLYFLG) (* ; "Edited 20-Jun-92 15:28 by rmk:") - (* builds an imageobj from the list - of screen elements.) + [LAMBDA (SCRELTS SKW CHARSONLYFLG) (* ; "Edited 20-Jun-92 15:28 by rmk:") + (* builds an imageobj from the list of + screen elements.) (COND [CHARSONLYFLG (* return only the text characters.) (PROG ((TEXTELTS (bind GELT for LOCALSKELT in SCRELTS - join (SELECTQ (fetch (GLOBALPART GTYPE) of (SETQ GELT - (fetch (SCREENELT - GLOBALPART) - of LOCALSKELT))) - (TEXT (LIST (LIST (fetch (TEXT LOCATIONLATLON) - of (SETQ GELT (fetch (GLOBALPART + join (SELECTQ (fetch (GLOBALPART GTYPE) of (SETQ GELT (fetch (SCREENELT GLOBALPART + ) of + LOCALSKELT + ))) + (TEXT (LIST (LIST (fetch (TEXT LOCATIONLATLON) + of (SETQ GELT (fetch (GLOBALPART + INDIVIDUALGLOBALPART) + of GELT))) + GELT))) + (TEXTBOX (LIST (LIST (SK.TEXTBOX.TEXT.POSITION (SETQ GELT + (fetch (GLOBALPART INDIVIDUALGLOBALPART - ) - of GELT))) - GELT))) - (TEXTBOX (LIST (LIST (SK.TEXTBOX.TEXT.POSITION (SETQ GELT - (fetch - (GLOBALPART - INDIVIDUALGLOBALPART - ) - of GELT))) - GELT))) - (SKIMAGEOBJ (* grab the imageobj too.) - (LIST (LIST (create - POSITION - XCOORD _ [fetch (REGION LEFT) - of - (fetch (SKIMAGEOBJ - SKIMOBJ.GLOBALREGION - ) - of (SETQ GELT - (fetch - (GLOBALPART - INDIVIDUALGLOBALPART - ) - of GELT] - YCOORD _ (fetch (REGION BOTTOM) - of (fetch (SKIMAGEOBJ - - SKIMOBJ.GLOBALREGION - ) + ) of GELT))) - GELT))) - NIL))) + GELT))) + (SKIMAGEOBJ (* grab the imageobj too.) + (LIST (LIST (create POSITION + XCOORD ↠+ [fetch (REGION LEFT) + of (fetch (SKIMAGEOBJ + SKIMOBJ.GLOBALREGION) + of (SETQ GELT (fetch (GLOBALPART + + INDIVIDUALGLOBALPART + ) + of GELT] + YCOORD ↠(fetch (REGION BOTTOM) + of (fetch (SKIMAGEOBJ + SKIMOBJ.GLOBALREGION + ) + of GELT))) + GELT))) + NIL))) CHARSLST) (* sort according to top from the - left.) + left.) [SORT TEXTELTS (FUNCTION (LAMBDA (A B) (COND - [(GREATERP (fetch (POSITION YCOORD) - of (SETQ A (CAR A))) - (fetch (POSITION YCOORD) - of (SETQ B (CAR B] + [(GREATERP (fetch (POSITION YCOORD) of (SETQ A + (CAR A))) + (fetch (POSITION YCOORD) of (SETQ B (CAR B] ((EQUAL (fetch (POSITION YCOORD) of A) (fetch (POSITION YCOORD) of B)) (LESSP (fetch (POSITION XCOORD) of A) @@ -2214,78 +2283,68 @@ This will be slow for arcs and curves."] (RETURN (COND ((EQUAL [CAR (LAST (SETQ CHARSLST (for TEXTELT in TEXTELTS - join (* collect relevant parts.) - (COND - [(EQ 'SKIMAGEOBJ (fetch ( - INDIVIDUALGLOBALPART - GTYPE) - of (CADR TEXTELT))) + join (* collect relevant parts.) + (COND + [(EQ 'SKIMAGEOBJ (fetch (INDIVIDUALGLOBALPART + GTYPE) + of (CADR TEXTELT))) (* copy image object so that copyfn is called. - This also copies the part of the image object that are sketch relevent - unnecessarily but it keeps copyfn call in one place.) + This also copies the part of the image object that are sketch relevent + unnecessarily but it keeps copyfn call in one place.) - (LIST (COPY.IMAGE.OBJECT - (fetch (SKIMAGEOBJ SKIMAGEOBJ) - of (CADR TEXTELT] - (T (SK.ADD.SPACES (fetch - (TEXT + (LIST (COPY.IMAGE.OBJECT (fetch (SKIMAGEOBJ + SKIMAGEOBJ) + of (CADR TEXTELT + ] + (T (SK.ADD.SPACES (fetch (TEXT LISTOFCHARACTERS - ) - of (CADR - TEXTELT - ] + ) + of (CADR TEXTELT] " -") (* strip off the trailing EOL that - was added.) +") (* strip off the trailing EOL that was + added.) (BUTLAST CHARSLST)) (T CHARSLST] [(AND (NOT (CDR SCRELTS)) - (EQ (fetch (GLOBALPART GTYPE) of (fetch (SCREENELT GLOBALPART) - of (CAR SCRELTS))) + (EQ (fetch (GLOBALPART GTYPE) of (fetch (SCREENELT GLOBALPART) of (CAR SCRELTS))) 'SKIMAGEOBJ)) (* ;; "RMK: singelton imageobject. Return an unencapsulated copy of it. Don't need to worry about sketch transformations that might have applied, since they don't affect imageobjects.") - (COPY.IMAGE.OBJECT (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (FETCH (GLOBALPART - INDIVIDUALGLOBALPART - ) - OF (fetch - (SCREENELT GLOBALPART - ) - of (CAR SCRELTS - ] + (COPY.IMAGE.OBJECT (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (FETCH (GLOBALPART INDIVIDUALGLOBALPART) + OF (fetch (SCREENELT GLOBALPART) + of (CAR SCRELTS] (T - (* return a sketch image object. The sketch is translated to bring its lower - left coordinate to 0,0 so that when it is put in a document it is in a - canonical place. Maybe don't need to do this anymore.) + (* return a sketch image object. The sketch is translated to bring its lower left + coordinate to 0,0 so that when it is put in a document it is in a canonical + place. Maybe don't need to do this anymore.) (SKETCH.IMAGEOBJ [create SKETCH using (INSURE.SKETCH SKW) - SKETCHNAME _ NIL SKETCHELTS _ + SKETCHNAME ↠NIL SKETCHELTS ↠(SK.SORT.GELTS.BY.PRIORITY (bind GELT for LOCALSKELT in SCRELTS collect (COND - ((EQ (fetch (GLOBALPART GTYPE) - of (SETQ GELT (fetch - (SCREENELT - GLOBALPART) - of LOCALSKELT - ))) - 'SKIMAGEOBJ) + ((EQ (fetch (GLOBALPART GTYPE) + of (SETQ GELT (fetch (SCREENELT GLOBALPART + ) of + LOCALSKELT + ))) + 'SKIMAGEOBJ) (* apply copy fn) - (SK.COPY.IMAGEOBJ GELT)) - (T (COPY GELT] + (SK.COPY.IMAGEOBJ GELT)) + (T (COPY GELT] (SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS SCRELTS (VIEWER.SCALE SKW)) (VIEWER.SCALE SKW) (SK.GRIDFACTOR SKW]) (SK.BUTTONEVENT.OVERP - [LAMBDA (COPYMODE DELETEMODE) (* rrb " 1-Feb-85 18:39") - - (* determines if this button event is over by looking at the keys that are held - down. COPYMODE and DELETEMODE indicate the keystate at the entry point.) + [LAMBDA (COPYMODE DELETEMODE) (* rrb " 1-Feb-85 18:39") + + (* determines if this button event is over by looking at the keys that are held + down. COPYMODE and DELETEMODE indicate the keystate at the entry point.) (COND [DELETEMODE (AND (NOT (OR (.DELETEKEYDOWNP.) @@ -2296,21 +2355,19 @@ This will be slow for arcs and curves."] (COPYMODE (NULL (.COPYKEYDOWNP.]) (SK.BUTTONEVENT.SAME.KEYS - [LAMBDA (COPYMODE DELETEMODE) (* rrb " 1-Feb-85 18:39") - - (* determines if the same keys are held down now as were held down at the - start. If not, the event will be stopped. - COPYMODE and DELETEMODE indicate the keystate at the entry point.) + [LAMBDA (COPYMODE DELETEMODE) (* rrb " 1-Feb-85 18:39") + + (* determines if the same keys are held down now as were held down at the start. + If not, the event will be stopped. COPYMODE and DELETEMODE indicate the keystate + at the entry point.) (COND [DELETEMODE (AND (OR (.DELETEKEYDOWNP.) (.MOVEKEYDOWNP.)) (EQ COPYMODE (OR (.COPYKEYDOWNP.) (.MOVEKEYDOWNP.] - (COPYMODE - - (* if we are not in delete mode, ignore the state of the delete key.) - + (COPYMODE (* if we are not in delete mode, + ignore the state of the delete key.) (.COPYKEYDOWNP.]) ) (DECLARE%: EVAL@COMPILE @@ -2328,18 +2385,17 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.SEL.AND.CHANGE - [LAMBDA (W) (* rrb "10-Dec-85 17:07") - - (* allows the user to select some elements and changes them.) - + [LAMBDA (W) (* rrb "10-Dec-85 17:07") + (* allows the user to select some + elements and changes them.) (SK.CHANGE.THING (SK.SELECT.MULTIPLE.ITEMS W T NIL 'CHANGE) W]) (SK.CHECK.WHENCHANGEDFN - [LAMBDA (VIEWER GELT PROPERTY NEWVALUE OLDVALUE) (* rrb " 3-Jan-86 18:36") - - (* checks if the sketch has a whenchange fn and if so, calls it and interprets - the result. Returns NIL if the change shouldn't be made.) + [LAMBDA (VIEWER GELT PROPERTY NEWVALUE OLDVALUE) (* rrb " 3-Jan-86 18:36") + + (* checks if the sketch has a whenchange fn and if so, calls it and interprets + the result. Returns NIL if the change shouldn't be made.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) RESULT WHENCHANGEDFN) @@ -2353,10 +2409,10 @@ This will be slow for arcs and curves."] (T (RETURN GELT]) (SK.CHECK.PRECHANGEFN - [LAMBDA (VIEWER SCRELT CHANGESPEC) (* rrb "27-Jun-86 15:51") - - (* checks if the sketch has a prechange fn and if so, calls it and interprets - the result. Returns NIL if the change shouldn't be made.) + [LAMBDA (VIEWER SCRELT CHANGESPEC) (* rrb "27-Jun-86 15:51") + + (* checks if the sketch has a prechange fn and if so, calls it and interprets the + result. Returns NIL if the change shouldn't be made.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) PRECHANGEFN) @@ -2366,14 +2422,15 @@ This will be slow for arcs and curves."] CHANGESPEC]) (SK.CHANGE.ELT - [LAMBDA (W) (* rrb "31-Jan-86 10:46") + [LAMBDA (W) (* rrb "31-Jan-86 10:46") (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.CHANGE (KWOTE W)) W]) (SK.CHANGE.THING - [LAMBDA (ELTSTOCHANGE W) (* rrb " 6-Jan-85 19:23") - - (* ELTSTOCHANGE is a sketch element that was selected for a CHANGE operation.) + [LAMBDA (ELTSTOCHANGE W) (* rrb " 6-Jan-85 19:23") + (* ELTSTOCHANGE is a sketch element + that was selected for a CHANGE + operation.) (* Change according to the first one  on the list) (PROG (FIRSTTYPE READCHANGEFN) (* find the first thing that has a @@ -2389,15 +2446,15 @@ This will be slow for arcs and curves."] ELTSTOCHANGE W]) (SKETCH.CHANGE.ELEMENTS - [LAMBDA (ELEMENTS CHANGESPECS SKETCHTOUPDATE ADDHISTORY?) (* rrb " 2-Oct-86 16:38") - - (* Changes the elements ELEMENTS according to the change specifications - CHANGESPECs. If SKETCHTOUPDATE is a viewer or a sketch. - it will be updated. If ADDHISTORY is non-NIL, the changes will be added to the - history list of SKETCHTOUPDATE which should be a viewer. - CHANGESPECs can be a list of the line, brush, text or arc properties, e.g. - ((TEXT BOLD) (SIZE LARGER) (DASHING (3 1 2 1))%. - The changes will be applied to any elements for which they make sense.)) + [LAMBDA (ELEMENTS CHANGESPECS SKETCHTOUPDATE ADDHISTORY?) (* rrb " 2-Oct-86 16:38") + + (* Changes the elements ELEMENTS according to the change specifications + CHANGESPECs. If SKETCHTOUPDATE is a viewer or a sketch. + it will be updated. If ADDHISTORY is non-NIL, the changes will be added to the + history list of SKETCHTOUPDATE which should be a viewer. + CHANGESPECs can be a list of the line, brush, text or arc properties, e.g. + ((TEXT BOLD) (SIZE LARGER) (DASHING (3 1 2 1))%. + The changes will be applied to any elements for which they make sense.)) (PROG ((VIEWER (SK.VIEWER.FROM.SKETCH.ARG SKETCHTOUPDATE)) RESULT) @@ -2408,10 +2465,10 @@ This will be slow for arcs and curves."] VIEWER NIL NIL (NULL ADDHISTORY?]) (SK.APPLY.SINGLE.CHANGEFN - [LAMBDA (GELEMENT CHANGEFN CHANGESPEC VIEWER) (* rrb " 2-Oct-86 10:49") - - (* applies a single change to an element. - It returns a change structure that contains the old and new elements.) + [LAMBDA (GELEMENT CHANGEFN CHANGESPEC VIEWER) (* rrb " 2-Oct-86 10:49") + + (* applies a single change to an element. + It returns a change structure that contains the old and new elements.) (COND ((EQ (fetch (GLOBALPART GTYPE) of GELEMENT) @@ -2420,10 +2477,10 @@ This will be slow for arcs and curves."] (T (APPLY* CHANGEFN GELEMENT CHANGESPEC VIEWER]) (SK.DO.CHANGESPECS - [LAMBDA (ELEMENT CHANGESPECS VIEWER) (* rrb " 2-Oct-86 16:31") - - (* returns a change structure that is the combined effects of applying all - CHANGESPECS to ELEMENT.) + [LAMBDA (ELEMENT CHANGESPECS VIEWER) (* rrb " 2-Oct-86 16:31") + + (* returns a change structure that is the combined effects of applying all + CHANGESPECS to ELEMENT.) (* for now, pretty kludgy) (PROG (NEWELEMENT) (COND @@ -2436,22 +2493,21 @@ This will be slow for arcs and curves."] NEWELT) of NEWELEMENT )) (T - - (* before one of the change specs applies, use the original element.) - + (* before one of the change specs + applies, use the original element.) ELEMENT)) CHANGESPEC VIEWER) NEWELEMENT))) (RETURN (AND NEWELEMENT (create SKHISTORYCHANGESPEC - OLDELT _ ELEMENT - NEWELT _ (fetch (SKHISTORYCHANGESPEC NEWELT) of NEWELEMENT) - PROPERTY _ CHANGESPECS]) + OLDELT ↠ELEMENT + NEWELT ↠(fetch (SKHISTORYCHANGESPEC NEWELT) of NEWELEMENT) + PROPERTY ↠CHANGESPECS]) (SK.VIEWER.FROM.SKETCH.ARG - [LAMBDA (SKETCH) (* rrb " 2-Oct-86 10:57") - - (* returns the viewer that changes should be reflected in when SKETCH is passed - in as a sketch argument.) + [LAMBDA (SKETCH) (* rrb " 2-Oct-86 10:57") + + (* returns the viewer that changes should be reflected in when SKETCH is passed + in as a sketch argument.) (COND ((NULL SKETCH) @@ -2461,7 +2517,7 @@ This will be slow for arcs and curves."] (CAR (ALL.SKETCH.VIEWERS SKETCH]) (SK.DO.CHANGESPEC1 - [LAMBDA (ELEMENT CHANGESPEC VIEWER) (* rrb "23-Oct-86 14:21") + [LAMBDA (ELEMENT CHANGESPEC VIEWER) (* rrb "23-Oct-86 14:21") (* applies a single change spec to a  single element.) (PROG (CHANGEASPECTFN (CHANGEHOW (CADR CHANGESPEC))) @@ -2476,10 +2532,9 @@ This will be slow for arcs and curves."] ((TEXT NEWFONT SETSIZE SAME FAMILY&SIZE) (SETQ CHANGEHOW CHANGESPEC) (FUNCTION SK.CHANGE.TEXT)) - (ADDPOINT - - (* handle this specially because it shouldn't go inside of a group element.) - + (ADDPOINT (* handle this specially because it + shouldn't go inside of a group + element.) (RETURN (SK.ADD.KNOT.TO.ELEMENT ELEMENT CHANGEHOW))) (BRUSHCOLOR (FUNCTION SK.CHANGE.BRUSH.COLOR)) (FILLINGCOLOR (FUNCTION SK.CHANGE.FILLING.COLOR)) @@ -2489,26 +2544,26 @@ This will be slow for arcs and curves."] (RETURN (SK.APPLY.SINGLE.CHANGEFN ELEMENT CHANGEASPECTFN CHANGEHOW VIEWER]) (SK.CHANGEFN - [LAMBDA (ELEMENTTYPE) (* rrb " 8-Jan-86 17:15") - - (* returns the changefn for an element. The only one that isnt - SK.ELEMENTS.CHANGEFN is image objects.) + [LAMBDA (ELEMENTTYPE) (* rrb " 8-Jan-86 17:15") + + (* returns the changefn for an element. The only one that isnt + SK.ELEMENTS.CHANGEFN is image objects.) (* the changefn should return a list  of SKHISTORYCHANGESPEC instances.) (OR (fetch (SKETCHTYPE CHANGEFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE)) (FUNCTION SK.DEFAULT.CHANGEFN]) (SK.READCHANGEFN - [LAMBDA (ELEMENTTYPE) (* rrb " 6-Jan-85 18:29") - - (* used to be (OR & (FUNCTION SK.DEFAULT.CHANGEFN)) If this really isn't - necessary, clean out SK.DEFAULT.CHANGEFN and all the things only it calls. - If it is necessary, update it to include a readchangefn.) + [LAMBDA (ELEMENTTYPE) (* rrb " 6-Jan-85 18:29") + + (* used to be (OR & (FUNCTION SK.DEFAULT.CHANGEFN)) If this really isn't + necessary, clean out SK.DEFAULT.CHANGEFN and all the things only it calls. + If it is necessary, update it to include a readchangefn.) (fetch (SKETCHTYPE READCHANGEFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.DEFAULT.CHANGEFN - [LAMBDA (SCRNELT W FIELD) (* rrb "14-May-84 15:57") + [LAMBDA (SCRNELT W FIELD) (* rrb "14-May-84 15:57") (PROG ([FIELD (OR FIELD (SK.MENU.AND.RETURN.FIELD (fetch (SCREENELT GTYPE) of SCRNELT] (INDVELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of SCRNELT)) (NOSETVALUE "str") @@ -2525,10 +2580,9 @@ This will be slow for arcs and curves."] (RECLOOK (fetch (SCREENELT GTYPE) of SCRNELT)) 'FETCH)) [COND - ((LISTP FIELD) - - (* cadr is queryfunction which can do special input and return value checking.) - + ((LISTP FIELD) (* cadr is queryfunction which can do + special input and return value + checking.) (SETQ NEWPROPVALUE (APPLY* (CADR FIELD) SCRNELT FIELD W NOSETVALUE))) (T (* have NIL returned be no change.) @@ -2550,34 +2604,33 @@ This will be slow for arcs and curves."] (RETURN (fetch (SCREENELT GLOBALPART) of SCRNELT]) (CHANGEABLEFIELDITEMS - [LAMBDA (ELEMENTTYPE) (* rrb "11-May-84 15:49") - - (* returns the list of fields that element type allows to change. - Each field should be of the form (FIELDNAMELABEL - (QUOTE (FIELDNAME QUERYFN)) "helpstring") - - QUERYFN should be a function of four args%: the screen element being changed, - the "field" returned from this function, the window the sketch is being - displayed in, and a value to be returned if no change should be made.) + [LAMBDA (ELEMENTTYPE) (* rrb "11-May-84 15:49") + + (* returns the list of fields that element type allows to change. + Each field should be of the form (FIELDNAMELABEL + (QUOTE (FIELDNAME QUERYFN)) "helpstring") - + QUERYFN should be a function of four args%: the screen element being changed, the "field" + returned from this function, the window the sketch is being displayed in, and a + value to be returned if no change should be made.) (GETPROP ELEMENTTYPE 'CHANGEABLEFIELDITEMS]) (SK.APPLY.CHANGE.COMMAND - [LAMBDA (CHANGEFN COMMAND SCRELTS SKW) (* rrb "24-Sep-86 16:23") - - (* applies a change command to the relevant elements in SCRELTS.) - + [LAMBDA (CHANGEFN COMMAND SCRELTS SKW) (* rrb "24-Sep-86 16:23") + (* applies a change command to the + relevant elements in SCRELTS.) (AND COMMAND (SK.DO.AND.RECORD.CHANGES (bind ELTCHANGE for SCRELT in SCRELTS - when (SETQ ELTCHANGE (SK.APPLY.CHANGE.COMMAND1 CHANGEFN + when (SETQ ELTCHANGE (SK.APPLY.CHANGE.COMMAND1 CHANGEFN COMMAND SCRELT SKW)) collect ELTCHANGE) SKW]) (SK.DO.AND.RECORD.CHANGES - [LAMBDA (LSTOFCHANGESPECS VIEWER DONTUPDATEPRIORITYFLG DONTDISPLAYFLG DONTHISTORYFLG) + [LAMBDA (LSTOFCHANGESPECS VIEWER DONTUPDATEPRIORITYFLG DONTDISPLAYFLG DONTHISTORYFLG) (* rrb " 2-Oct-86 16:22") - - (* accepts a list of change specs and actually updates the sketch, viewer and - history list.) + + (* accepts a list of change specs and actually updates the sketch, viewer and + history list.) (COND (LSTOFCHANGESPECS [SETQ LSTOFCHANGESPEC (COND @@ -2587,9 +2640,9 @@ This will be slow for arcs and curves."] (SORT.CHANGESPECS.BY.NEW.PRIORITY LSTOFCHANGESPECS)) (T - - (* order so that new priorities are assigned in the same relative order as the - old ones.) + + (* order so that new priorities are assigned in the same relative order as the + old ones.) (SORT.CHANGESPECS.BY.OLD.PRIORITY LSTOFCHANGESPECS] @@ -2598,10 +2651,10 @@ This will be slow for arcs and curves."] T]) (SK.APPLY.CHANGE.COMMAND1 - [LAMBDA (CHANGEFN COMMAND SCRELT VIEWER) (* rrb "27-Jun-86 15:48") - - (* applies a change command to a single screen element. - Does the prechangefn and whenchangefn checks.) + [LAMBDA (CHANGEFN COMMAND SCRELT VIEWER) (* rrb "27-Jun-86 15:48") + + (* applies a change command to a single screen element. + Does the prechangefn and whenchangefn checks.) (PROG (FNRESULT CHANGES) (COND @@ -2611,9 +2664,9 @@ This will be slow for arcs and curves."] ((LISTP FNRESULT) (* result was a different change  specification.) (SETQ COMMAND FNRESULT))) - - (* code was written to take a list but since prechangefn can change things at - the elements level, every element is done individually.) + + (* code was written to take a list but since prechangefn can change things at the + elements level, every element is done individually.) (OR (SETQ CHANGES (APPLY* CHANGEFN (LIST SCRELT) VIEWER COMMAND)) @@ -2627,7 +2680,7 @@ This will be slow for arcs and curves."] CHANGES]) (SK.ELEMENTS.CHANGEFN - [LAMBDA (SCRELTS SKW HOW) (* rrb " 2-Oct-86 16:18") + [LAMBDA (SCRELTS SKW HOW) (* rrb " 2-Oct-86 16:18") (* changefn for many sketch elements.) (PROG (CHANGEASPECTFN (CHANGEHOW (CADR HOW))) (OR (SETQ CHANGEASPECTFN (SELECTQ (CAR HOW) @@ -2641,10 +2694,8 @@ This will be slow for arcs and curves."] ((TEXT NEWFONT SETSIZE SAME FAMILY&SIZE) (SETQ CHANGEHOW HOW) (FUNCTION SK.CHANGE.TEXT)) - (ADDPOINT - - (* handle this specially because it only works on the first element.) - + (ADDPOINT (* handle this specially because it + only works on the first element.) (RETURN (LIST (SK.ADD.KNOT.TO.ELEMENT (fetch (SCREENELT GLOBALPART) of (CAR SCRELTS)) @@ -2660,10 +2711,10 @@ This will be slow for arcs and curves."] CHANGEASPECTFN CHANGEHOW SKW]) (READ.POINT.TO.ADD - [LAMBDA (SCRELT SKVIEWER) (* rrb "20-May-86 10:52") - - (* asks where a point should be added and where it should be. - Return a list (AfterPt NewPt)) + [LAMBDA (SCRELT SKVIEWER) (* rrb "20-May-86 10:52") + + (* asks where a point should be added and where it should be. + Return a list (AfterPt NewPt)) (PROG (AFTERPT NEWPT) (STATUSPRINT SKVIEWER "Select the point that the new point should follow.") @@ -2678,20 +2729,18 @@ This will be slow for arcs and curves."] (SK.MAP.INPUT.PT.TO.GLOBAL NEWPT SKVIEWER]) (GLOBAL.KNOT.FROM.LOCAL - [LAMBDA (LOCALKNOT SCRELT) (* rrb "20-Nov-85 11:05") - - (* returns the global knot that corresponds to a local one.) - + [LAMBDA (LOCALKNOT SCRELT) (* rrb "20-Nov-85 11:05") + (* returns the global knot that + corresponds to a local one.) (for LKNOT in (fetch (SCREENELT HOTSPOTS) of SCRELT) as GKNOT in (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of SCRELT) 'DATA) when (EQUAL LKNOT LOCALKNOT) do (RETURN GKNOT]) (SK.ADD.KNOT.TO.ELEMENT - [LAMBDA (GELTWITHKNOTS PTS) (* rrb "16-Jan-86 12:23") - - (* adds a point to a knot element. The point - (CADR PTS) is added after (CAR PTS)) - + [LAMBDA (GELTWITHKNOTS PTS) (* rrb "16-Jan-86 12:23") + (* adds a point to a knot element. + The point (CADR PTS) is added after + (CAR PTS)) (PROG ((OLDKNOTS (GETSKETCHELEMENTPROP GELTWITHKNOTS 'DATA)) NEWKNOTS) [SETQ NEWKNOTS (for KNOT in OLDKNOTS join (COND @@ -2699,37 +2748,37 @@ This will be slow for arcs and curves."] (LIST KNOT (CADR PTS))) (T (LIST KNOT] (RETURN (create SKHISTORYCHANGESPEC - NEWELT _ (SK.CHANGE.ELEMENT.KNOTS GELTWITHKNOTS NEWKNOTS) - OLDELT _ GELTWITHKNOTS - PROPERTY _ 'DATA - NEWVALUE _ NEWKNOTS - OLDVALUE _ OLDKNOTS]) + NEWELT ↠(SK.CHANGE.ELEMENT.KNOTS GELTWITHKNOTS NEWKNOTS) + OLDELT ↠GELTWITHKNOTS + PROPERTY ↠'DATA + NEWVALUE ↠NEWKNOTS + OLDVALUE ↠OLDKNOTS]) (SK.GROUP.CHANGEFN - [LAMBDA (GROUPELT CHANGEASPECTFN CHANGEHOW SKW) (* rrb "10-Jan-86 12:15") - - (* maps a change function through all the elements of a group and returns a - change spec event if it takes on any of them.) + [LAMBDA (GROUPELT CHANGEASPECTFN CHANGEHOW SKW) (* rrb "10-Jan-86 12:15") + + (* maps a change function through all the elements of a group and returns a + change spec event if it takes on any of them.) (PROG (NEWELT) (SETQ NEWELT (SK.GROUP.CHANGEFN1 GROUPELT CHANGEASPECTFN CHANGEHOW SKW)) (OR NEWELT (RETURN)) (RETURN (create SKHISTORYCHANGESPEC - NEWELT _ NEWELT - OLDELT _ GROUPELT - PROPERTY _ 'DATA - NEWVALUE _ (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART + NEWELT ↠NEWELT + OLDELT ↠GROUPELT + PROPERTY ↠'DATA + NEWVALUE ↠(fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of NEWELT)) - OLDVALUE _ (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART + OLDVALUE ↠(fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GROUPELT]) (SK.GROUP.CHANGEFN1 - [LAMBDA (GROUPELT CHANGEASPECTFN CHANGEHOW SKW) (* rrb "27-Jun-86 16:19") - - (* maps a change function through all the elements of a group and returns a new - element if it takes on any of them.) + [LAMBDA (GROUPELT CHANGEASPECTFN CHANGEHOW SKW) (* rrb "27-Jun-86 16:19") + + (* maps a change function through all the elements of a group and returns a new + element if it takes on any of them.) (PROG ((OLDSUBELTS (fetch (GROUP LISTOFGLOBALELTS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT))) @@ -2740,14 +2789,14 @@ This will be slow for arcs and curves."] ((EQ (fetch (GLOBALPART GTYPE) of SUBELT) 'GROUP) (* handle a group by propagating it) - (SK.GROUP.CHANGEFN1 SUBELT CHANGEASPECTFN + (SK.GROUP.CHANGEFN1 SUBELT CHANGEASPECTFN CHANGEHOW SKW)) (T - - (* individual change functions return a change spec event, pull the new element - out of it. This throws aways a lot of information about what was changed but I - don't know any good way to save it so that it can be passed on undoing so don't - save it.) + + (* individual change functions return a change spec event, pull the new element + out of it. This throws aways a lot of information about what was changed but I + don't know any good way to save it so that it can be passed on undoing so don't + save it.) (fetch (SKHISTORYCHANGESPEC NEWELT) of (APPLY* CHANGEASPECTFN SUBELT @@ -2756,23 +2805,21 @@ This will be slow for arcs and curves."] NEWELT] (OR CHANGEDFLG (RETURN)) [SETQ NEWSUBELTS (for OLDSUBELT in OLDSUBELTS as NEWSUBELT in NEWSUBELTS - collect - - (* copy any unchanged elements so that user programs don't have to worry about - them.) - + collect (* copy any unchanged elements so that + user programs don't have to worry + about them.) (OR NEWSUBELT (SK.COPY.GLOBAL.ELEMENT OLDSUBELT] (RETURN (SK.UPDATE.GROUP.AFTER.CHANGE (create GLOBALPART - COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART ↠(fetch (GLOBALPART COMMONGLOBALPART ) of GROUPELT) - INDIVIDUALGLOBALPART _ + INDIVIDUALGLOBALPART ↠(create GROUP using (fetch (GLOBALPART INDIVIDUALGLOBALPART ) of GROUPELT) - LISTOFGLOBALELTS _ + LISTOFGLOBALELTS ↠NEWSUBELTS]) ) (DECLARE%: DONTCOPY @@ -2789,20 +2836,16 @@ This will be slow for arcs and curves."] (DEFINEQ (ADD.ELEMENT.TO.SKETCH - [LAMBDA (GELT SKETCH) (* rrb "23-Jun-87 13:29") + [LAMBDA (GELT SKETCH) (* rrb "23-Jun-87 13:29") (* changes the global sketch) (PROG [(REALSKETCH (INSURE.SKETCH SKETCH)) (ELTPRI (\GETSKETCHELEMENTPROP1 GELT 'PRI] [COND ((EQ (fetch (GLOBALPART GTYPE) of GELT) - 'SKIMAGEOBJ) - - (* call the wheninsertedfn for this imageobj if there is one.) - - (PROG ((IMOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (fetch (GLOBALPART - INDIVIDUALGLOBALPART - ) - of GELT))) + 'SKIMAGEOBJ) (* call the wheninsertedfn for this + imageobj if there is one.) + (PROG ((IMOBJ (fetch (SKIMAGEOBJ SKIMAGEOBJ) of (fetch (GLOBALPART INDIVIDUALGLOBALPART + ) of GELT))) DATUM) (COND ((AND (SETQ DATUM (IMAGEOBJPROP IMOBJ 'WHENINSERTEDFN)) @@ -2811,10 +2854,8 @@ This will be slow for arcs and curves."] NIL SKETCH))) (RETURN] (COND - ((NULL ELTPRI) - - (* give the element a priority and put it at the end) - + ((NULL ELTPRI) (* give the element a priority and put + it at the end) (SK.SET.ELEMENT.PRIORITY GELT (SK.POP.NEXT.PRIORITY REALSKETCH)) (TCONC (fetch (SKETCH SKETCHTCELL) of REALSKETCH) GELT)) @@ -2822,7 +2863,7 @@ This will be slow for arcs and curves."] (SK.MARK.DIRTY REALSKETCH]) (ADD.SKETCH.VIEWER - [LAMBDA (SKETCH VIEWER) (* rrb " 8-APR-83 17:56") + [LAMBDA (SKETCH VIEWER) (* rrb " 8-APR-83 17:56") (* adds VIEWER as a viewer of SKETCH.) (PROG (VIEWERS) (COND @@ -2834,7 +2875,7 @@ This will be slow for arcs and curves."] ALL.SKETCHES]) (REMOVE.SKETCH.VIEWER - [LAMBDA (SKETCH VIEWER) (* rrb "26-Apr-85 16:56") + [LAMBDA (SKETCH VIEWER) (* rrb "26-Apr-85 16:56") (* removes VIEWER as a viewer of  SKETCH.) (PROG (VIEWERS) @@ -2845,10 +2886,9 @@ This will be slow for arcs and curves."] (SETQ ALL.SKETCHES (REMOVE VIEWERS ALL.SKETCHES]) (ALL.SKETCH.VIEWERS - [LAMBDA (SKETCH) (* rrb " 8-APR-83 14:20") - - (* returns the list of all active viewers of a sketch) - + [LAMBDA (SKETCH) (* rrb " 8-APR-83 14:20") + (* returns the list of all active + viewers of a sketch) (CDR (VIEWER.BUCKET SKETCH]) (SKETCH.ALL.VIEWERS @@ -2857,65 +2897,58 @@ This will be slow for arcs and curves."] (ALL.SKETCH.VIEWERS (INSURE.SKETCH SKETCH]) (VIEWER.BUCKET - [LAMBDA (SKETCH) (* rrb " 8-APR-83 14:20") + [LAMBDA (SKETCH) (* rrb " 8-APR-83 14:20") (FASSOC SKETCH ALL.SKETCHES]) (ELT.INSIDE.REGION? - [LAMBDA (GLOBALPART WORLDREG) (* rrb " 4-AUG-83 14:51") - - (* determines if any part of an element is inside the region WORLDREG) - + [LAMBDA (GLOBALPART WORLDREG) (* rrb " 4-AUG-83 14:51") + (* determines if any part of an + element is inside the region WORLDREG) (APPLY* (SK.INSIDEFN (fetch (GLOBALPART GTYPE) of GLOBALPART)) GLOBALPART WORLDREG]) (ELT.INSIDE.SKWP - [LAMBDA (GLOBALPART SKETCHW) (* rrb "25-Nov-85 17:46") - - (* determines if a global element is in the world region of a map window.) - + [LAMBDA (GLOBALPART SKETCHW) (* rrb "25-Nov-85 17:46") + (* determines if a global element is + in the world region of a map window.) (ELT.INSIDE.REGION? GLOBALPART (SKETCH.REGION.VIEWED SKETCHW]) (SCALE.FROM.SKW - [LAMBDA (WINDOW) (* rrb "11-MAR-83 11:52") + [LAMBDA (WINDOW) (* rrb "11-MAR-83 11:52") (* gets the scale of a sketch window.) (WINDOWPROP WINDOW 'SCALE]) (SK.ADDELT.TO.WINDOW - [LAMBDA (PELT SKETCHW) (* rrb "10-Mar-86 14:56") - - (* adds a picture element to a sketch window. - Returns the element that was added.) - + [LAMBDA (PELT SKETCHW) (* rrb "10-Mar-86 14:56") + (* adds a picture element to a sketch + window. Returns the element that was + added.) (COND (PELT (SK.ADD.PRIORITY.LOCAL.ELEMENT.TO.SKETCH (WINDOWPROP SKETCHW 'SKETCHSPECS) PELT) [PROG ((CACHE (SK.HOTSPOT.CACHE SKETCHW))) (COND - (CACHE - - (* if there is a cache, adding an element will change it) - + (CACHE (* if there is a cache, adding an + element will change it) (SK.ADD.HOTSPOTS.TO.CACHE1 PELT CACHE)) - (T - - (* if this is the first, must set the window property too.) - + (T (* if this is the first, must set the + window property too.) (SK.SET.HOTSPOT.CACHE SKETCHW (SK.ADD.HOTSPOTS.TO.CACHE1 PELT CACHE] PELT]) (SK.CALC.REGION.VIEWED - [LAMBDA (WINDOW SCALE) (* rrb "29-APR-83 08:37") + [LAMBDA (WINDOW SCALE) (* rrb "29-APR-83 08:37") (* returns the region of the sketch  visible in window.) (UNSCALE.REGION (DSPCLIPPINGREGION NIL WINDOW) SCALE]) (SK.DRAWFIGURE - [LAMBDA (SCREENELT STREAM REGION SCALE) (* rrb "30-Aug-84 14:31") - - (* draws an element of a sketch in a window. - Makes sure the scale of the current drawing is with in the limits of the - element. Returns SCREENELT) + [LAMBDA (SCREENELT STREAM REGION SCALE) (* rrb "30-Aug-84 14:31") + + (* draws an element of a sketch in a window. + Makes sure the scale of the current drawing is with in the limits of the element. + Returns SCREENELT) (PROG (GLOBALPART) [COND @@ -2933,20 +2966,20 @@ This will be slow for arcs and curves."] (RETURN SCREENELT]) (SK.DRAWFIGURE1 - [LAMBDA (ELT SKW REGION) (* rrb "14-Sep-84 16:59") + [LAMBDA (ELT SKW REGION) (* rrb "14-Sep-84 16:59") (* displays a sketch element in a  window) (APPLY* (SK.DRAWFN (fetch (SCREENELT GTYPE) of ELT)) ELT SKW REGION]) (SK.LOCAL.FROM.GLOBAL - [LAMBDA (GELT SKSTREAM SCALE) (* rrb "11-Jul-86 15:56") - - (* returns the element instance of the global element GELT expanded into the - window SKW.) - - (* SKSTREAM can be deleted from call once TEXT.EXPANDFN no longer needs to - distinquish INTERPRESS stream from windows.) + [LAMBDA (GELT SKSTREAM SCALE) (* rrb "11-Jul-86 15:56") + (* returns the element instance of the + global element GELT expanded into the + window SKW.) + + (* SKSTREAM can be deleted from call once TEXT.EXPANDFN no longer needs to + distinquish INTERPRESS stream from windows.) (PROG ((SCRELT (APPLY* (SK.EXPANDFN (fetch (GLOBALPART GTYPE) of GELT)) GELT @@ -2962,10 +2995,10 @@ This will be slow for arcs and curves."] (RETURN SCRELT]) (SKETCH.REGION.VIEWED - [LAMBDA (VIEWER NEWREGION) (* rrb "23-Apr-87 12:20") - - (* returns the region in sketch coordinates of the area visible in SKETCHW.) - + [LAMBDA (VIEWER NEWREGION) (* rrb "23-Apr-87 12:20") + (* returns the region in sketch + coordinates of the area visible in + SKETCHW.) (COND [(IMAGEOBJP VIEWER) (* it is a sketch image object) (PROG ([SK? (LISTP (IMAGEOBJPROP VIEWER 'OBJECTDATUM] @@ -2973,62 +3006,57 @@ This will be slow for arcs and curves."] (COND [(type? SKETCH (FETCH (SKETCHIMAGEOBJ SKIO.SKETCH) OF SK?)) (RETURN (PROG1 (fetch (SKETCHIMAGEOBJ SKIO.REGION) of SK?) - (COND - (NEWREGION (COND - ((REGIONP NEWREGION) - (replace (SKETCHIMAGEOBJ SKIO.REGION) - of SK? with NEWREGION)) - ((SETQ NEWVIEW (SKETCH.VIEW.FROM.NAME NEWREGION - VIEWER)) - (replace (SKETCHIMAGEOBJ SKIO.REGION) - of SK? with NEWVIEW)) - ((EQ NEWREGION 'HOME) - - (* change scale to 1.0 and set lower left of region viewed to - (0,0)%.) - - NIL) - (T - - (* HOME and named views aren't supported for image object sketches.) - - (\ILLEGAL.ARG NEWREGION] + [COND + (NEWREGION (COND + ((REGIONP NEWREGION) + (replace (SKETCHIMAGEOBJ SKIO.REGION) of SK? + with NEWREGION)) + ((SETQ NEWVIEW (SKETCH.VIEW.FROM.NAME NEWREGION VIEWER + )) + (replace (SKETCHIMAGEOBJ SKIO.REGION) of SK? + with NEWVIEW)) + ((EQ NEWREGION 'HOME) + (* change scale to 1.0 and set lower + left of region viewed to + (0,0)%.) + NIL) + (T (* HOME and named views aren't + supported for image object sketches.) + (\ILLEGAL.ARG NEWREGION])] (T (ERROR "not a sketch image object" VIEWER] [(WINDOWP VIEWER) (PROG1 (WINDOWPROP VIEWER 'REGION.VIEWED) - (COND - (NEWREGION (PROG (NEWVIEW) - (RETURN (COND - ((REGIONP NEWREGION) - (SKETCH.GLOBAL.REGION.ZOOM VIEWER NEWREGION)) - ((EQ NEWREGION 'HOME) - (SKETCH.HOME VIEWER)) - ((SETQ NEWVIEW (SKETCH.VIEW.FROM.NAME NEWREGION - VIEWER)) - (SK.MOVE.TO.VIEW VIEWER NEWVIEW)) - (T (\ILLEGAL.ARG NEWREGION] + [COND + (NEWREGION (PROG (NEWVIEW) + (RETURN (COND + ((REGIONP NEWREGION) + (SKETCH.GLOBAL.REGION.ZOOM VIEWER NEWREGION)) + ((EQ NEWREGION 'HOME) + (SKETCH.HOME VIEWER)) + ((SETQ NEWVIEW (SKETCH.VIEW.FROM.NAME NEWREGION VIEWER)) + (SK.MOVE.TO.VIEW VIEWER NEWVIEW)) + (T (\ILLEGAL.ARG NEWREGION])] (T (\ILLEGAL.ARG VIEWER]) (SKETCH.VIEW.FROM.NAME - [LAMBDA (VIEWNAME SKETCHW) (* rrb "25-Nov-85 17:55") - - (* returns the view structure for a view given its name.) - + [LAMBDA (VIEWNAME SKETCHW) (* rrb "25-Nov-85 17:55") + (* returns the view structure for a + view given its name.) (for SAVEDVIEW in (GETSKETCHPROP (INSURE.SKETCH SKETCHW) 'VIEWS) when (EQUAL VIEWNAME (fetch (SKETCHVIEW VIEWNAME) of SAVEDVIEW)) do (RETURN SAVEDVIEW]) (SK.UPDATE.REGION.VIEWED - [LAMBDA (SKW) (* rrb "11-Jul-86 15:51") + [LAMBDA (SKW) (* rrb "11-Jul-86 15:51") (* updates the REGION.VIEWED property  of a window.) (WINDOWPROP SKW 'REGION.VIEWED (SK.CALC.REGION.VIEWED SKW (VIEWER.SCALE SKW]) (SKETCH.ADD.AND.DISPLAY - [LAMBDA (GELT SKETCHW DONTCLEARCURSOR) (* rrb "14-Nov-84 17:12") - - (* adds a new element to a sketch window and handles propagation to all other - figure windows) + [LAMBDA (GELT SKETCHW DONTCLEARCURSOR) (* rrb "14-Nov-84 17:12") + + (* adds a new element to a sketch window and handles propagation to all other + figure windows) (COND (GELT (SK.ADD.HISTEVENT 'ADD (LIST GELT) @@ -3036,10 +3064,9 @@ This will be slow for arcs and curves."] (SK.ADD.ELEMENT GELT SKETCHW DONTCLEARCURSOR]) (SKETCH.ADD.AND.DISPLAY1 - [LAMBDA (GELT SKETCHW SCALE NODISPLAYFLG) (* rrb "11-Jul-86 15:51") - - (* displays a sketch element and adds it to the window.) - + [LAMBDA (GELT SKETCHW SCALE NODISPLAYFLG) (* rrb "11-Jul-86 15:51") + (* displays a sketch element and adds + it to the window.) (COND (GELT (COND (NODISPLAYFLG (SK.ADD.ITEM GELT SKETCHW)) @@ -3047,19 +3074,18 @@ This will be slow for arcs and curves."] SKETCHW NIL (OR SCALE (VIEWER.SCALE SKETCHW]) (SK.ADD.ITEM - [LAMBDA (GELT SKETCHW) (* rrb "10-APR-83 13:38") - - (* adds a global element to a window. Returns the local element that was - actually added.) + [LAMBDA (GELT SKETCHW) (* rrb "10-APR-83 13:38") + + (* adds a global element to a window. Returns the local element that was actually + added.) (SK.ADDELT.TO.WINDOW (SK.LOCAL.FROM.GLOBAL GELT SKETCHW) SKETCHW]) (SKETCHW.ADD.INSTANCE - [LAMBDA (TYPE SKW) (* rrb "14-Nov-84 17:08") - - (* reads an instance of type TYPE from the user and displays it in SKW.) - + [LAMBDA (TYPE SKW) (* rrb "14-Nov-84 17:08") + (* reads an instance of type TYPE from + the user and displays it in SKW.) (PROG ((ELT (SK.INPUT TYPE SKW))) (AND ELT (SKETCH.ADD.AND.DISPLAY ELT SKW)) (RETURN ELT]) @@ -3072,14 +3098,14 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.SEL.AND.DELETE - [LAMBDA (W) (* rrb "10-Dec-85 17:08") + [LAMBDA (W) (* rrb "10-Dec-85 17:08") (* lets the user select elements and  deletes them) (SK.DELETE.ELEMENT (SK.SELECT.MULTIPLE.ITEMS W T NIL 'DELETE) W]) (SK.ERASE.AND.DELETE.ITEM - [LAMBDA (SELELT SKW NODISPLAYFLG) (* rrb "30-Jul-85 15:36") + [LAMBDA (SELELT SKW NODISPLAYFLG) (* rrb "30-Jul-85 15:36") (* removes a sketch element from a  viewer.) (COND @@ -3087,11 +3113,11 @@ This will be slow for arcs and curves."] (SK.DELETE.ITEM SELELT SKW]) (REMOVE.ELEMENT.FROM.SKETCH - [LAMBDA (GELT SKETCH INSIDEGROUPFLG) (* rrb "26-Sep-86 13:24") - - (* changes the global sketch Returns the element or the group element - containing the element if the element was found in the sketch. - If INSIDEGROUPFLG is T, it will go inside of groups.) + [LAMBDA (GELT SKETCH INSIDEGROUPFLG) (* rrb "26-Sep-86 13:24") + + (* changes the global sketch Returns the element or the group element containing + the element if the element was found in the sketch. + If INSIDEGROUPFLG is T, it will go inside of groups.) (PROG ((SKETCHDATA (INSURE.SKETCH SKETCH))) (COND @@ -3108,10 +3134,10 @@ This will be slow for arcs and curves."] (T (RETURN NIL]) (SK.DELETE.ELEMENT - [LAMBDA (ELTSTODEL SKETCHW ELTSFORHISTORY) (* rrb "30-Dec-85 16:19") - - (* deletes a list of element to a sketch window and handles propagation to all - other figure windows) + [LAMBDA (ELTSTODEL SKETCHW ELTSFORHISTORY) (* rrb "30-Dec-85 16:19") + + (* deletes a list of element to a sketch window and handles propagation to all + other figure windows) (SKED.CLEAR.SELECTION SKETCHW) (AND ELTSTODEL (SK.DELETE.ELEMENT2 (for SCRELT in ELTSTODEL collect (fetch (SCREENELT GLOBALPART) @@ -3119,10 +3145,10 @@ This will be slow for arcs and curves."] SKETCHW ELTSFORHISTORY]) (SK.DELETE.ELEMENT2 - [LAMBDA (GELTSTODEL SKETCHW ELTSFORHISTORY) (* rrb "30-Dec-85 16:18") - - (* deletes a list of global elements and adds it to the history list depending - upon ELTSFORHISTORY) + [LAMBDA (GELTSTODEL SKETCHW ELTSFORHISTORY) (* rrb "30-Dec-85 16:18") + + (* deletes a list of global elements and adds it to the history list depending + upon ELTSFORHISTORY) (PROG (DELETEDELTS) (SETQ DELETEDELTS (SK.CHECK.WHENDELETEDFN SKETCHW GELTSTODEL)) @@ -3134,15 +3160,14 @@ This will be slow for arcs and curves."] (RETURN DELETEDELTS]) (SK.DELETE.KNOT - [LAMBDA (W) (* rrb "31-Jan-86 10:47") - - (* lets the user select a knot in a curve or wire and deletes it.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:47") + (* lets the user select a knot in a + curve or wire and deletes it.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.DELETE.KNOT (KWOTE W)) W]) (SK.SEL.AND.DELETE.KNOT - [LAMBDA (W) (* rrb "10-Dec-85 17:03") + [LAMBDA (W) (* rrb "10-Dec-85 17:03") (* lets the user select a knot and  deletes it.) (PROG [(KNOTELTS (SUBSET (LOCALSPECS.FROM.VIEWER W) @@ -3160,7 +3185,7 @@ This will be slow for arcs and curves."] KNOTELTS W]) (SK.DELETE.ELEMENT.KNOT - [LAMBDA (LOCALKNOT SCRELTS SKW) (* rrb " 9-Jan-86 19:45") + [LAMBDA (LOCALKNOT SCRELTS SKW) (* rrb " 9-Jan-86 19:45") (* deletes a knot from a curve or wire  element.) (SKED.CLEAR.SELECTION SKW) @@ -3196,11 +3221,11 @@ This will be slow for arcs and curves."]  screen) (SK.UPDATE.ELEMENTS (SETQ CHANGES (CONS (create SKHISTORYCHANGESPEC - NEWELT _ NEWELT - OLDELT _ GLOBALPART - PROPERTY _ 'DATA - NEWVALUE _ NEWKNOTS - OLDVALUE _ GLOBALKNOTS))) + NEWELT ↠NEWELT + OLDELT ↠GLOBALPART + PROPERTY ↠'DATA + NEWVALUE ↠NEWKNOTS + OLDVALUE ↠GLOBALKNOTS))) SKW) (SK.ADD.HISTEVENT 'CHANGE CHANGES SKW] (T (* delete the whole element.) @@ -3208,11 +3233,11 @@ This will be slow for arcs and curves."] SKW]) (SK.CHECK.WHENDELETEDFN - [LAMBDA (VIEWER GELTS) (* rrb "30-Dec-85 16:15") - - (* checks if the sketch has a when deleted fn and if so, creates the list of - global elements and interprets the result. - Returns a list of the elements that should be deleted.) + [LAMBDA (VIEWER GELTS) (* rrb "30-Dec-85 16:15") + + (* checks if the sketch has a when deleted fn and if so, creates the list of + global elements and interprets the result. + Returns a list of the elements that should be deleted.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) RESULT DELETEFN) @@ -3228,10 +3253,9 @@ This will be slow for arcs and curves."] (T (RETURN GELTS]) (SK.CHECK.PREEDITFN - [LAMBDA (VIEWER OLDELT) (* rrb " 9-Dec-85 11:52") - - (* checks if the sketch has a preedit fn and if so, calls it) - + [LAMBDA (VIEWER OLDELT) (* rrb " 9-Dec-85 11:52") + (* checks if the sketch has a preedit + fn and if so, calls it) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) PREEDITFN) (COND @@ -3241,20 +3265,20 @@ This will be slow for arcs and curves."] 'DON'T]) (SK.CHECK.END.INITIAL.EDIT - [LAMBDA (VIEWER NEWELT) (* rrb "15-Jan-86 15:20") - - (* called when the edit of a newly created text element is ended. - Calls the when changed fn.) + [LAMBDA (VIEWER NEWELT) (* rrb "15-Jan-86 15:20") + + (* called when the edit of a newly created text element is ended. + Calls the when changed fn.) (SK.CHECK.WHENCHANGEDFN VIEWER NEWELT 'DATA NIL (fetch (TEXT LISTOFCHARACTERS) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of NEWELT]) (SK.CHECK.WHENPOINTDELETEDFN - [LAMBDA (VIEWER SCRELT CONTROLPOINT) (* rrb " 3-Jan-86 15:32") - - (* checks if the sketch has a prechange fn and if so, calls it and interprets - the result. Returns NIL if the point should not be deleted.) + [LAMBDA (VIEWER SCRELT CONTROLPOINT) (* rrb " 3-Jan-86 15:32") + + (* checks if the sketch has a prechange fn and if so, calls it and interprets the + result. Returns NIL if the point should not be deleted.) (PROG ((SKETCH (INSURE.SKETCH VIEWER)) RESULT PRECHANGEFN) @@ -3269,21 +3293,21 @@ This will be slow for arcs and curves."] (T (RETURN SCRELT]) (SK.ERASE.ELT - [LAMBDA (ELT WINDOW REGION) (* rrb "30-Aug-86 15:08") + [LAMBDA (ELT WINDOW REGION) (* rrb "30-Aug-86 15:08") (* erases a sketch element) (DSPOPERATION 'ERASE WINDOW) (SK.DRAWFIGURE ELT WINDOW REGION (VIEWER.SCALE WINDOW)) (DSPOPERATION 'PAINT WINDOW]) (SK.DELETE.ELT - [LAMBDA (W) (* rrb "31-Jan-86 10:48") + [LAMBDA (W) (* rrb "31-Jan-86 10:48") (* lets the user select an element and  deletes it.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.DELETE (KWOTE W)) W]) (SK.DELETE.ITEM - [LAMBDA (ELT SKETCHW) (* rrb "12-May-85 18:10") + [LAMBDA (ELT SKETCHW) (* rrb "12-May-85 18:10") (* deletes an element from a window) (COND (ELT (DELFROMTCONC (WINDOWPROP SKETCHW 'SKETCHSPECS) @@ -3292,10 +3316,10 @@ This will be slow for arcs and curves."] ELT]) (DELFROMTCONC - [LAMBDA (TCONCCELL ELEMENT) (* rrb "26-Sep-86 13:24") - - (* deletes an element from a TCONC cell list. - Returns T if the element was deleted, NIL if it wasn't a member.) + [LAMBDA (TCONCCELL ELEMENT) (* rrb "26-Sep-86 13:24") + + (* deletes an element from a TCONC cell list. + Returns T if the element was deleted, NIL if it wasn't a member.) (COND ((EQ ELEMENT (CAAR TCONCCELL)) (* first element) @@ -3307,10 +3331,8 @@ This will be slow for arcs and curves."] (T (* remove first element.) (RPLACA TCONCCELL (CDAR TCONCCELL] T) - ((EQ ELEMENT (CADR TCONCCELL)) - - (* elt to delete is the last one on the list, do special case.) - + ((EQ ELEMENT (CADR TCONCCELL)) (* elt to delete is the last one on + the list, do special case.) (for TAIL on (CAR TCONCCELL) when (EQ (CDR TAIL) (CDR TCONCCELL)) do (* update the TCONC last entry) @@ -3331,24 +3353,24 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.COPY.ELT - [LAMBDA (W) (* rrb "31-Jan-86 10:49") + [LAMBDA (W) (* rrb "31-Jan-86 10:49") (* lets the user select an element and  copies it.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.COPY (KWOTE W)) W]) (SK.SEL.AND.COPY - [LAMBDA (W) (* rrb "10-Dec-85 17:08") + [LAMBDA (W) (* rrb "10-Dec-85 17:08") (* lets the user select elements and  copies them.) (SK.COPY.ELEMENTS (SK.SELECT.MULTIPLE.ITEMS W T NIL 'COPY) W]) (SK.COPY.ELEMENTS - [LAMBDA (SCRELTS SKW) (* rrb " 1-Oct-86 19:12") - - (* create a bitmap of the thing being moved and get its new position. - Then translate all the pieces.) + [LAMBDA (SCRELTS SKW) (* rrb " 1-Oct-86 19:12") + + (* create a bitmap of the thing being moved and get its new position. + Then translate all the pieces.) (AND SCRELTS (PROG (FIGINFO FIRSTHOTSPOT GHOTSPOT LOWLFT NEWGPOS DELTAPOS NEWELTS COPYFN SKETCH COPYARGS COPYPLACEDYETFLG) (* call PRECOPYFN.) @@ -3360,12 +3382,12 @@ This will be slow for arcs and curves."] [COND ((EQ DELTAPOS 'DON'T) (RETURN)) - ((POSITIONP DELTAPOS) - - (* PRECOPYFN returned a position, don't bother to check for multiple copies.) - - (* value returned is the delta by which to move the point. - Set up new position) + ((POSITIONP DELTAPOS) (* PRECOPYFN returned a position, + don't bother to check for multiple + copies.) + + (* value returned is the delta by which to move the point. + Set up new position) (RETURN (SK.ADD.COPY.OF.ELEMENTS SKW SCRELTS (OR COPYARGS (SETQ COPYARGS ( @@ -3378,9 +3400,9 @@ This will be slow for arcs and curves."] (SETQ GHOTSPOT (GETSKETCHELEMENTPROP (fetch (SCREENELT GLOBALPART) of (CAR SCRELTS)) 'POSITION)) - - (* move the image by the first hotspot of the first element chosen. - This will align the image on the grid correctly.) + + (* move the image by the first hotspot of the first element chosen. + This will align the image on the grid correctly.) PLACECOPYLP (COND @@ -3402,19 +3424,18 @@ This will be slow for arcs and curves."] ] SKW)) (CLOSEPROMPTWINDOW SKW)) - (COPYPLACEDYETFLG - - (* already one copy down, close prompt window so user knows copy mode is over.) - + (COPYPLACEDYETFLG (* already one copy down, close prompt + window so user knows copy mode is + over.) (CLOSEPROMPTWINDOW SKW) (RETURN NIL)) (T (STATUSPRINT SKW "Position was outside the window. Copy not placed.") (RETURN NIL))) [SETQ DELTAPOS (create POSITION - XCOORD _ (DIFFERENCE (fetch (POSITION XCOORD) + XCOORD ↠(DIFFERENCE (fetch (POSITION XCOORD) of NEWGPOS) (fetch (POSITION XCOORD) of GHOTSPOT)) - YCOORD _ (DIFFERENCE (fetch (POSITION YCOORD) + YCOORD ↠(DIFFERENCE (fetch (POSITION YCOORD) of NEWGPOS) (fetch (POSITION YCOORD) of GHOTSPOT] (SK.ADD.COPY.OF.ELEMENTS SKW SCRELTS (OR COPYARGS (SETQ COPYARGS ( @@ -3428,10 +3449,10 @@ This will be slow for arcs and curves."] (T (CLOSEPROMPTWINDOW SKW]) (SK.ADD.COPY.OF.ELEMENTS - [LAMBDA (VIEWER SCRELEMENTS GLOBALELEMENTS NEWPOSDELTA) (* rrb " 1-Oct-86 19:13") - - (* internal function for copying elements. - Adds a copy of SCRELEMENTS moved by NEWPOSDELTA to VIEWER and calls the copyfn.) + [LAMBDA (VIEWER SCRELEMENTS GLOBALELEMENTS NEWPOSDELTA) (* rrb " 1-Oct-86 19:13") + + (* internal function for copying elements. + Adds a copy of SCRELEMENTS moved by NEWPOSDELTA to VIEWER and calls the copyfn.) (PROG (SKETCH NEWELTS COPYFN X) (AND (SETQ COPYFN (GETSKETCHPROP (SETQ SKETCH (INSURE.SKETCH VIEWER)) @@ -3440,11 +3461,8 @@ This will be slow for arcs and curves."] (COND ((EQ X 'DON'T) (RETURN)) - ((POSITIONP X) - - (* value returned is the position to put the copy. - Set up new position) - + ((POSITIONP X) (* value returned is the position to + put the copy. Set up new position) (SETQ NEWPOSDELTA X))) [SETQ NEWELTS (SK.SORT.GELTS.BY.PRIORITY (COND ((AND (LISTP X) @@ -3461,35 +3479,32 @@ This will be slow for arcs and curves."] (SK.ADD.HISTEVENT 'COPY NEWELTS VIEWER]) (SK.GLOBAL.FROM.LOCAL.ELEMENTS - [LAMBDA (SCRELTS) - - (* returns the global elements from a list of screen elements) - + [LAMBDA (SCRELTS) (* returns the global elements from a + list of screen elements) (for SCRELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.COPY.ITEM - [LAMBDA (SELELT GLOBALDELTAPOS W) (* rrb "24-Jun-87 15:12") - - (* SELELT is a sketch element that was selected for a copy operation. - GLOBALDELTAPOS is the amount the new item is to be offset from the old.) + [LAMBDA (SELELT GLOBALDELTAPOS W) (* rrb "24-Jun-87 15:12") + + (* SELELT is a sketch element that was selected for a copy operation. + GLOBALDELTAPOS is the amount the new item is to be offset from the old.) (PROG ((OLDGLOBAL (fetch (SCREENELT GLOBALPART) of SELELT))) [COND ((EQ (fetch (GLOBALPART GTYPE) of OLDGLOBAL) 'SKIMAGEOBJ) - - (* copying an image obj. Don't call its when copied fn. - was changed to call the WHENINSERTEDFN instead when it acutally gets - inserted.) + + (* copying an image obj. Don't call its when copied fn. + was changed to call the WHENINSERTEDFN instead when it acutally gets inserted.) (SETQ OLDGLOBAL (SK.COPY.IMAGEOBJ OLDGLOBAL W] (RETURN (SK.TRANSLATE.GLOBALPART OLDGLOBAL GLOBALDELTAPOS]) (SK.INSERT.SKETCH - [LAMBDA (W SKETCH REGION SCALE) (* rrb "30-Sep-86 18:29") - - (* * inserts the sketch SKETCH into the sketch window W. - Called by the copy insert function for sketch windows.) + [LAMBDA (W SKETCH REGION SCALE) (* rrb "30-Sep-86 18:29") + + (* * inserts the sketch SKETCH into the sketch window W. + Called by the copy insert function for sketch windows.) (AND SKETCH (PROG (LOCALSCRELTS FIGINFO FIRSTHOTSPOT LOWLFT NEWPOS WINDOWSCALE NEWELTS) (* map inserted elements into new @@ -3498,7 +3513,7 @@ This will be slow for arcs and curves."] ([NOT (EQUAL SCALE (SETQ WINDOWSCALE (VIEWER.SCALE W] (* change the scale of the sketch and  the region.) - [SETQ SKETCH (create SKETCH using SKETCH SKETCHELTS _ + [SETQ SKETCH (create SKETCH using SKETCH SKETCHELTS ↠(SK.TRANSFORM.GLOBAL.ELEMENTS (fetch (SKETCH SKETCHELTS) of SKETCH) (FUNCTION @@ -3510,9 +3525,9 @@ This will be slow for arcs and curves."] (SETQ FIGINFO (SK.FIGUREIMAGE LOCALSCRELTS REGION)) [SETQ FIRSTHOTSPOT (CAR (fetch (SCREENELT HOTSPOTS) of (CAR LOCALSCRELTS] (SETQ LOWLFT (fetch (SKFIGUREIMAGE SKFIGURE.LOWERLEFT) of FIGINFO)) - - (* move the image by the first hotspot of the first element chosen. - This will align the image on the grid correctly.) + + (* move the image by the first hotspot of the first element chosen. + This will align the image on the grid correctly.) (COND ([SETQ NEWPOS (fetch (INPUTPT INPUT.POSITION) @@ -3534,11 +3549,11 @@ This will be slow for arcs and curves."] (SETQ NEWELTS (MAPCOLLECTSKETCHSPECS LOCALSCRELTS (FUNCTION SK.COPY.ITEM) (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID (create POSITION - XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) + XCOORD ↠(IDIFFERENCE (fetch (POSITION XCOORD) of NEWPOS) (fetch (POSITION XCOORD) of FIRSTHOTSPOT)) - YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) + YCOORD ↠(IDIFFERENCE (fetch (POSITION YCOORD) of NEWPOS) (fetch (POSITION YCOORD) of FIRSTHOTSPOT))) @@ -3556,37 +3571,35 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.MOVE.ELT - [LAMBDA (W) (* rrb "31-Jan-86 10:49") - - (* lets the user select one or more elements and move them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:49") + (* lets the user select one or more + elements and move them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE (KWOTE W)) W]) (SK.MOVE.ELT.OR.PT - [LAMBDA (W) (* rrb "31-Jan-86 10:49") - - (* lets the user select one or more elements and move them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:49") + (* lets the user select one or more + elements and move them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE (KWOTE W) T) W]) (SK.APPLY.DEFAULT.MOVE - [LAMBDA (W) (* rrb " 2-Jun-85 12:52") - - (* applies the default move mode which can be either points, elements or both.) - + [LAMBDA (W) (* rrb " 2-Jun-85 12:52") + (* applies the default move mode which + can be either points, elements or + both.) (SELECTQ (fetch (SKETCHCONTEXT SKETCHMOVEMODE) of (WINDOWPROP W 'SKETCHCONTEXT)) (POINTS (SK.MOVE.POINTS W)) (ELEMENTS (SK.MOVE.ELT W)) (SK.MOVE.ELT.OR.PT W]) (SK.SEL.AND.MOVE - [LAMBDA (W PTFLG) (* rrb "10-Dec-85 17:06") - - (* lets the user select either a control point or one or more elements and move - them.) + [LAMBDA (W PTFLG) (* rrb "10-Dec-85 17:06") + + (* lets the user select either a control point or one or more elements and move + them.) (SK.MOVE.ELEMENTS [COND ((EQ PTFLG 'ONLY) @@ -3597,7 +3610,7 @@ This will be slow for arcs and curves."] W]) (SK.MOVE.ELEMENTS - [LAMBDA (SCRELTS SKW) (* rrb "11-Jul-86 15:51") + [LAMBDA (SCRELTS SKW) (* rrb "11-Jul-86 15:51") (SKED.CLEAR.SELECTION SKW) (COND ((NULL SCRELTS)) @@ -3616,16 +3629,14 @@ This will be slow for arcs and curves."] GLOBALPART) of SCRELT) 'MOVE)) do (RETURN SCRELT] - - (* only protected elements at this point, shouldn't happen but don't cause an - error.) - + (* only protected elements at this + point, shouldn't happen but don't + cause an error.) (RETURN NIL))) [COND ([NULL (SETQ OTHERHOTSPOTS (REMOVE SCRELTS (fetch (SCREENELT HOTSPOTS) of SKETCHELT] - - (* only one control point, move it with the move element function.) - + (* only one control point, move it + with the move element function.) (RETURN (SK.MOVE.ELEMENTS (LIST SKETCHELT) SKW] (* call sketch premovefn if given.) [AND (SETQ MOVEFN (GETSKETCHPROP (SETQ SKETCH (INSURE.SKETCH SKW)) @@ -3636,9 +3647,9 @@ This will be slow for arcs and curves."] ((EQ GDELTAPOS 'DON'T) (RETURN)) ((POSITIONP GDELTAPOS) - - (* value returned is the delta by which to move the point. - Set up new position) + + (* value returned is the delta by which to move the point. + Set up new position) NIL) (T (* read new position from the user) @@ -3653,12 +3664,12 @@ This will be slow for arcs and curves."]  selected point moves.) (SETQ GDELTAPOS (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID (create POSITION - XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) + XCOORD ↠(IDIFFERENCE (fetch (POSITION XCOORD) of (fetch (INPUTPT INPUT.POSITION) of NEWPOS)) (fetch (POSITION XCOORD) of SCRELTS)) - YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) + YCOORD ↠(IDIFFERENCE (fetch (POSITION YCOORD) of (fetch (INPUTPT INPUT.POSITION) of NEWPOS)) @@ -3672,14 +3683,17 @@ This will be slow for arcs and curves."] ((EQ X 'DON'T) (RETURN)) ((POSITIONP X) - - (* value returned is the delta by which to move the point. - Set up new position) + + (* value returned is the delta by which to move the point. + Set up new position) (SETQ GDELTAPOS X))) (RETURN (SK.MOVE.THING SKETCHELT SCRELTS GDELTAPOS SKW] - (T (* create a bitmap of the thing being moved and get its new position. - Then translate all the pieces.) + (T + + (* create a bitmap of the thing being moved and get its new position. + Then translate all the pieces.) + (PROG (FIGINFO FIRSTHOTSPOT NEWPOS LOWLFT IMAGEPOSX IMAGEPOSY IMAGEBM DELTAPOS CHANGES MOVEFN X GDELTAPOS) [AND (SETQ MOVEFN (GETSKETCHPROP (INSURE.SKETCH SKW) @@ -3689,9 +3703,9 @@ This will be slow for arcs and curves."] ((EQ GDELTAPOS 'DON'T) (RETURN)) ((POSITIONP GDELTAPOS) - - (* value returned is the delta by which to move the point. - Set up new position) + + (* value returned is the delta by which to move the point. + Set up new position) NIL) (T (* read new position from the user) @@ -3699,9 +3713,9 @@ This will be slow for arcs and curves."] [SETQ FIRSTHOTSPOT (CAR (fetch (SCREENELT HOTSPOTS) of (CAR SCRELTS] (SETQ IMAGEBM (fetch (SKFIGUREIMAGE SKFIGURE.BITMAP) of FIGINFO)) (SETQ LOWLFT (fetch (SKFIGUREIMAGE SKFIGURE.LOWERLEFT) of FIGINFO)) - - (* move the image by the first hotspot of the first element chosen. - This will align the image on the grid correctly.) + + (* move the image by the first hotspot of the first element chosen. + This will align the image on the grid correctly.) (SETQ IMAGEPOSX (fetch (POSITION XCOORD) of LOWLFT)) (SETQ IMAGEPOSY (fetch (POSITION YCOORD) of LOWLFT)) @@ -3728,19 +3742,19 @@ This will be slow for arcs and curves."] (SK.SHOW.FIG.FROM.INFO IMAGEBM IMAGEPOSX IMAGEPOSY 'PAINT SKW) (STATUSPRINT SKW "Position was outside the window, copy not placed.") (RETURN NIL))) - - (* GET.BITMAP.POSITION returns the position that the cursor was in which is the - position of the first hotspot.) + + (* GET.BITMAP.POSITION returns the position that the cursor was in which is the + position of the first hotspot.) (* calculate the delta that the  selected point moves.) (SETQ GDELTAPOS (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID [SETQ DELTAPOS (create POSITION - XCOORD _ (IDIFFERENCE + XCOORD ↠(IDIFFERENCE (fetch (POSITION XCOORD) of NEWPOS) (fetch (POSITION XCOORD) of FIRSTHOTSPOT)) - YCOORD _ (IDIFFERENCE + YCOORD ↠(IDIFFERENCE (fetch (POSITION YCOORD) of NEWPOS) (fetch (POSITION YCOORD) @@ -3749,24 +3763,24 @@ This will be slow for arcs and curves."] (SKETCH.MOVE.ELEMENTS (for ELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of ELT)) GDELTAPOS SKW T) - - (* I started noticing cases where the image was a point off on some lines and - where the texture alignment was off so I removed this - (COND ((AND DELTAPOS (NOT (POSITIONP X))) - (* If the user was asked for a new position and the movefn didn't change it, - redraw the image in case any of it was erased by the calls to SK.TRANSLATE.ITEM) - (SK.SHOW.FIG.FROM.INFO IMAGEBM (IPLUS IMAGEPOSX - (fetch (POSITION XCOORD) of DELTAPOS)) (IPLUS IMAGEPOSY - (fetch (POSITION YCOORD) of DELTAPOS)) (QUOTE PAINT) SKW)))) + + (* I started noticing cases where the image was a point off on some lines and + where the texture alignment was off so I removed this + (COND ((AND DELTAPOS (NOT (POSITIONP X))) + (* If the user was asked for a new position and the movefn didn't change it, + redraw the image in case any of it was erased by the calls to SK.TRANSLATE.ITEM) + (SK.SHOW.FIG.FROM.INFO IMAGEBM (IPLUS IMAGEPOSX + (fetch (POSITION XCOORD) of DELTAPOS)) (IPLUS IMAGEPOSY + (fetch (POSITION YCOORD) of DELTAPOS)) (QUOTE PAINT) SKW)))) (CLOSEPROMPTWINDOW SKW]) (SKETCH.MOVE.ELEMENTS - [LAMBDA (ELEMENTS DELTA SKETCHTOUPDATE ADDHISTORY?) (* rrb " 2-Oct-86 11:09") - - (* moves the elements ELEMENTS by the amount of position DELTA - (XCOORD gives x amount, YCOORD gives y delta) and updates the viewers on - SKETCHTOUPDATE if it is given.) + [LAMBDA (ELEMENTS DELTA SKETCHTOUPDATE ADDHISTORY?) (* rrb " 2-Oct-86 11:09") + + (* moves the elements ELEMENTS by the amount of position DELTA + (XCOORD gives x amount, YCOORD gives y delta) and updates the viewers on + SKETCHTOUPDATE if it is given.) (PROG (X MOVEFN NEWGLOBALS SKETCH GDELTAPOS VIEWER) (OR (POSITIONP DELTA) @@ -3775,9 +3789,9 @@ This will be slow for arcs and curves."] (SETQ VIEWER (SK.VIEWER.FROM.SKETCH.ARG SKETCHTOUPDATE))) (COND [[AND SKETCH (SETQ MOVEFN (GETSKETCHPROP SKETCH 'WHENMOVEDFN] - - (* call the WHENMOVEDFN if any Pass the thing the user passed in if you can't - find a viewer.) + + (* call the WHENMOVEDFN if any Pass the thing the user passed in if you can't + find a viewer.) (COND ((EQ (SETQ X (APPLY* MOVEFN VIEWER (for ELT in ELEMENTS @@ -3786,9 +3800,9 @@ This will be slow for arcs and curves."] 'DON'T) (RETURN)) ((POSITIONP X) - - (* value returned is the delta by which to move the point. - Set up new position) + + (* value returned is the delta by which to move the point. + Set up new position) (SETQ GDELTAPOS X)) (T (SETQ GDELTAPOS DELTA] @@ -3803,11 +3817,11 @@ This will be slow for arcs and curves."] (RETURN NEWGLOBALS]) (SKETCH.COPY.ELEMENTS - [LAMBDA (ELEMENTS SKETCHTOUPDATE DELTA ADDHISTORY?) (* rrb "15-Dec-86 15:58") - - (* copies the elements ELEMENTS moving them by the amount of position DELTA - (XCOORD gives x amount, YCOORD gives y delta) and updates the viewers on - SKETCHTOUPDATE if it is given.) + [LAMBDA (ELEMENTS SKETCHTOUPDATE DELTA ADDHISTORY?) (* rrb "15-Dec-86 15:58") + + (* copies the elements ELEMENTS moving them by the amount of position DELTA + (XCOORD gives x amount, YCOORD gives y delta) and updates the viewers on + SKETCHTOUPDATE if it is given.) (PROG (X COPYFN NEWGLOBALS SKETCH GDELTAPOS VIEWER) (COND @@ -3819,18 +3833,18 @@ This will be slow for arcs and curves."] (SETQ VIEWER (SK.VIEWER.FROM.SKETCH.ARG SKETCHTOUPDATE))) (COND [[AND SKETCH (SETQ COPYFN (GETSKETCHPROP SKETCH 'WHENCOPIEDFN] - - (* call the WHENCOPIEFN if any Pass the thing the user passed in if you can't - find a viewer.) + + (* call the WHENCOPIEFN if any Pass the thing the user passed in if you can't + find a viewer.) (COND ((EQ (SETQ X (APPLY* COPYFN VIEWER ELEMENTS DELTA)) 'DON'T) (RETURN)) ((POSITIONP X) - - (* value returned is the delta by which to move the point. - Set up new position) + + (* value returned is the delta by which to move the point. + Set up new position) (SETQ GDELTAPOS X)) (T (SETQ GDELTAPOS DELTA] @@ -3846,24 +3860,24 @@ This will be slow for arcs and curves."] (RETURN NEWGLOBALS]) (\SKETCH.COPY.ELEMENT - [LAMBDA (GLOBALELEMENT GLOBALDELTAPOS W) (* rrb "24-Jun-87 15:05") - - (* SELELT is a sketch element that was selected for a copy operation. - GLOBALDELTAPOS is the amount the new item is to be offset from the old.) + [LAMBDA (GLOBALELEMENT GLOBALDELTAPOS W) (* rrb "24-Jun-87 15:05") + + (* SELELT is a sketch element that was selected for a copy operation. + GLOBALDELTAPOS is the amount the new item is to be offset from the old.) (COND ((EQ (fetch (GLOBALPART GTYPE) of GLOBALELEMENT) 'SKIMAGEOBJ) (* copying an image obj. - Calls its when copied fn.) + Calls its when copied fn.) (SK.TRANSLATE.GLOBALPART (SK.COPY.IMAGEOBJ GLOBALELEMENT W) GLOBALDELTAPOS)) (T (SK.TRANSLATE.GLOBALPART GLOBALELEMENT GLOBALDELTAPOS]) (SK.TRANSLATE.ELEMENT - [LAMBDA (GELT GLOBALDELTAPOS W) (* rrb "25-Sep-86 15:16") - - (* * GELT is a sketch element to be moved. - GLOBALDELTAPOS is the amount the item is to be translated.) + [LAMBDA (GELT GLOBALDELTAPOS W) (* rrb "25-Sep-86 15:16") + + (* * GELT is a sketch element to be moved. + GLOBALDELTAPOS is the amount the item is to be translated.) (PROG (NEWGLOBAL) (COND @@ -3877,31 +3891,31 @@ This will be slow for arcs and curves."] T]) (SK.MAKE.ELEMENT.MOVE.ARG - [LAMBDA (SCRELT SELPOS) (* rrb " 5-Nov-85 14:35") - - (* makes an argument structure that is suitable to be passed to the sketch - movefn. This is a list whose CAR is a list of the numbers of the control points - being moved and whose CDR is the global sketch element.) + [LAMBDA (SCRELT SELPOS) (* rrb " 5-Nov-85 14:35") + + (* makes an argument structure that is suitable to be passed to the sketch + movefn. This is a list whose CAR is a list of the numbers of the control points + being moved and whose CDR is the global sketch element.) (CONS (CONS (for I from 1 as PT in (fetch (SCREENELT HOTSPOTS) of SCRELT) when (EQUAL PT SELPOS) do (RETURN I))) (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.MAKE.ELEMENTS.MOVE.ARG - [LAMBDA (SCRELTS) (* rrb " 5-Nov-85 14:34") - - (* makes an argument structure that is suitable to be passed to the sketch - movefn. This is a list whose CAR is a list of the numbers of the control points - being moved which is in this case T and whose CDR is the global sketch element.) + [LAMBDA (SCRELTS) (* rrb " 5-Nov-85 14:34") + + (* makes an argument structure that is suitable to be passed to the sketch + movefn. This is a list whose CAR is a list of the numbers of the control points + being moved which is in this case T and whose CDR is the global sketch element.) (CONS T (for SCRELT in SCRELTS collect (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.MAKE.POINTS.AND.ELEMENTS.MOVE.ARG - [LAMBDA (SCRELTS SELPTS) (* rrb "21-Jan-86 17:38") - - (* makes an argument structure that is suitable to be passed to the sketch - movefn. This is a list of lists each of whose CAR is a list of the numbers of - the control points being moved and whose CDR is the global sketch element.) + [LAMBDA (SCRELTS SELPTS) (* rrb "21-Jan-86 17:38") + + (* makes an argument structure that is suitable to be passed to the sketch + movefn. This is a list of lists each of whose CAR is a list of the numbers of the + control points being moved and whose CDR is the global sketch element.) (for SCRELT in SCRELTS collect (CONS (bind NOTALL for I from 1 as PT in (fetch (SCREENELT HOTSPOTS) of SCRELT) @@ -3913,13 +3927,13 @@ This will be slow for arcs and curves."] (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.SHOW.FIG.FROM.INFO - [LAMBDA (IMAGEBM XOFFSET YOFFSET OPERATION WINDOW) (* rrb "14-Nov-84 14:20") + [LAMBDA (IMAGEBM XOFFSET YOFFSET OPERATION WINDOW) (* rrb "14-Nov-84 14:20") (* puts a bitmap onto the sketch  window.) (BITBLT IMAGEBM 0 0 WINDOW XOFFSET YOFFSET NIL NIL 'INPUT OPERATION]) (SK.MOVE.THING - [LAMBDA (SKETCHELT LOCALPT GDELTAPOS SKW) (* rrb "27-Jun-86 14:04") + [LAMBDA (SKETCHELT LOCALPT GDELTAPOS SKW) (* rrb "27-Jun-86 14:04") (* moves a control point in a sketch  element.) (PROG (OLDGLOBAL NEWGLOBAL) (* calculate the delta that the @@ -3933,26 +3947,26 @@ This will be slow for arcs and curves."] (RETURN NEWGLOBAL]) (UPDATE.ELEMENT.IN.SKETCH - [LAMBDA (OLDGELT NEWGELT SKETCH SKW DONTUPDATEPRIORITYFLG) (* rrb "26-Sep-86 13:35") + [LAMBDA (OLDGELT NEWGELT SKETCH SKW DONTUPDATEPRIORITYFLG) (* rrb "26-Sep-86 13:35") (* changes the global sketch) - - (* returns NIL if the old global sketch element is not found in SKETCH. - This can happen if things are undone out of order.) + + (* returns NIL if the old global sketch element is not found in SKETCH. + This can happen if things are undone out of order.) (PROG ((SKETCHSTRUCTURE (INSURE.SKETCH SKETCH)) SKETCHELEMENTS) - - (* if old and new are the same, the change was done destructively; - otherwise clobber the new one in.) + + (* if old and new are the same, the change was done destructively; + otherwise clobber the new one in.) [COND ((EQ OLDGELT NEWGELT)) ((OR (NULL DONTUPDATEPRIORITYFLG) (EQ (SK.ELEMENT.PRIORITY OLDGELT) (SK.ELEMENT.PRIORITY NEWGELT))) - - (* same priorities so just clobber the old elements place in the list with the - new one.) + + (* same priorities so just clobber the old elements place in the list with the + new one.) (OR (for GELTTAIL on (fetch (SKETCH SKETCHELTS) of SKETCHSTRUCTURE) when (EQ (CAR GELTTAIL) @@ -3964,9 +3978,9 @@ This will be slow for arcs and curves."] (RETURN T)) (RETURN))) (T - - (* priority has changed so order of this element in the list may need to be - changed.) + + (* priority has changed so order of this element in the list may need to be + changed.) (REMOVE.ELEMENT.FROM.SKETCH OLDGELT SKETCHSTRUCTURE) (SK.ADD.PRIORITY.ELEMENT.TO.SKETCH SKETCHSTRUCTURE NEWGELT (SK.ELEMENT.PRIORITY @@ -3975,19 +3989,19 @@ This will be slow for arcs and curves."] (RETURN T]) (SK.UPDATE.ELEMENT - [LAMBDA (OLDGLOBAL NEWGLOBAL SKETCHW REDRAWIFSAMEFLG DONTUPDATEPRIORITYFLG DONTDISPLAYFLG) + [LAMBDA (OLDGLOBAL NEWGLOBAL SKETCHW REDRAWIFSAMEFLG DONTUPDATEPRIORITYFLG DONTDISPLAYFLG) (* rrb "24-Sep-86 17:32") - - (* replaces an old element with a new one. - The global part of the old one may be the same as the new global part. - This also handles propagation to other windows that have the same figure - displayed.) + + (* replaces an old element with a new one. + The global part of the old one may be the same as the new global part. + This also handles propagation to other windows that have the same figure + displayed.) (PROG ((SKETCH (SKETCH.FROM.VIEWER SKETCHW)) UPDATEDELT) - - (* update the element in the sketch first. - If this returns NIL, the element was not found in the sketch.) + + (* update the element in the sketch first. + If this returns NIL, the element was not found in the sketch.) (OR (UPDATE.ELEMENT.IN.SKETCH OLDGLOBAL NEWGLOBAL SKETCH SKETCHW DONTUPDATEPRIORITYFLG) (RETURN NIL)) (* do the window that the interaction @@ -3996,19 +4010,19 @@ This will be slow for arcs and curves."] DONTDISPLAYFLG)) (* propagate to other windows.) (for SKW in (ALL.SKETCH.VIEWERS SKETCH) when (NEQ SKW SKETCHW) do - - (* the position may have changed which means that it may have moved in or out - of a viewer.) + + (* the position may have changed which means that it may have moved in or out of + a viewer.) (SK.UPDATE.ELEMENT1 OLDGLOBAL NEWGLOBAL SKW REDRAWIFSAMEFLG DONTDISPLAYFLG)) (RETURN UPDATEDELT]) (SK.UPDATE.ELEMENTS - [LAMBDA (CHANGEEVENTS WINDOW DONTUPDATEPRIORITYFLG DONTDISPLAYFLG) + [LAMBDA (CHANGEEVENTS WINDOW DONTUPDATEPRIORITYFLG DONTDISPLAYFLG) (* rrb "24-Sep-86 17:32") - - (* replaces the global parts of a list of change events and handles updating - the screen.) + + (* replaces the global parts of a list of change events and handles updating the + screen.) (for CHANGEEVENT in CHANGEEVENTS do (SK.UPDATE.ELEMENT (fetch (SKHISTORYCHANGESPEC OLDELT) of CHANGEEVENT) @@ -4016,32 +4030,29 @@ This will be slow for arcs and curves."] WINDOW NIL DONTUPDATEPRIORITYFLG DONTDISPLAYFLG]) (SK.UPDATE.ELEMENT1 - [LAMBDA (OLDGELT NEWGELT SKETCHW REDRAWIFSAME DONTDISPLAYFLG) + [LAMBDA (OLDGELT NEWGELT SKETCHW REDRAWIFSAME DONTDISPLAYFLG) (* rrb "24-Sep-86 17:32") - - (* determines what action is needed wrt the viewer SKETCHW when the element - OLDGELT is updated to NEWGELT. This works only in the given window.) + + (* determines what action is needed wrt the viewer SKETCHW when the element + OLDGELT is updated to NEWGELT. This works only in the given window.) (PROG (LOCALELT UPDATEFN NEWLOCAL) (COND [(SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART OLDGELT SKETCHW)) (COND - (DONTDISPLAYFLG - - (* just do the update in the datastructure, don't change the display) - + (DONTDISPLAYFLG (* just do the update in the + datastructure, don't change the + display) (SK.DELETE.ITEM LOCALELT SKETCHW) (RETURN (SK.ADD.ITEM NEWGELT SKETCHW))) ((EQ (SKETCH.ELEMENT.TYPE OLDGELT) - 'SKIMAGEOBJ) - - (* handle imageobject case specially because changes are often in internal - structure) - + 'SKIMAGEOBJ) (* handle imageobject case specially + because changes are often in internal + structure) (SK.DELETE.ITEM LOCALELT SKETCHW) - - (* erase the old image region because often the internal parts of the image - object have been clobbered making it impossible to erase by redrawing) + + (* erase the old image region because often the internal parts of the image + object have been clobbered making it impossible to erase by redrawing) (DSPFILL (fetch (LOCALSKIMAGEOBJ SKIMOBJLOCALREGION) of (fetch (SCREENELT LOCALPART ) @@ -4052,36 +4063,35 @@ This will be slow for arcs and curves."] [[AND (EQUAL OLDGELT NEWGELT) (NOT (MEMB (fetch (GLOBALPART GTYPE) of OLDGELT) '(TEXT TEXTBOX] - - (* text and textbox are special because interactive editing reuses the same - element after the first character but they need to use updatefns for speed.) - - (* replacing something by something else that is identical. - Check here because add will not add something that is already there and - updatefn may call add first.) + + (* text and textbox are special because interactive editing reuses the same + element after the first character but they need to use updatefns for speed.) + + (* replacing something by something else that is identical. + Check here because add will not add something that is already there and updatefn + may call add first.) (COND (REDRAWIFSAME - - (* this entry is used from the WB.BUTTON.HANDLER and deals with image objects - which we have no control over whether they give us something new or not.) + + (* this entry is used from the WB.BUTTON.HANDLER and deals with image objects + which we have no control over whether they give us something new or not.) (SK.ERASE.AND.DELETE.ITEM LOCALELT SKETCHW)) (T (SK.DELETE.ITEM LOCALELT SKETCHW) (RETURN (SK.ADD.ITEM NEWGELT SKETCHW] ((AND (SETQ UPDATEFN (SK.UPDATEFN (fetch (GLOBALPART GTYPE) of NEWGELT))) (SETQ NEWLOCAL (APPLY* UPDATEFN LOCALELT NEWGELT SKETCHW))) - - (* if the old one is visible and the element has an updatefn, use it to update - the display. Then delete the old one. The updatefn should have added the new - one.) + + (* if the old one is visible and the element has an updatefn, use it to update + the display. Then delete the old one. The updatefn should have added the new one.) (SK.DELETE.ITEM LOCALELT SKETCHW) (RETURN NEWLOCAL)) (T - - (* if this type doesn't have a updatefn or it returned NIL, do the erase and - redraw method.) + + (* if this type doesn't have a updatefn or it returned NIL, do the erase and + redraw method.) (SK.ERASE.AND.DELETE.ITEM LOCALELT SKETCHW] ((NOT (MEMB NEWGELT (SKETCH.ELEMENTS.OF.SKETCH SKETCHW))) @@ -4093,7 +4103,7 @@ This will be slow for arcs and curves."] (SKETCH.ADD.AND.DISPLAY1 NEWGELT SKETCHW]) (SK.MOVE.ELEMENT.POINT - [LAMBDA (W) (* rrb "31-Jan-86 10:50") + [LAMBDA (W) (* rrb "31-Jan-86 10:50") (* lets the user select an element and  move it.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE (KWOTE W) @@ -4108,23 +4118,22 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.MOVE.POINTS - [LAMBDA (W) (* rrb "31-Jan-86 10:50") - - (* lets the user select a collection of points and move them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:50") + (* lets the user select a collection + of points and move them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE.POINTS (KWOTE W)) W]) (SK.SEL.AND.MOVE.POINTS - [LAMBDA (W) (* rrb "17-Oct-85 11:11") - - (* * lets the user select a collection of control point and moves them.) + [LAMBDA (W) (* rrb "17-Oct-85 11:11") + + (* * lets the user select a collection of control point and moves them.) (SK.DO.MOVE.ELEMENT.POINTS (SK.SELECT.MULTIPLE.POINTS W) W]) (SK.DO.MOVE.ELEMENT.POINTS - [LAMBDA (SCRPTS SKW) (* rrb "30-Sep-86 18:33") + [LAMBDA (SCRPTS SKW) (* rrb "30-Sep-86 18:33") (* moves a collection of points) (SKED.CLEAR.SELECTION SKW) (AND SCRPTS @@ -4140,16 +4149,16 @@ This will be slow for arcs and curves."] ((EQ GDELTAPOS 'DON'T) (RETURN)) ((POSITIONP GDELTAPOS) - - (* value returned is the delta by which to move the point. - Set up new position) + + (* value returned is the delta by which to move the point. + Set up new position) NIL) (T (* read new position from the user) - - (* create a bitmap of all of the elements that have any point being moved and - get its new position. Use only the region that contains the points. - points plus a boarder to catch the lines of a box as large as the region.) + + (* create a bitmap of all of the elements that have any point being moved and get + its new position. Use only the region that contains the points. + points plus a boarder to catch the lines of a box as large as the region.) (SETQ NONMOVEDHOTSPOTS (SK.HOTSPOTS.NOT.ON.LIST SCRPTS SCRELTS)) [SETQ ONEPTELTS (SUBSET SCRELTS (FUNCTION (LAMBDA (ELT) @@ -4162,9 +4171,9 @@ This will be slow for arcs and curves."] (SETQ FIGINFO (SK.FIGUREIMAGE SCRELTS NIL (INCREASEREGION (COND (ONEPTELTS - - (* include the regions of any elements that only have one control point. - This picks up text and groups whose image is much larger than the point.) + + (* include the regions of any elements that only have one control point. + This picks up text and groups whose image is much larger than the point.) (SK.UNIONREGIONS (REGION.CONTAINING.PTS @@ -4178,9 +4187,9 @@ This will be slow for arcs and curves."] (SETQ FIRSTHOTSPOT (CAR SCRPTS)) (SETQ LOWLFT (fetch (SKFIGUREIMAGE SKFIGURE.LOWERLEFT) of FIGINFO)) (SETQ IMAGEBM (fetch (SKFIGUREIMAGE SKFIGURE.BITMAP) of FIGINFO)) - - (* move the image by the first hotspot of the first element chosen. - This will align the image on the grid correctly.) + + (* move the image by the first hotspot of the first element chosen. + This will align the image on the grid correctly.) (SETQ IMAGEPOSX (fetch (POSITION XCOORD) of LOWLFT)) (SETQ IMAGEPOSY (fetch (POSITION YCOORD) of LOWLFT)) @@ -4211,18 +4220,18 @@ This will be slow for arcs and curves."] (for PT in NONMOVEDHOTSPOTS do (MARKPOINT PT SKW OTHERCONTROLPOINTMARK)) (STATUSPRINT SKW "Position was outside the window, copy not placed.") (RETURN NIL))) - - (* GET.BITMAP.POSITION returns the position that the cursor was in which is the - position of the first hotspot.) + + (* GET.BITMAP.POSITION returns the position that the cursor was in which is the + position of the first hotspot.) (for PT in NONMOVEDHOTSPOTS do (MARKPOINT PT SKW OTHERCONTROLPOINTMARK)) (SETQ GDELTAPOS (SK.MAP.FROM.WINDOW.TO.NEAREST.GRID (create POSITION - XCOORD _ (IDIFFERENCE (fetch (POSITION XCOORD) + XCOORD ↠(IDIFFERENCE (fetch (POSITION XCOORD) of NEWPOS) (fetch (POSITION XCOORD) of FIRSTHOTSPOT )) - YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) + YCOORD ↠(IDIFFERENCE (fetch (POSITION YCOORD) of NEWPOS) (fetch (POSITION YCOORD) of FIRSTHOTSPOT ))) @@ -4236,9 +4245,9 @@ This will be slow for arcs and curves."] ((EQ X 'DON'T) (RETURN)) ((POSITIONP X) - - (* value returned is the delta by which to move the point. - Set up new position) + + (* value returned is the delta by which to move the point. + Set up new position) (SETQ GDELTAPOS X))) (SETQ NEWGLOBALS (MAPCOLLECTSKETCHSPECS SCRELTS (FUNCTION SK.MOVE.ITEM.POINTS) @@ -4250,32 +4259,28 @@ This will be slow for arcs and curves."] (CLOSEPROMPTWINDOW SKW]) (SK.MOVE.ITEM.POINTS - [LAMBDA (SELELT GLOBALDELTAPOS W LOCALPTS) (* rrb "11-Jul-85 13:44") - - (* SELELT is a sketch element at least one of whose points was selected for a - translate operation. GLOBALDELTAPOS is the amount the item is to be translated. - LOCALPTS is the list of points that was selected. - This function moves any of those that belong to SELELT and return the new - global. If all of SELELT points are on LOCALPTS this is a SK.TRANSLATE.ITEM.) + [LAMBDA (SELELT GLOBALDELTAPOS W LOCALPTS) (* rrb "11-Jul-85 13:44") + + (* SELELT is a sketch element at least one of whose points was selected for a + translate operation. GLOBALDELTAPOS is the amount the item is to be translated. + LOCALPTS is the list of points that was selected. + This function moves any of those that belong to SELELT and return the new global. + If all of SELELT points are on LOCALPTS this is a SK.TRANSLATE.ITEM.) (PROG ((ELTHOTSPOTS (fetch (LOCALPART HOTSPOTS) of (fetch (SCREENELT LOCALPART) of SELELT))) - MOVEDPTS NEWGLOBAL OLDGLOBAL NEWSCREENELT) - - (* this shouldn't happen but don't cause an error if it does.) - + MOVEDPTS NEWGLOBAL OLDGLOBAL NEWSCREENELT) (* this shouldn't happen but don't + cause an error if it does.) (OR (SETQ MOVEDPTS (INTERSECTION ELTHOTSPOTS LOCALPTS)) (RETURN)) - - (* map the difference point onto a grid location that would have the same - screen distance but will leave things on a power of two.) + + (* map the difference point onto a grid location that would have the same screen + distance but will leave things on a power of two.) (SETQ OLDGLOBAL (fetch (SCREENELT GLOBALPART) of SELELT)) (COND ((EQ (LENGTH MOVEDPTS) - (LENGTH ELTHOTSPOTS)) - - (* all of its hot spots have been moved, just translate it) - + (LENGTH ELTHOTSPOTS)) (* all of its hot spots have been + moved, just translate it) (OR (SETQ NEWGLOBAL (SK.TRANSLATE.GLOBALPART OLDGLOBAL GLOBALDELTAPOS W)) (RETURN NIL))) ((SETQ NEWGLOBAL (SK.TRANSLATE.POINTS MOVEDPTS GLOBALDELTAPOS SELELT W))) @@ -4284,13 +4289,13 @@ This will be slow for arcs and curves."] (RETURN NEWGLOBAL]) (SK.TRANSLATEPTSFN - [LAMBDA (ELEMENTTYPE) (* rrb " 5-May-85 16:25") + [LAMBDA (ELEMENTTYPE) (* rrb " 5-May-85 16:25") (* goes from an element type name to  its EXPANDFN) (fetch (SKETCHTYPE TRANSLATEPTSFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.TRANSLATE.POINTS - [LAMBDA (SELPTS GLOBALDELTA SKETCHELT W) (* rrb " 6-May-86 11:01") + [LAMBDA (SELPTS GLOBALDELTA SKETCHELT W) (* rrb " 6-May-86 11:01") (* moves the selected points by a  global amount.) (AND SKETCHELT (PROG ((NEWGLOBAL (APPLY* (SK.TRANSLATEPTSFN (fetch (SCREENELT GTYPE) of SKETCHELT @@ -4302,9 +4307,9 @@ This will be slow for arcs and curves."] (RETURN NEWGLOBAL]) (SK.SELECT.MULTIPLE.POINTS - [LAMBDA (SKW) (* rrb "10-Dec-85 16:41") - - (* * allows the user to select a collection of control points.) + [LAMBDA (SKW) (* rrb "10-Dec-85 16:41") + + (* * allows the user to select a collection of control points.) (PROG ((INTERIOR (DSPCLIPPINGREGION NIL SKW)) SELECTABLEITEMS HOTSPOTCACHE NOW OLDX ORIGX NEWX NEWY OLDY ORIGY SELPTS PREVMOUSEBUTTONS @@ -4320,55 +4325,50 @@ This will be slow for arcs and curves."] (COND ((INSIDEP INTERIOR (LASTMOUSEX SKW) (LASTMOUSEY SKW))) - (T - - (* first press was outside of the window, don't select anything.) - + (T (* first press was outside of the + window, don't select anything.) (SK.TAKE.MARKS.DOWN SKW HOTSPOTCACHE) (RETURN))) SELECTLP (COND ((MOUSESTATE UP) (GO SHIFTDOWNLP))) - - (* this label provides an entry for the code that tests if the shift key is - down.) + + (* this label provides an entry for the code that tests if the shift key is down.) SELAFTERTEST (SETQ NEWY (LASTMOUSEY SKW)) (SETQ NEWX (LASTMOUSEX SKW)) [COND [(NOT MOUSEINSIDE?) - - (* mouse is outside, don't do anything other than wait for it to come back in. - If the user has let up all buttons, the branch to SELECTEXIT will have been - taken.) + + (* mouse is outside, don't do anything other than wait for it to come back in. + If the user has let up all buttons, the branch to SELECTEXIT will have been + taken.) (COND ((INSIDEP INTERIOR NEWX NEWY) (SETQ MOUSEINSIDE? T) (* restore the saved selected items.) (for ELT in SELPTS do (SK.ADD.PT.SELECTION ELT SKW] ((NOT (INSIDEP INTERIOR NEWX NEWY)) - - (* mouse just went outside, remove selections but save them in case mouse comes - back in.) + + (* mouse just went outside, remove selections but save them in case mouse comes + back in.) (SETQ MOUSEINSIDE? NIL) (SETQ SELPTS (WINDOWPROP SKW 'SKETCH.SELECTIONS)) (for ELT in SELPTS do (SK.REMOVE.PT.SELECTION ELT SKW))) [(NEQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) - - (* another button has gone down, mark this as the origin of a new box to sweep.) + + (* another button has gone down, mark this as the origin of a new box to sweep.) (SETQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ ORIGX (LASTMOUSEX SKW)) - (SETQ ORIGY (LASTMOUSEY SKW)) - - (* add or delete the element that the button press occurred on if any.) - + (SETQ ORIGY (LASTMOUSEY SKW)) (* add or delete the element that the + button press occurred on if any.) (AND (SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE (create POSITION - XCOORD _ NEWX - YCOORD _ NEWY) + XCOORD ↠NEWX + YCOORD ↠NEWY) T)) (COND ((LASTMOUSESTATE (ONLY LEFT)) (* add selection.) @@ -4380,10 +4380,8 @@ This will be slow for arcs and curves."] (SETQ SELPTS (SK.CONTROL.POINTS.IN.REGION HOTSPOTCACHE (MIN ORIGX NEWX) (MIN ORIGY NEWY) (MAX ORIGX NEWX) - (MAX ORIGY NEWY] - - (* add or delete any with in the swept out area.) - + (MAX ORIGY NEWY] (* add or delete any with in the swept + out area.) (COND ((LASTMOUSESTATE (ONLY LEFT)) (* left only selects.) (for SELPT in SELPTS do (SK.ADD.PT.SELECTION SELPT SKW))) @@ -4394,18 +4392,14 @@ This will be slow for arcs and curves."] (GO SELECTLP) SHIFTDOWNLP (COND - ((MOUSESTATE (NOT UP)) - - (* button went down again, initialize the button state and click position.) - + ((MOUSESTATE (NOT UP)) (* button went down again, initialize + the button state and click position.) (SETQ PREVMOUSEBUTTONS NIL) (GO SELAFTERTEST)) ((.SHIFTKEYDOWNP.) [COND - [(NOT MOUSEINSIDE?) - - (* mouse is outside%: if it comes back in, mark the selections.) - + [(NOT MOUSEINSIDE?) (* mouse is outside%: if it comes back + in, mark the selections.) (COND ((INSIDEP INTERIOR (LASTMOUSEX SKW) (LASTMOUSEY SKW)) @@ -4424,9 +4418,9 @@ This will be slow for arcs and curves."] (RETURN SELPTS]) (SK.CONTROL.POINTS.IN.REGION - [LAMBDA (HOTSPOTCACHE LEFT BOTTOM RIGHT TOP) (* rrb " 6-May-85 16:22") - - (* * returns a list of the control points that are within LOCALREGION) + [LAMBDA (HOTSPOTCACHE LEFT BOTTOM RIGHT TOP) (* rrb " 6-May-85 16:22") + + (* * returns a list of the control points that are within LOCALREGION) (PROG ((RLEFT (DIFFERENCE LEFT SK.POINT.WIDTH)) (RBOTTOM (DIFFERENCE BOTTOM SK.POINT.WIDTH)) @@ -4444,17 +4438,15 @@ This will be slow for arcs and curves."] do (COND ((ILESSP (CAR XBUCKET) RLEFT) (* stop when X gets too small.) - (RETURN))) - - (* collect the points if there are any elements cached there.) - + (RETURN))) (* collect the points if there are any + elements cached there.) (AND (CDR XBUCKET) (SETQ ELTS (SK.ADD.POINT ELTS (CAR XBUCKET) (CAR YBUCKET] (RETURN ELTS]) (SK.ADD.PT.SELECTION - [LAMBDA (PT WINDOW MARKBM) (* rrb " 9-May-85 10:18") + [LAMBDA (PT WINDOW MARKBM) (* rrb " 9-May-85 10:18") (* adds an item to the selection list  of WINDOW.) (COND @@ -4463,22 +4455,21 @@ This will be slow for arcs and curves."] (WINDOWADDPROP WINDOW 'SKETCH.SELECTIONS PT]) (SK.REMOVE.PT.SELECTION - [LAMBDA (PT WINDOW MARKBM) (* rrb " 9-May-85 10:22") + [LAMBDA (PT WINDOW MARKBM) (* rrb " 9-May-85 10:22") (* removes an item from the selection  list of WINDOW.) (COND ((MEMBER PT (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (MARKPOINT PT WINDOW MARKBM) - - (* used to call WINDOWDELPROP but it has a bug that it only removes EQ things.) + + (* used to call WINDOWDELPROP but it has a bug that it only removes EQ things.) (WINDOWPROP WINDOW 'SKETCH.SELECTIONS (REMOVE PT (WINDOWPROP WINDOW 'SKETCH.SELECTIONS]) (SK.ADD.POINT - [LAMBDA (PTLST X Y) (* rrb " 6-May-85 16:22") - - (* add the point X Y to PTLST unless it is already a member.) - + [LAMBDA (PTLST X Y) (* rrb " 6-May-85 16:22") + (* add the point X Y to PTLST unless + it is already a member.) (COND ((for PT in PTLST thereis (AND (EQ (fetch (POSITION XCOORD) of PT) X) @@ -4486,27 +4477,25 @@ This will be slow for arcs and curves."] Y))) PTLST) (T (CONS (create POSITION - XCOORD _ X - YCOORD _ Y) + XCOORD ↠X + YCOORD ↠Y) PTLST]) (SK.ELTS.CONTAINING.PTS - [LAMBDA (PTLST SKW) (* rrb " 4-May-85 15:38") - - (* returns the list of elements that have any points on PTLST.) - - (bind (HOTSPOTCACHE _ (SK.HOTSPOT.CACHE SKW)) + [LAMBDA (PTLST SKW) (* rrb " 4-May-85 15:38") + (* returns the list of elements that + have any points on PTLST.) + (bind (HOTSPOTCACHE ↠(SK.HOTSPOT.CACHE SKW)) ELTS for POS in PTLST do (SETQ ELTS (UNION (SK.ELTS.FROM.HOTSPOT POS HOTSPOTCACHE) ELTS)) finally - - (* reverse them so the first selected pt has its element first.) - + (* reverse them so the first selected + pt has its element first.) (RETURN (REVERSE ELTS]) (SK.HOTSPOTS.NOT.ON.LIST - [LAMBDA (PTLST ELTS) (* rrb "19-Jul-85 13:18") - - (* returns a list of the hot spots on any of ELTS that aren't on PTLST.) + [LAMBDA (PTLST ELTS) (* rrb "19-Jul-85 13:18") + + (* returns a list of the hot spots on any of ELTS that aren't on PTLST.) (bind OTHERHOTSPOTS for ELT in ELTS do [for HOTSPOT in (fetch (SCREENELT HOTSPOTS) of ELT) do (OR (MEMBER HOTSPOT PTLST) @@ -4522,9 +4511,9 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.SET.MOVE.MODE - [LAMBDA (SKW NEWMODE) (* rrb " 2-Jun-85 12:52") - - (* * reads a value of move command mode and makes it the default) + [LAMBDA (SKW NEWMODE) (* rrb " 2-Jun-85 12:52") + + (* * reads a value of move command mode and makes it the default) (PROG [(LOCALNEWMODE (OR NEWMODE (READMOVEMODE] (RETURN (AND LOCALNEWMODE (replace (SKETCHCONTEXT SKETCHMOVEMODE) @@ -4535,31 +4524,30 @@ This will be slow for arcs and curves."] NIL]) (SK.SET.MOVE.MODE.POINTS - [LAMBDA (SKW) (* rrb " 2-Jun-85 12:47") + [LAMBDA (SKW) (* rrb " 2-Jun-85 12:47") (* sets the default to move mode to  points.) (SK.SET.MOVE.MODE SKW 'POINTS]) (SK.SET.MOVE.MODE.ELEMENTS - [LAMBDA (SKW) (* rrb " 2-Jun-85 12:48") + [LAMBDA (SKW) (* rrb " 2-Jun-85 12:48") (* sets the default to move mode to  elements) (SK.SET.MOVE.MODE SKW 'ELEMENTS]) (SK.SET.MOVE.MODE.COMBINED - [LAMBDA (SKW) (* rrb " 2-Jun-85 12:49") + [LAMBDA (SKW) (* rrb " 2-Jun-85 12:49") (* sets the default to move mode to  combined move.) (SK.SET.MOVE.MODE SKW 'COMBINED]) (READMOVEMODE - [LAMBDA (MENUTITLE) (* rrb " 6-Nov-85 09:54") - - (* interacts to get whether move mode should be points, elements or both.) - + [LAMBDA (MENUTITLE) (* rrb " 6-Nov-85 09:54") + (* interacts to get whether move mode + should be points, elements or both.) (\CURSOR.IN.MIDDLE.MENU (create MENU - TITLE _ (OR MENUTITLE "Top level MOVE command should apply to?") - ITEMS _ '((Points 'POINTS + TITLE ↠(OR MENUTITLE "Top level MOVE command should apply to?") + ITEMS ↠'((Points 'POINTS "Top level MOVE command will be the same as MOVE POINTS command." ) (Elements 'ELEMENTS @@ -4568,84 +4556,75 @@ This will be slow for arcs and curves."] (Combined 'COMBINED "MOVE command will move points if a single point is clicked; elements otherwise" )) - CENTERFLG _ T]) + CENTERFLG ↠T]) ) (DEFINEQ (SK.ALIGN.POINTS - [LAMBDA (W) (* rrb "31-Jan-86 10:50") - - (* lets the user select a collection of points and aligns them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:50") + (* lets the user select a collection + of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE.POINTS (KWOTE W)) W]) (SK.SEL.AND.ALIGN.POINTS - [LAMBDA (ALIGNHOW W) (* rrb "22-Jan-86 14:57") - - (* * lets the user select a collection of control point and aligns them.) + [LAMBDA (ALIGNHOW W) (* rrb "22-Jan-86 14:57") + + (* * lets the user select a collection of control point and aligns them.) (SK.DO.ALIGN.POINTS (SK.SELECT.MULTIPLE.POINTS W) ALIGNHOW W]) (SK.ALIGN.POINTS.LEFT - [LAMBDA (W) (* rrb "31-Jan-86 10:51") - - (* lets the user select a collection of points and aligns them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:51") + (* lets the user select a collection + of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''LEFT (KWOTE W)) W]) (SK.ALIGN.POINTS.RIGHT - [LAMBDA (W) (* rrb "31-Jan-86 10:51") - - (* lets the user select a collection of points and aligns them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:51") + (* lets the user select a collection + of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''RIGHT (KWOTE W)) W]) (SK.ALIGN.POINTS.TOP - [LAMBDA (W) (* rrb "31-Jan-86 10:57") - - (* lets the user select a collection of points and aligns them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:57") + (* lets the user select a collection + of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''TOP (KWOTE W)) W]) (SK.ALIGN.POINTS.BOTTOM - [LAMBDA (W) (* rrb "31-Jan-86 10:58") - - (* lets the user select a collection of points and aligns them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:58") + (* lets the user select a collection + of points and aligns them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''BOTTOM (KWOTE W)) W]) (SK.EVEN.SPACE.POINTS.IN.X - [LAMBDA (W) (* rrb "31-Jan-86 10:58") - - (* lets the user select a collection of points and spaces them evenly in X) - + [LAMBDA (W) (* rrb "31-Jan-86 10:58") + (* lets the user select a collection + of points and spaces them evenly in X) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''EVENX (KWOTE W)) W]) (SK.EVEN.SPACE.POINTS.IN.Y - [LAMBDA (W) (* rrb "31-Jan-86 10:58") - - (* lets the user select a collection of points and spaces them evenly in Y) - + [LAMBDA (W) (* rrb "31-Jan-86 10:58") + (* lets the user select a collection + of points and spaces them evenly in Y) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.ALIGN.POINTS ''EVENY (KWOTE W)) W]) (SK.DO.ALIGN.POINTS - [LAMBDA (SCRPTS ALIGNHOW SKW) (* rrb "12-Sep-86 18:28") - - (* * aligns a collection of points according to ALIGNHOW which can be LEFT - RIGHT TOP BOTTOM EVENX or EVENY) + [LAMBDA (SCRPTS ALIGNHOW SKW) (* rrb "12-Sep-86 18:28") - (SKED.CLEAR.SELECTION SKW) - - (* if there isn't at least two points, don't do anything.) + (* * aligns a collection of points according to ALIGNHOW which can be LEFT RIGHT + TOP BOTTOM EVENX or EVENY) + (SKED.CLEAR.SELECTION SKW) (* if there isn't at least two points, + don't do anything.) (AND (CDR SCRPTS) (PROG ((SELECTEDPTSTRUC (SK.GET.SELECTED.ELEMENT.STRUCTURE SCRPTS SKW)) MOSTSELBUCK LEASTSELBUCK DIMENSION LEAST MOST PREMOVEFN X NEWGLOBALS) @@ -4659,10 +4638,8 @@ This will be slow for arcs and curves."] 'DON'T) (RETURN)) (SETQ MOSTSELBUCK (CAR SELECTEDPTSTRUC)) - (SETQ LEASTSELBUCK (CAR SELECTEDPTSTRUC)) - - (* find the dimension of interest and do some error checking.) - + (SETQ LEASTSELBUCK (CAR SELECTEDPTSTRUC)) (* find the dimension of interest and + do some error checking.) (SETQ DIMENSION (SELECTQ ALIGNHOW ((LEFT RIGHT) 'HORIZONTAL) @@ -4789,22 +4766,22 @@ This will be slow for arcs and curves."] N]) (SK.GET.SELECTED.ELEMENT.STRUCTURE - [LAMBDA (SELPTS SKW) (* rrb "22-Jan-86 14:58") - - (* returns a list of the points and elements that each selected point on SELPTS - corresponds to. Returns a list of lists of the form - (SELPT (GPT1 GELT1) |...| (GPTn GELTn))) + [LAMBDA (SELPTS SKW) (* rrb "22-Jan-86 14:58") - (bind (HOTSPOTCACHE _ (SK.HOTSPOT.CACHE SKW)) for POS in SELPTS + (* returns a list of the points and elements that each selected point on SELPTS + corresponds to. Returns a list of lists of the form + (SELPT (GPT1 GELT1) |...| (GPTn GELTn))) + + (bind (HOTSPOTCACHE ↠(SK.HOTSPOT.CACHE SKW)) for POS in SELPTS collect (CONS POS (for ELT in (SK.ELTS.FROM.HOTSPOT POS HOTSPOTCACHE) collect (LIST (SK.CORRESPONDING.CONTROL.PT POS ELT) ELT]) (SK.CORRESPONDING.CONTROL.PT - [LAMBDA (SELPT SCRELEMENT) (* rrb "22-Jan-86 14:59") - - (* returns the global control point of an element that corresponds to the - screen point SELPT.) + [LAMBDA (SELPT SCRELEMENT) (* rrb "22-Jan-86 14:59") + + (* returns the global control point of an element that corresponds to the screen + point SELPT.) (for I from 1 as PT in (fetch (SCREENELT HOTSPOTS) of SCRELEMENT) when (EQUAL PT SELPT) do (RETURN (OR (SK.NTH.CONTROL.POINT (fetch (SCREENELT GLOBALPART) of SCRELEMENT) @@ -4812,28 +4789,27 @@ This will be slow for arcs and curves."] (SHOULDNT]) (SK.CONTROL.POINT.NUMBER - [LAMBDA (SELPT SCRELT) (* rrb "22-Jan-86 10:54") - - (* returns the control point number that SELPT is on the element SCRELT) - + [LAMBDA (SELPT SCRELT) (* rrb "22-Jan-86 10:54") + (* returns the control point number + that SELPT is on the element SCRELT) (for I from 1 as HOTPT in (fetch (SCREENELT HOTSPOTS) of SCRELT) when (EQUAL SELPT HOTPT) do (RETURN I]) (SK.DO.ALIGN.SETVALUE - [LAMBDA (SELBUCKET VALUE DIMENSION VIEWER) (* rrb "22-Jan-86 17:23") + [LAMBDA (SELBUCKET VALUE DIMENSION VIEWER) (* rrb "22-Jan-86 17:23") (* performs the alignment of a  selection bucket structure.) - (bind (SELPT _ (CAR SELBUCKET)) - (MOVEFN _ (GETSKETCHPROP (INSURE.SKETCH VIEWER) + (bind (SELPT ↠(CAR SELBUCKET)) + (MOVEFN ↠(GETSKETCHPROP (INSURE.SKETCH VIEWER) 'WHENMOVEDFN)) GDELTA X for GELTSTRUC in (CDR SELBUCKET) when (PROG NIL - - (* calculate the amount that this global element point should be moved and - apply move fn) + + (* calculate the amount that this global element point should be moved and apply + move fn) (* don't move it if it moves 0.0) [SETQ GDELTA (create POSITION - XCOORD _ (COND + XCOORD ↠(COND ((EQ DIMENSION 'HORIZONTAL) (COND ([ZEROP (SETQ X (DIFFERENCE VALUE @@ -4842,7 +4818,7 @@ This will be slow for arcs and curves."] (RETURN)) (T X))) (T 0)) - YCOORD _ (COND + YCOORD ↠(COND ((EQ DIMENSION 'VERTICAL) (COND ([ZEROP (SETQ X (DIFFERENCE VALUE @@ -4863,15 +4839,15 @@ This will be slow for arcs and curves."] ((EQ X 'DON'T) (* if DON'T, don't move this guy.) (RETURN NIL)) ((POSITIONP X) - - (* value returned is the delta by which to move the point. - Set up new position) + + (* value returned is the delta by which to move the point. + Set up new position) (SETQ GDELTA X))) (RETURN T)) join - - (* build the history structure here because this is where the old screen - element is known.) + + (* build the history structure here because this is where the old screen element + is known.) (AND (SETQ X (SK.MOVE.ITEM.POINTS (CADR GELTSTRUC) GDELTA VIEWER (LIST SELPT))) @@ -4887,26 +4863,25 @@ This will be slow for arcs and curves."] (DEFINEQ (SKETCH.CREATE.GROUP - [LAMBDA (LISTOFSKETCHELEMENTS CONTROLPOINT) (* rrb " 4-Dec-85 21:38") + [LAMBDA (LISTOFSKETCHELEMENTS CONTROLPOINT) (* rrb " 4-Dec-85 21:38") (* creates a sketch group element.) (SK.CREATE.GROUP1 LISTOFSKETCHELEMENTS (OR (POSITIONP CONTROLPOINT) (REGION.CENTER (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS LISTOFSKETCHELEMENTS]) (SK.CREATE.GROUP1 - [LAMBDA (GELTS CONTROLPT) (* rrb " 4-Dec-85 21:38") + [LAMBDA (GELTS CONTROLPT) (* rrb " 4-Dec-85 21:38") (* creates a group element.) (SK.UPDATE.GROUP.AFTER.CHANGE (create GLOBALPART - INDIVIDUALGLOBALPART _ + INDIVIDUALGLOBALPART ↠(create GROUP - LISTOFGLOBALELTS _ GELTS - GROUPCONTROLPOINT _ CONTROLPT]) + LISTOFGLOBALELTS ↠GELTS + GROUPCONTROLPOINT ↠CONTROLPT]) (SK.UPDATE.GROUP.AFTER.CHANGE - [LAMBDA (GROUPELT) (* rrb " 4-Dec-85 21:38") - - (* updates the dependent field of a group element after a change.) - + [LAMBDA (GROUPELT) (* rrb " 4-Dec-85 21:38") + (* updates the dependent field of a + group element after a change.) (PROG ((INDGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) GROUPREGION) (SETQ GROUPREGION (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS (fetch (GROUP LISTOFGLOBALELTS) @@ -4917,26 +4892,25 @@ This will be slow for arcs and curves."] (RETURN GROUPELT]) (SK.GROUP.ELTS - [LAMBDA (W) (* rrb "31-Jan-86 10:58") - - (* lets the user select a collection elements and groups them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:58") + (* lets the user select a collection + elements and groups them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.GROUP (KWOTE W)) W]) (SK.SEL.AND.GROUP - [LAMBDA (W) (* rrb "10-Dec-85 17:08") + [LAMBDA (W) (* rrb "10-Dec-85 17:08") (* lets the user select elements and  groups them.) (SK.GROUP.ELEMENTS (SK.SELECT.MULTIPLE.ITEMS W T NIL 'GROUP) W]) (SK.GROUP.ELEMENTS - [LAMBDA (SCRELTS SKW) (* rrb "11-Jul-86 15:51") - - (* groups the collection of elements SCRELTS. - Does this by creating a group element, adding it and deleting the individual - elements.) + [LAMBDA (SCRELTS SKW) (* rrb "11-Jul-86 15:51") + + (* groups the collection of elements SCRELTS. + Does this by creating a group element, adding it and deleting the individual + elements.) (SKED.CLEAR.SELECTION SKW) (AND SCRELTS (PROG (GROUPELT LOCALGROUPELT) (* call the group fn if there is one.) @@ -4948,10 +4922,9 @@ This will be slow for arcs and curves."]  SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS SCRELTS (VIEWER.SCALE SKW))) - SKW))) - - (* do grouping. This might return NIL if the when grouped function says not to.) - + SKW))) (* do grouping. This might return NIL + if the when grouped function says not + to.) (OR (SK.DO.GROUP GROUPELT SKW) (RETURN)) (* record it on the history list.) (SK.ADD.HISTEVENT 'GROUP (LIST (LIST GROUPELT)) @@ -4959,15 +4932,14 @@ This will be slow for arcs and curves."] (RETURN GROUPELT]) (SK.UNGROUP.ELT - [LAMBDA (W) (* rrb "31-Jan-86 10:58") - - (* lets the user select a collection elements and groups them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:58") + (* lets the user select a collection + elements and groups them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.UNGROUP (KWOTE W)) W]) (SK.SEL.AND.UNGROUP - [LAMBDA (W) (* rrb "10-Dec-85 18:03") + [LAMBDA (W) (* rrb "10-Dec-85 18:03") (* lets the user select elements and  groups them.) (PROG NIL @@ -4990,26 +4962,24 @@ This will be slow for arcs and curves."] W]) (SK.UNGROUP.ELEMENT - [LAMBDA (SCRELTS SKW) (* rrb "15-Jan-86 16:12") + [LAMBDA (SCRELTS SKW) (* rrb "15-Jan-86 16:12") (* ungroups the first group element in  SCRELTS.) (PROG ((GROUPELTS (for ELT in SCRELTS when (EQ (fetch (SCREENELT GTYPE) of ELT) 'GROUP) collect (fetch (SCREENELT GLOBALPART) of ELT))) X) - (OR GROUPELTS (RETURN)) - - (* do the ungrouping. this may return NIL if the ungroup fn says don't.) - + (OR GROUPELTS (RETURN)) (* do the ungrouping. + this may return NIL if the ungroup fn + says don't.) (SETQ X (for GROUPELT in GROUPELTS when (SK.DO.UNGROUP GROUPELT SKW) collect (LIST GROUPELT))) (AND X (SK.ADD.HISTEVENT 'UNGROUP X SKW]) (SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS - [LAMBDA (SCRELTS SCALE) (* rrb "30-Sep-86 18:33") - - (* returns the global region occuppied by a list of local elements.) - + [LAMBDA (SCRELTS SCALE) (* rrb "30-Sep-86 18:33") + (* returns the global region occuppied + by a list of local elements.) (PROG (GROUPREGION) [for SCRELT in SCRELTS do (SETQ GROUPREGION (COND (GROUPREGION @@ -5021,10 +4991,9 @@ This will be slow for arcs and curves."] (RETURN (UNSCALE.REGION GROUPREGION SCALE]) (SK.LOCAL.REGION.OF.LOCAL.ELEMENTS - [LAMBDA (SCRELTS SCALE) (* rrb "30-Sep-86 18:33") - - (* returns the local region occupied by a list of local elements.) - + [LAMBDA (SCRELTS SCALE) (* rrb "30-Sep-86 18:33") + (* returns the local region occupied + by a list of local elements.) (bind GROUPREGION for SCRELT in SCRELTS do [SETQ GROUPREGION (COND (GROUPREGION (* first time because UNIONREGIONS @@ -5036,16 +5005,15 @@ This will be slow for arcs and curves."] finally (RETURN GROUPREGION]) (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS - [LAMBDA (GELTS) (* rrb "30-Sep-86 17:35") - - (* returns the global region occuppied by a list of global elements.) - + [LAMBDA (GELTS) (* rrb "30-Sep-86 17:35") + (* returns the global region occuppied + by a list of global elements.) (COND [(LESSP (LENGTH GELTS) 50) - - (* for smallish numbers of elements, only do the cons to create the args to - SK.UNIONREGIONS.) + + (* for smallish numbers of elements, only do the cons to create the args to + SK.UNIONREGIONS.) (APPLY (FUNCTION SK.UNIONREGIONS) (for GELT in GELTS collect (SK.ELEMENT.GLOBAL.REGION GELT] @@ -5061,10 +5029,10 @@ This will be slow for arcs and curves."] (RETURN GROUPREGION]) (SK.UNIONREGIONS - [LAMBDA REGIONS (* rrb "30-Sep-86 18:14") - - (* returns the smallest region that encloses all of REGIONS Is different from - UNIONREGIONS because it works in floating pt) + [LAMBDA REGIONS (* rrb "30-Sep-86 18:14") + + (* returns the smallest region that encloses all of REGIONS Is different from + UNIONREGIONS because it works in floating pt) (COND ((EQ 0 REGIONS) @@ -5095,19 +5063,19 @@ This will be slow for arcs and curves."] TP) (SETQ TP X] (RETURN (create REGION - LEFT _ LFT - BOTTOM _ BTTM - WIDTH _ (DIFFERENCE RGHT LFT) - HEIGHT _ (DIFFERENCE TP BTTM]) + LEFT ↠LFT + BOTTOM ↠BTTM + WIDTH ↠(DIFFERENCE RGHT LFT) + HEIGHT ↠(DIFFERENCE TP BTTM]) (SKETCH.REGION.OF.SKETCH - [LAMBDA (SKETCH) (* rrb "23-Oct-85 11:17") + [LAMBDA (SKETCH) (* rrb "23-Oct-85 11:17") (* returns the global region of a  sketch.) (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH SKETCH]) (SK.FLASHREGION - [LAMBDA (REGION WINDOW TEXTURE) (* rrb "30-Jul-85 15:47") + [LAMBDA (REGION WINDOW TEXTURE) (* rrb "30-Jul-85 15:47") (* flashes a region) (DSPFILL REGION TEXTURE 'INVERT WINDOW) (DISMISS 400) @@ -5116,7 +5084,7 @@ This will be slow for arcs and curves."] (DEFINEQ (INIT.GROUP.ELEMENT - [LAMBDA NIL (* rrb "18-Oct-85 17:15") + [LAMBDA NIL (* rrb "18-Oct-85 17:15") (* initializes the text box element.) (COND ((NOT (SKETCH.ELEMENT.TYPEP 'GROUP)) @@ -5136,81 +5104,78 @@ This will be slow for arcs and curves."] (FUNCTION GROUP.GLOBALREGIONFN]) (GROUP.DRAWFN - [LAMBDA (GROUPELT WINDOW REGION OPERATION) (* rrb "10-Dec-85 12:38") + [LAMBDA (GROUPELT WINDOW REGION OPERATION) (* rrb "10-Dec-85 12:38") (* draws a group element.) (for ELT in (fetch (LOCALGROUP LOCALELEMENTS) of (fetch (SCREENELT LOCALPART) of GROUPELT)) do (APPLY* (SK.DRAWFN (fetch (SCREENELT GTYPE) of ELT)) ELT WINDOW REGION OPERATION]) (GROUP.EXPANDFN - [LAMBDA (GROUPELT SCALE STREAM) (* rrb "30-Dec-85 17:30") - - (* creates a local group screen element from a global group element) - + [LAMBDA (GROUPELT SCALE STREAM) (* rrb "30-Dec-85 17:30") + (* creates a local group screen + element from a global group element) (PROG ((GROUPINDVELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) LOCALREGION) (SETQ LOCALREGION (SCALE.REGION.OUT (fetch (GROUP GROUPREGION) of GROUPINDVELT) SCALE)) (* put the position in the center.) (RETURN (create SCREENELT - LOCALPART _ (create LOCALGROUP - GROUPPOSITION _ (SK.SCALE.POSITION.INTO.VIEWER + LOCALPART ↠(create LOCALGROUP + GROUPPOSITION ↠(SK.SCALE.POSITION.INTO.VIEWER (fetch (GROUP GROUPCONTROLPOINT) of GROUPINDVELT) SCALE) - LOCALGROUPREGION _ LOCALREGION - LOCALELEMENTS _ (for ELEMENT + LOCALGROUPREGION ↠LOCALREGION + LOCALELEMENTS ↠(for ELEMENT in (fetch (GROUP LISTOFGLOBALELTS) of GROUPINDVELT) - collect (SK.LOCAL.FROM.GLOBAL ELEMENT + collect (SK.LOCAL.FROM.GLOBAL ELEMENT STREAM SCALE))) - GLOBALPART _ GROUPELT]) + GLOBALPART ↠GROUPELT]) (GROUP.INSIDEFN - [LAMBDA (GROUPELT WREG) (* rrb "10-Jan-85 10:37") - - (* determines if the global group element GROUPELT is inside of WREG.) - + [LAMBDA (GROUPELT WREG) (* rrb "10-Jan-85 10:37") + (* determines if the global group + element GROUPELT is inside of WREG.) (REGIONSINTERSECTP (fetch (GROUP GROUPREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) WREG]) (GROUP.REGIONFN - [LAMBDA (GROUPSCRELT) (* rrb "10-Dec-85 12:38") + [LAMBDA (GROUPSCRELT) (* rrb "10-Dec-85 12:38") (* returns the region occuppied by a  group) (fetch (LOCALGROUP LOCALGROUPREGION) of (fetch (SCREENELT LOCALPART) of GROUPSCRELT]) (GROUP.GLOBALREGIONFN - [LAMBDA (GGROUPELT) (* rrb "18-Oct-85 17:13") - - (* returns the global region occupied by a global group element.) - + [LAMBDA (GGROUPELT) (* rrb "18-Oct-85 17:13") + (* returns the global region occupied + by a global group element.) (fetch (GROUP GROUPREGION) of (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GGROUPELT]) (GROUP.TRANSLATEFN - [LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:43") - - (* * returns a group element which has been translated by DELTAPOS) + [LAMBDA (SKELT DELTAPOS) (* rrb "28-Apr-85 18:43") + + (* * returns a group element which has been translated by DELTAPOS) (PROG ((GGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKELT)) NEWREG) (SETQ NEWREG (REL.MOVE.REGION (fetch (GROUP GROUPREGION) of GGROUPELT) (fetch (POSITION XCOORD) of DELTAPOS) (fetch (POSITION YCOORD) of DELTAPOS))) - - (* makes a copy of the common global part because it includes the scales which - may change for one of the instances.) + + (* makes a copy of the common global part because it includes the scales which + may change for one of the instances.) (RETURN (create GLOBALPART - COMMONGLOBALPART _ (APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) - INDIVIDUALGLOBALPART _ (create GROUP - GROUPREGION _ NEWREG - LISTOFGLOBALELTS _ + COMMONGLOBALPART ↠(APPEND (fetch (GLOBALPART COMMONGLOBALPART) of SKELT)) + INDIVIDUALGLOBALPART ↠(create GROUP + GROUPREGION ↠NEWREG + LISTOFGLOBALELTS ↠(for SUBELT in (fetch (GROUP LISTOFGLOBALELTS) of GGROUPELT) collect (SK.TRANSLATE.GLOBALPART SUBELT DELTAPOS T)) - GROUPCONTROLPOINT _ (PTPLUS + GROUPCONTROLPOINT ↠(PTPLUS (fetch (GROUP GROUPCONTROLPOINT ) @@ -5218,15 +5183,13 @@ This will be slow for arcs and curves."] DELTAPOS]) (GROUP.TRANSFORMFN - [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb " 2-Jun-85 13:10") - - (* * returns a group element which has been transformed by TRANSFORMFN) + [LAMBDA (GELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR) (* rrb " 2-Jun-85 13:10") + + (* * returns a group element which has been transformed by TRANSFORMFN) (COND - [(EQ TRANSFORMFN (FUNCTION SK.PUT.ON.GRID)) - - (* if putting things on a grid, move only the control point.) - + [(EQ TRANSFORMFN (FUNCTION SK.PUT.ON.GRID)) (* if putting things on a grid, move + only the control point.) (PROG ((GGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) NOWPOS) (SETQ NOWPOS (fetch (GROUP GROUPCONTROLPOINT) of GGROUPELT)) @@ -5235,34 +5198,34 @@ This will be slow for arcs and curves."] NOWPOS] (T (PROG ((GGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GELT)) NEWREG) - - (* this transforms the old region to get the new one. - This is not as good as recalculating the new one from the transformed elements. - The latter is hard because the region function only works on local elements and - here we have only global ones.) + + (* this transforms the old region to get the new one. + This is not as good as recalculating the new one from the transformed elements. + The latter is hard because the region function only works on local elements and + here we have only global ones.) (SETQ NEWREG (SK.TRANSFORM.REGION (fetch (GROUP GROUPREGION) of GGROUPELT) TRANSFORMFN TRANSFORMDATA)) - - (* the control point could also profitably be put on a grid point but no other - elements points are so done and it would be hard.) + + (* the control point could also profitably be put on a grid point but no other + elements points are so done and it would be hard.) (RETURN (BOX.SET.SCALES NEWREG (create GLOBALPART - COMMONGLOBALPART _ (fetch (GLOBALPART + COMMONGLOBALPART ↠(fetch (GLOBALPART COMMONGLOBALPART ) of GELT) - INDIVIDUALGLOBALPART _ + INDIVIDUALGLOBALPART ↠(create GROUP - GROUPREGION _ NEWREG - LISTOFGLOBALELTS _ + GROUPREGION ↠NEWREG + LISTOFGLOBALELTS ↠(for SUBELT in (fetch (GROUP LISTOFGLOBALELTS) of GGROUPELT) - collect (SK.TRANSFORM.ELEMENT SUBELT + collect (SK.TRANSFORM.ELEMENT SUBELT TRANSFORMFN TRANSFORMDATA SCALEFACTOR)) - GROUPCONTROLPOINT _ + GROUPCONTROLPOINT ↠(SK.TRANSFORM.POINT (fetch (GROUP GROUPCONTROLPOINT ) @@ -5270,20 +5233,20 @@ This will be slow for arcs and curves."] TRANSFORMFN TRANSFORMDATA]) (GROUP.READCHANGEFN - [LAMBDA (SKW SCRNELTS) (* rrb "14-May-86 19:38") + [LAMBDA (SKW SCRNELTS) (* rrb "14-May-86 19:38") (* reads how the user wants to change  a textbox.) (PROG (ASPECT HOW) (SETQ HOW (SELECTQ (SETQ ASPECT (\CURSOR.IN.MIDDLE.MENU (create MENU - TITLE _ "Change which part?" - ITEMS _ [APPEND (COND + TITLE ↠"Change which part?" + ITEMS ↠[APPEND (COND [(SKETCHINCOLORP) '(("Brush color" 'BRUSHCOLOR "changes the color of any lines or text in the group." ) - ("Filling color" ' - FILLINGCOLOR + ("Filling color" + 'FILLINGCOLOR "changes the filling color of any boxes or text boxes in the group." ] (T NIL)) @@ -5305,7 +5268,7 @@ This will be slow for arcs and curves."] (Text 'TEXT "allows changing the properties of the text." ] - CENTERFLG _ T))) + CENTERFLG ↠T))) (TEXT (* handle TEXT specially because it  has several different cases.) (AND (SETQ HOW (TEXT.READCHANGEFN SKW SCRNELTS T)) @@ -5323,13 +5286,13 @@ This will be slow for arcs and curves."] (DEFINEQ (REGION.CENTER - [LAMBDA (REGION) (* rrb "11-Jan-85 18:22") + [LAMBDA (REGION) (* rrb "11-Jan-85 18:22") (* returns the center of a region) (create POSITION - XCOORD _ (PLUS (fetch (REGION LEFT) of REGION) + XCOORD ↠(PLUS (fetch (REGION LEFT) of REGION) (QUOTIENT (fetch (REGION WIDTH) of REGION) 2)) - YCOORD _ (PLUS (fetch (REGION BOTTOM) of REGION) + YCOORD ↠(PLUS (fetch (REGION BOTTOM) of REGION) (QUOTIENT (fetch (REGION HEIGHT) of REGION) 2]) @@ -5350,18 +5313,16 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.MOVE.GROUP.CONTROL.PT - [LAMBDA (W) (* rrb "31-Jan-86 10:59") - - (* lets the user move the control point of a group.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:59") + (* lets the user move the control + point of a group.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.MOVE.CONTROL.PT (KWOTE W)) W]) (SK.SEL.AND.MOVE.CONTROL.PT - [LAMBDA (W) (* rrb "23-Jan-86 18:11") - - (* lets the user select a groups and move its control point.) - + [LAMBDA (W) (* rrb "23-Jan-86 18:11") + (* lets the user select a groups and + move its control point.) (PROG NIL (RETURN (SK.MOVE.GROUP.ELEMENT.CONTROL.POINT [SK.SELECT.ITEM W T (COND @@ -5380,10 +5341,9 @@ This will be slow for arcs and curves."] W]) (SK.MOVE.GROUP.ELEMENT.CONTROL.POINT - [LAMBDA (SCRGROUPELT SKW) (* rrb "27-Jun-86 15:34") - - (* reads a new location of the control point for a group element.) - + [LAMBDA (SCRGROUPELT SKW) (* rrb "27-Jun-86 15:34") + (* reads a new location of the control + point for a group element.) (PROG ((GELT (fetch (SCREENELT GLOBALPART) of SCRGROUPELT)) (INDVGELT (fetch (SCREENELT INDIVIDUALGLOBALPART) of SCRGROUPELT)) OLDPOS NEWPOS NEWGROUPELT LOCALELT) @@ -5406,19 +5366,18 @@ This will be slow for arcs and curves."] of LOCALELT)) SKW GRAYSHADE) (SK.ADD.HISTEVENT 'CHANGE (LIST (create SKHISTORYCHANGESPEC - NEWELT _ NEWGROUPELT - OLDELT _ GELT - PROPERTY _ 'POSITION - NEWVALUE _ NEWPOS - OLDVALUE _ OLDPOS)) + NEWELT ↠NEWGROUPELT + OLDELT ↠GELT + PROPERTY ↠'POSITION + NEWVALUE ↠NEWPOS + OLDVALUE ↠OLDPOS)) SKW) (RETURN NEWGROUPELT]) (SK.READ.NEW.GROUP.CONTROL.PT - [LAMBDA (VIEWER LOCALGROUPREGION) (* rrb "14-Jul-86 13:51") - - (* reads where the user wants the new control point to be.) - + [LAMBDA (VIEWER LOCALGROUPREGION) (* rrb "14-Jul-86 13:51") + (* reads where the user wants the new + control point to be.) (PROG (PT) (* outline the group) (SK.DRAWBOX (fetch (REGION LEFT) of LOCALGROUPREGION) (fetch (REGION BOTTOM) of LOCALGROUPREGION) @@ -5453,7 +5412,7 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.DO.GROUP - [LAMBDA (GROUPELT SKW) (* rrb "30-Sep-86 17:38") + [LAMBDA (GROUPELT SKW) (* rrb "30-Sep-86 17:38") (* does a group event.  Used to undo UNGROUP too.) (PROG (LOCALELT OKEDGELTS) @@ -5466,17 +5425,15 @@ This will be slow for arcs and curves."] with (SK.ORDER.ELEMENTS OKEDGELTS)) (SK.UPDATE.GROUP.AFTER.CHANGE GROUPELT) (for GELT in OKEDGELTS do (SK.DELETE.ELEMENT1 GELT SKW T)) - (SETQ LOCALELT (SK.ADD.ELEMENT GROUPELT SKW T T T)) - - (* flash the grouped area to let user know something happened.) - + (SETQ LOCALELT (SK.ADD.ELEMENT GROUPELT SKW T T T))(* flash the grouped area to let user + know something happened.) (SK.FLASHREGION (fetch (LOCALGROUP LOCALGROUPREGION) of (fetch (SCREENELT LOCALPART) of LOCALELT)) SKW GRAYSHADE) (RETURN LOCALELT]) (SK.CHECK.WHENGROUPEDFN - [LAMBDA (VIEWER ELEMENTS) (* rrb "15-Jan-86 16:07") + [LAMBDA (VIEWER ELEMENTS) (* rrb "15-Jan-86 16:07") (* checks the when grouped fn of a  sketch viewer.) (PROG (GROUPFN X) @@ -5491,7 +5448,7 @@ This will be slow for arcs and curves."] (T ELEMENTS]) (SK.DO.UNGROUP - [LAMBDA (GROUPELT SKW) (* rrb "11-Jul-86 15:51") + [LAMBDA (GROUPELT SKW) (* rrb "11-Jul-86 15:51") (* does a ungroup event.  Used to undo GROUP too.) (PROG NIL @@ -5510,7 +5467,7 @@ This will be slow for arcs and curves."] (RETURN GROUPELT]) (SK.CHECK.WHENUNGROUPEDFN - [LAMBDA (VIEWER GROUPELT) (* rrb "15-Jan-86 16:19") + [LAMBDA (VIEWER GROUPELT) (* rrb "15-Jan-86 16:19") (* checks the when ungrouped fn of a  sketch viewer.) (PROG (UNGROUPFN) @@ -5520,14 +5477,14 @@ This will be slow for arcs and curves."] 'DON'T]) (SK.GROUP.UNDO - [LAMBDA (EVENTARGS SKW) (* rrb "15-Jan-86 16:12") + [LAMBDA (EVENTARGS SKW) (* rrb "15-Jan-86 16:12") (* undoes a group event) (for GRP in EVENTARGS do (SK.DO.UNGROUP (CAR GRP) SKW)) T]) (SK.UNGROUP.UNDO - [LAMBDA (EVENTARGS SKW) (* rrb "15-Jan-86 15:47") + [LAMBDA (EVENTARGS SKW) (* rrb "15-Jan-86 15:47") (* undoes a ungroup event) (for GRP in EVENTARGS do (SK.DO.GROUP (CAR GRP) SKW)) @@ -5545,22 +5502,21 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.FREEZE.ELTS - [LAMBDA (W) (* rrb "31-Jan-86 10:59") - - (* lets the user select a collection elements and freezes them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:59") + (* lets the user select a collection + elements and freezes them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.FREEZE (KWOTE W)) W]) (SK.SEL.AND.FREEZE - [LAMBDA (W) (* rrb "11-Dec-85 15:30") + [LAMBDA (W) (* rrb "11-Dec-85 15:30") (* lets the user select elements and  freezes them.) (SK.FREEZE.ELEMENTS (SK.SELECT.MULTIPLE.ITEMS W T NIL 'FROZEN) W]) (SK.FREEZE.ELEMENTS - [LAMBDA (SCRELTS SKW) (* rrb "11-Dec-85 15:30") + [LAMBDA (SCRELTS SKW) (* rrb "11-Dec-85 15:30") (* freezes the collection of elements  SCRELTS.) (PROG (GELTS GELT) @@ -5570,15 +5526,14 @@ This will be slow for arcs and curves."] (SK.ADD.HISTEVENT 'FREEZE GELTS SKW]) (SK.UNFREEZE.ELT - [LAMBDA (W) (* rrb "31-Jan-86 10:59") - - (* lets the user select a collection elements and unfreezes them.) - + [LAMBDA (W) (* rrb "31-Jan-86 10:59") + (* lets the user select a collection + elements and unfreezes them.) (SK.EVAL.AS.PROCESS (LIST 'SK.SEL.AND.UNFREEZE (KWOTE W)) W]) (SK.SEL.AND.UNFREEZE - [LAMBDA (W) (* rrb "12-Dec-85 12:25") + [LAMBDA (W) (* rrb "12-Dec-85 12:25") (* lets the user select elements and  freezes them.) (PROG NIL @@ -5600,7 +5555,7 @@ This will be slow for arcs and curves."] W]) (SK.UNFREEZE.ELEMENTS - [LAMBDA (SCRELTS SKW) (* rrb "11-Dec-85 15:30") + [LAMBDA (SCRELTS SKW) (* rrb "11-Dec-85 15:30") (* unfreezes the collection of  elements SCRELTS.) (PROG (GELTS GELT) @@ -5610,24 +5565,24 @@ This will be slow for arcs and curves."] (SK.ADD.HISTEVENT 'UNFREEZE GELTS SKW]) (SK.FREEZE.UNDO - [LAMBDA (EVENTARGS SKW) (* rrb "11-Dec-85 15:28") + [LAMBDA (EVENTARGS SKW) (* rrb "11-Dec-85 15:28") (* undoes a freeze event) (SK.DO.UNFREEZE EVENTARGS SKW]) (SK.UNFREEZE.UNDO - [LAMBDA (EVENTARGS SKW) (* rrb "11-Dec-85 15:28") + [LAMBDA (EVENTARGS SKW) (* rrb "11-Dec-85 15:28") (* undoes a unfreeze event) (SK.DO.FREEZE EVENTARGS SKW]) (SK.DO.FREEZE - [LAMBDA (GELTS SKW) (* rrb "11-Dec-85 15:27") + [LAMBDA (GELTS SKW) (* rrb "11-Dec-85 15:27") (* does a freeze event.  Used to undo UNFREEZE too.) (for GELT in GELTS do (ADDSKETCHELEMENTPROP GELT 'PROTECTION 'FROZEN)) GELTS]) (SK.DO.UNFREEZE - [LAMBDA (GELTS SKW) (* rrb "11-Dec-85 15:27") + [LAMBDA (GELTS SKW) (* rrb "11-Dec-85 15:27") (* does a unfreeze event.  Used to undo FREEZE too.) (for GELT in GELTS do (REMOVESKETCHELEMENTPROP GELT 'PROTECTION 'FROZEN)) @@ -5645,36 +5600,36 @@ This will be slow for arcs and curves."] (DEFINEQ (SKETCH.ELEMENTS.OF.SKETCH - [LAMBDA (SKETCH) (* rrb " 2-Aug-85 16:21") - - (* Returns the list of elements that are in SKETCH. - SKETCH can be either a SKETCH structure, a sketch window - (sometimes called a viewer) or a SKETCH stream - (obtained via (OPENIMAGESTREAM (QUOTE name) - (QUOTE SKETCH))%. If SKETCH is not a sketch, a sketch window or a sketch - stream, it returns NIL. This can be used with sketch streams to determine the - elements created by a call to a display function or series of functions by - looking at the list differences; new elements are always added at the end.)) + [LAMBDA (SKETCH) (* rrb " 2-Aug-85 16:21") + + (* Returns the list of elements that are in SKETCH. + SKETCH can be either a SKETCH structure, a sketch window + (sometimes called a viewer) or a SKETCH stream + (obtained via (OPENIMAGESTREAM (QUOTE name) + (QUOTE SKETCH))%. If SKETCH is not a sketch, a sketch window or a sketch stream, + it returns NIL. This can be used with sketch streams to determine the elements + created by a call to a display function or series of functions by looking at the + list differences; new elements are always added at the end.)) (fetch (SKETCH SKETCHELTS) of (INSURE.SKETCH SKETCH T]) (SKETCH.LIST.OF.ELEMENTS - [LAMBDA (SKETCH PREDICATE INSIDEGROUPSFLG) (* rrb "14-Aug-85 16:26") - - (* Returns a list of the sketch elements in SKETCH that satisfy PREDICATE. - If INSIDEGROUPSFLG is T, elements that are members of a group will be - considered too. Otherwise only top level objects are considered. - Note%: PREDICATE will be applied to GROUP elements even when INSIDEGROUPSFLG is - T.) + [LAMBDA (SKETCH PREDICATE INSIDEGROUPSFLG) (* rrb "14-Aug-85 16:26") + + (* Returns a list of the sketch elements in SKETCH that satisfy PREDICATE. + If INSIDEGROUPSFLG is T, elements that are members of a group will be considered + too. Otherwise only top level objects are considered. + Note%: PREDICATE will be applied to GROUP elements even when INSIDEGROUPSFLG is + T.) (* FOR NOW, IGNORE INSIDEGROUPSFLG) (for ELT in (SKETCH.ELEMENTS.OF.SKETCH SKETCH) when (APPLY* PREDICATE ELT) collect ELT]) (SKETCH.ADD.ELEMENT - [LAMBDA (ELEMENT SKETCH NODISPLAYFLG) (* rrb "30-Aug-86 15:09") - - (* Adds an element to a sketch. If NODISPLAYFLG is NIL, any windows currently - displaying SKETCH will be updated to reflect ELEMENT's addition. - If NODISPLAYFLG is T, the displays won't be updated.) + [LAMBDA (ELEMENT SKETCH NODISPLAYFLG) (* rrb "30-Aug-86 15:09") + + (* Adds an element to a sketch. If NODISPLAYFLG is NIL, any windows currently + displaying SKETCH will be updated to reflect ELEMENT's addition. + If NODISPLAYFLG is T, the displays won't be updated.) (PROG [(SKSTRUC (COND ((NULL SKETCH) @@ -5691,14 +5646,14 @@ This will be slow for arcs and curves."] (RETURN SKSTRUC]) (SKETCH.DELETE.ELEMENT - [LAMBDA (ELEMENT SKETCH INSIDEGROUPSFLG NODISPLAYFLG) (* rrb "19-Oct-85 17:09") - - (* Deletes an element from a sketch. If INSIDEGROUPSFLG is T, the element will - be deleted even if it is inside a group. - Otherwise it will be deleted only if it is on the top level. - If NODISPLAYFLG is NIL, any windows currently displaying SKETCH will be updated - to reflect ELEMENT's deletion. If NODISPLAYFLG is T, the displays won't be - updated. It returns ELEMENT if ELEMENT was deleted.) + [LAMBDA (ELEMENT SKETCH INSIDEGROUPSFLG NODISPLAYFLG) (* rrb "19-Oct-85 17:09") + + (* Deletes an element from a sketch. If INSIDEGROUPSFLG is T, the element will be + deleted even if it is inside a group. Otherwise it will be deleted only if it is + on the top level. If NODISPLAYFLG is NIL, any windows currently displaying SKETCH + will be updated to reflect ELEMENT's deletion. + If NODISPLAYFLG is T, the displays won't be updated. + It returns ELEMENT if ELEMENT was deleted.) (PROG ((SKSTRUC (INSURE.SKETCH SKETCH)) LOCALELT OLDGELT) (* delete the element to the sketch.) @@ -5717,10 +5672,9 @@ This will be slow for arcs and curves."] (RETURN OLDGELT]) (DELFROMGROUPELT - [LAMBDA (ELTTODEL GROUPELT) (* rrb " 2-Aug-85 17:03") - - (* if ELTTODEL is a member of GROUPELT, this deletes it.) - + [LAMBDA (ELTTODEL GROUPELT) (* rrb " 2-Aug-85 17:03") + (* if ELTTODEL is a member of + GROUPELT, this deletes it.) (AND (EQ (fetch (GLOBALPART GTYPE) of GROUPELT) 'GROUP) (PROG ((INDVGROUPELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of GROUPELT)) @@ -5733,17 +5687,17 @@ This will be slow for arcs and curves."] (T (RETURN (for ELT in SUBELTS thereis (DELFROMGROUPELT ELTTODEL ELT]) (SKETCH.ELEMENT.TYPE - [LAMBDA (ELEMENT) (* rrb "14-Aug-85 16:35") + [LAMBDA (ELEMENT) (* rrb "14-Aug-85 16:35") (* returns the type of a global sketch  element) (fetch (GLOBALPART GTYPE) of ELEMENT]) (SKETCH.ELEMENT.CHANGED - [LAMBDA (SKETCH ELEMENT SKETCHWINDOW) (* rrb " 4-Feb-86 15:04") - - (* If ELEMENT is an element of SKETCH, its local part is recalculated. - This is normally used to notify sketch that an image object element has - changed. Note%: this replaces the element with another one.) + [LAMBDA (SKETCH ELEMENT SKETCHWINDOW) (* rrb " 4-Feb-86 15:04") + + (* If ELEMENT is an element of SKETCH, its local part is recalculated. + This is normally used to notify sketch that an image object element has changed. + Note%: this replaces the element with another one.) (PROG ((SKETCH (INSURE.SKETCH SKETCH)) OLDREG) @@ -5763,10 +5717,9 @@ This will be slow for arcs and curves."] (RETURN ELEMENT]) (SK.ELEMENT.CHANGED1 - [LAMBDA (SKIMAGEOBJELT OLDREGION SKETCHW) (* rrb "21-Aug-85 15:54") - - (* updates the display of an image object element in a window.) - + [LAMBDA (SKIMAGEOBJELT OLDREGION SKETCHW) (* rrb "21-Aug-85 15:54") + (* updates the display of an image + object element in a window.) (PROG (LOCALELT) (COND ((SETQ LOCALELT (SK.LOCAL.ELT.FROM.GLOBALPART SKIMAGEOBJELT SKETCHW)) @@ -5778,10 +5731,10 @@ This will be slow for arcs and curves."] (RETURN (SKETCH.ADD.AND.DISPLAY1 SKIMAGEOBJELT SKETCHW]) (SK.UPDATE.GLOBAL.IMAGE.OBJECT.ELEMENT - [LAMBDA (SKIMOBJELT VIEWER) (* rrb " 4-Feb-86 15:04") - - (* updates the fields to reflect changes in the size of the image object.) - + [LAMBDA (SKIMOBJELT VIEWER) (* rrb " 4-Feb-86 15:04") + (* updates the fields to reflect + changes in the size of the image + object.) (PROG ((INDVSKIMOBJELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of SKIMOBJELT)) IMOBJSIZE REGION SCALE) (SETQ IMOBJSIZE (IMAGEBOXSIZE (fetch (SKIMAGEOBJ SKIMAGEOBJ) of INDVSKIMOBJELT) @@ -5796,11 +5749,11 @@ This will be slow for arcs and curves."] (TIMES (fetch (IMAGEBOX YSIZE) of IMOBJSIZE) SCALE))) (replace (SKIMAGEOBJ SKIMOBJ.OFFSETPOS) of INDVSKIMOBJELT with (create POSITION - XCOORD _ + XCOORD ↠(fetch (IMAGEBOX XKERN) of IMOBJSIZE) - YCOORD _ + YCOORD ↠(fetch (IMAGEBOX YDESC) of IMOBJSIZE))) @@ -5814,10 +5767,9 @@ This will be slow for arcs and curves."] (DEFINEQ (INSURE.SKETCH - [LAMBDA (SK NOERRORFLG) (* rrb " 3-Oct-86 15:16") - - (* returns the SKETCH structure from a window, sketch stream, or a structure.) - + [LAMBDA (SK NOERRORFLG) (* rrb " 3-Oct-86 15:16") + (* returns the SKETCH structure from a + window, sketch stream, or a structure.) (SK.CHECK.SKETCH.VERSION (COND ((type? SKETCH SK) SK) @@ -5833,7 +5785,7 @@ This will be slow for arcs and curves."] 'SKETCH)) (T (AND (NULL NOERRORFLG) (ERROR - "sketch stream window doesn't have SKETCH property" + "sketch stream window doesn't have SKETCH property" SK] [(type? IMAGEOBJ SK) (PROG [(SK? (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) @@ -5846,14 +5798,12 @@ This will be slow for arcs and curves."] ((AND (LISTP SK) (LITATOM (CAR SK)) (for ELT in (CDR SK) always (GLOBALELEMENTP ELT))) - - (* old form, probably written out by notecards, update to new form.) - + (* old form, probably written out by + notecards, update to new form.) (PROG (X) (SETQ X (SKIO.UPDATE.FROM.OLD.FORM SK)) - - (* smash sketch so this won't have to happen every time.) - + (* smash sketch so this won't have to + happen every time.) (RPLACA SK (CAR X)) (RPLACD SK (CDR X)) (RETURN X))) @@ -5861,16 +5811,16 @@ This will be slow for arcs and curves."] (ERROR SK "not a SKETCH"]) (LOCALSPECS.FROM.VIEWER - [LAMBDA (SKW) (* rrb "12-May-85 16:46") + [LAMBDA (SKW) (* rrb "12-May-85 16:46") (* returns the sketch specification  displayed in the window SKW.) (CDAR (WINDOWPROP SKW 'SKETCHSPECS]) (SK.LOCAL.ELT.FROM.GLOBALPART - [LAMBDA (GLOBALPART SKW) (* rrb "18-MAR-83 13:09") - - (* returns the local element from SKW that has global part GLOBALPART - - NIL if there isn't one.) + [LAMBDA (GLOBALPART SKW) (* rrb "18-MAR-83 13:09") + + (* returns the local element from SKW that has global part GLOBALPART - + NIL if there isn't one.) (for ELT in (LOCALSPECS.FROM.VIEWER SKW) when (EQ (fetch (SCREENELT GLOBALPART) of ELT) GLOBALPART) do (RETURN ELT]) @@ -5881,36 +5831,33 @@ This will be slow for arcs and curves."] (WINDOWPROP SKETCHW 'SKETCH]) (INSPECT.SKETCH - [LAMBDA (SKW) (* rrb "18-Apr-84 14:44") - - (* calls the inspector on the sketch specs of a sketch window.) - + [LAMBDA (SKW) (* rrb "18-Apr-84 14:44") + (* calls the inspector on the sketch + specs of a sketch window.) (PROG ((SPECS (LOCALSPECS.FROM.VIEWER SKW))) (COND (SPECS (INSPECT/TOP/LEVEL/LIST SPECS]) (ELT.INSIDE.SKETCHWP - [LAMBDA (GELT SKW) (* rrb " 8-APR-83 13:18") - - (* determines if a global element is in the region of a viewer) - + [LAMBDA (GELT SKW) (* rrb " 8-APR-83 13:18") + (* determines if a global element is + in the region of a viewer) (SK.INSIDE.REGION GELT (WINDOWPROP SKW 'REGION.VIEWED]) (SK.INSIDE.REGION - [LAMBDA (GELT REGION) (* rrb "31-Aug-84 10:15") - - (* determines if the element GELT is inside of the global region REGION) - + [LAMBDA (GELT REGION) (* rrb "31-Aug-84 10:15") + (* determines if the element GELT is + inside of the global region REGION) (APPLY* (SK.INSIDEFN (fetch (GLOBALPART GTYPE) of GELT)) GELT REGION]) ) (DEFINEQ (MAPSKETCHSPECS - [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "10-Sep-84 14:58") - - (* walks through a sketch specification list and applies SPECFN to each of the - individual elements.) + [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "10-Sep-84 14:58") + + (* walks through a sketch specification list and applies SPECFN to each of the + individual elements.) (AND SKSPECS (COND ((SCREENELEMENTP SKSPECS) @@ -5920,10 +5867,10 @@ This will be slow for arcs and curves."] (T (ERROR "unknown figure specification" SKSPECS]) (MAPCOLLECTSKETCHSPECS - [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3 DATUM4) (* rrb "26-Apr-85 09:29") - - (* walks through a sketch specification list and applies SPECFN to each of the - individual (elements returning a list of the results.)) + [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3 DATUM4) (* rrb "26-Apr-85 09:29") + + (* walks through a sketch specification list and applies SPECFN to each of the + individual (elements returning a list of the results.)) (AND SKSPECS (COND ((SCREENELEMENTP SKSPECS) @@ -5934,10 +5881,10 @@ This will be slow for arcs and curves."] (T (ERROR "unknown figure specification" SKSPECS]) (MAPSKETCHSPECSUNTIL - [LAMBDA (SKETCHSPECS SPECFN DATUM DATUM2) (* rrb " 4-AUG-83 15:22") - - (* walks through a sketch specification list and applies SPECFN to each of the - individual elements.) + [LAMBDA (SKETCHSPECS SPECFN DATUM DATUM2) (* rrb " 4-AUG-83 15:22") + + (* walks through a sketch specification list and applies SPECFN to each of the + individual elements.) (AND SKETCHSPECS (COND ((SKETCH.ELEMENT.NAMEP (fetch (SCREENELT GTYPE) of SKETCHSPECS)) @@ -5949,10 +5896,10 @@ This will be slow for arcs and curves."] (T (ERROR "unknown figure specification" SKETCHSPECS]) (MAPGLOBALSKETCHSPECS - [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "19-Feb-85 17:52") - - (* walks through a list of global sketch elements and applies SPECFN to each of - the individual elements.) + [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "19-Feb-85 17:52") + + (* walks through a list of global sketch elements and applies SPECFN to each of + the individual elements.) (AND SKSPECS (COND ((GLOBALELEMENTP SKSPECS) @@ -5963,11 +5910,11 @@ This will be slow for arcs and curves."] (T (ERROR "unknown global sketch element" SKSPECS]) (MAPGLOBALSKETCHELEMENTS - [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "24-Apr-85 15:02") - - (* walks through a list of global sketch elements and applies SPECFN to each of - the individual elements. Differes from MAPGLOBALSKETCHSPECS in that it know - about and gets inside of GROUP elements.) + [LAMBDA (SKSPECS SPECFN DATUM DATUM2 DATUM3) (* rrb "24-Apr-85 15:02") + + (* walks through a list of global sketch elements and applies SPECFN to each of + the individual elements. Differes from MAPGLOBALSKETCHSPECS in that it know about + and gets inside of GROUP elements.) (AND SKSPECS (COND [(GLOBALELEMENTP SKSPECS) @@ -5993,69 +5940,66 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.ADD.SELECTION - [LAMBDA (ITEM/POS WINDOW MARKBM FIRSTFLG) (* rrb " 9-May-85 10:42") + [LAMBDA (ITEM/POS WINDOW MARKBM FIRSTFLG) (* rrb " 9-May-85 10:42") (* adds an item to the selection list  of WINDOW.) (COND ([NOT (MEMBER ITEM/POS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS] - - (* must turning off the element's selection before adding it to the window - selections because the display of the selection check to see if the points are - already selected in another element.) + + (* must turning off the element's selection before adding it to the window + selections because the display of the selection check to see if the points are + already selected in another element.) (SK.SELECT.ELT ITEM/POS WINDOW MARKBM) (WINDOWADDPROP WINDOW 'SKETCH.SELECTIONS ITEM/POS FIRSTFLG]) (SK.COPY.INSERTFN - [LAMBDA (IMAGEOBJ SKW) (* rrb "23-Jun-87 13:25") - - (* * the function that gets called to insert a copy-selection into a sketch - window. Knows how to insert sketches, everything else is text.) + [LAMBDA (IMAGEOBJ SKW) (* rrb "23-Jun-87 13:25") + + (* * the function that gets called to insert a copy-selection into a sketch + window. Knows how to insert sketches, everything else is text.) (PROG (IMAGEOBJYET SELECTION EXTENDSELECTION) - - (* bind the selection so that if the user has to place an image obj, it is - restored before the characters are unBYSYSBUFed) + + (* bind the selection so that if the user has to place an image obj, it is + restored before the characters are unBYSYSBUFed) [bind DATUM for IMOBJ inside IMAGEOBJ do (COND - ((STRINGP IMOBJ) - (BKSYSBUF IMOBJ)) - ((EQ (fetch (IMAGEOBJ IMAGEOBJFNS) of IMOBJ) - SKETCHIMAGEFNS) (* this is a sketch imageobj) - [COND - ((NULL IMAGEOBJYET) (* save SELECTION and - EXTENDSELECTION so they can be - restored) - (SETQ IMAGEOBJYET T) - (SETQ SELECTION (WINDOWPROP SKW 'SELECTION)) - (SETQ EXTENDSELECTION (WINDOWPROP SKW 'EXTENDSELECTION] - (SETQ DATUM (IMAGEOBJPROP IMOBJ 'OBJECTDATUM)) - (OR (SK.INSERT.SKETCH SKW (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) - of DATUM) - (fetch (SKETCHIMAGEOBJ SKIO.REGION) of DATUM) - (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of DATUM)) - (RETURN))) - (T (* insert the image object whatever - it is) - [COND - ((NULL IMAGEOBJYET) (* save SELECTION and - EXTENDSELECTION so they can be - restored) - (SETQ IMAGEOBJYET T) - (SETQ SELECTION (WINDOWPROP SKW 'SELECTION)) - (SETQ EXTENDSELECTION (WINDOWPROP SKW 'EXTENDSELECTION] - (* if the user placed it outside, - just return) - (OR (SK.INSERT.SKETCH SKW [SKETCH.CREATE 'DUMMYNAME 'ELEMENTS - (LIST (SETQ DATUM ( - SK.ELEMENT.FROM.IMAGEOBJ - IMOBJ SKW] - (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) - of (fetch (GLOBALPART INDIVIDUALGLOBALPART) - of DATUM)) - (VIEWER.SCALE SKW)) - (RETURN] + ((STRINGP IMOBJ) + (BKSYSBUF IMOBJ)) + ((EQ (fetch (IMAGEOBJ IMAGEOBJFNS) of IMOBJ) + SKETCHIMAGEFNS) (* this is a sketch imageobj) + [COND + ((NULL IMAGEOBJYET) (* save SELECTION and EXTENDSELECTION + so they can be restored) + (SETQ IMAGEOBJYET T) + (SETQ SELECTION (WINDOWPROP SKW 'SELECTION)) + (SETQ EXTENDSELECTION (WINDOWPROP SKW 'EXTENDSELECTION] + (SETQ DATUM (IMAGEOBJPROP IMOBJ 'OBJECTDATUM)) + (OR (SK.INSERT.SKETCH SKW (fetch (SKETCHIMAGEOBJ SKIO.SKETCH) of DATUM) + (fetch (SKETCHIMAGEOBJ SKIO.REGION) of DATUM) + (fetch (SKETCHIMAGEOBJ SKIO.SCALE) of DATUM)) + (RETURN))) + (T (* insert the image object whatever it + is) + [COND + ((NULL IMAGEOBJYET) (* save SELECTION and EXTENDSELECTION + so they can be restored) + (SETQ IMAGEOBJYET T) + (SETQ SELECTION (WINDOWPROP SKW 'SELECTION)) + (SETQ EXTENDSELECTION (WINDOWPROP SKW 'EXTENDSELECTION] + (* if the user placed it outside, just + return) + (OR (SK.INSERT.SKETCH SKW [SKETCH.CREATE 'DUMMYNAME 'ELEMENTS + (LIST (SETQ DATUM (SK.ELEMENT.FROM.IMAGEOBJ + IMOBJ SKW] + (fetch (SKIMAGEOBJ SKIMOBJ.GLOBALREGION) of (fetch (GLOBALPART + + INDIVIDUALGLOBALPART + ) of DATUM)) + (VIEWER.SCALE SKW)) + (RETURN] (COND (IMAGEOBJYET (* restore the selection) (WINDOWPROP SKW 'SELECTION SELECTION) @@ -6063,9 +6007,9 @@ This will be slow for arcs and curves."] (SKED.SELECTION.FEEDBACK SKW]) (SCREENELEMENTP - [LAMBDA (ELT?) (* rrb "26-Sep-86 14:53") - - (* * returns ELT? if it is a screen element.) + [LAMBDA (ELT?) (* rrb "26-Sep-86 14:53") + + (* * returns ELT? if it is a screen element.) (PROG (X) (RETURN (AND (LISTP ELT?) @@ -6075,10 +6019,10 @@ This will be slow for arcs and curves."] ELT?]) (SK.ITEM.REGION - [LAMBDA (SCRELT) (* rrb "24-Jan-85 17:46") - - (* SCRELT is a sketch element This function returns the region it occupies.) - + [LAMBDA (SCRELT) (* rrb "24-Jan-85 17:46") + (* SCRELT is a sketch element This + function returns the region it + occupies.) (PROG [(REGIONFN (SK.REGIONFN (fetch (SCREENELT GTYPE) of SCRELT] (RETURN (COND ((OR (NULL REGIONFN) @@ -6087,11 +6031,10 @@ This will be slow for arcs and curves."] ((APPLY* REGIONFN SCRELT]) (SK.ELEMENT.GLOBAL.REGION - [LAMBDA (GELT) (* rrb "18-Oct-85 10:30") - - (* GELT is a global sketch element This function returns the global region it - occupies.) - + [LAMBDA (GELT) (* rrb "18-Oct-85 10:30") + (* GELT is a global sketch element + This function returns the global + region it occupies.) (PROG [(REGIONFN (SK.GLOBAL.REGIONFN (fetch (GLOBALPART GTYPE) of GELT] (RETURN (COND ((OR (NULL REGIONFN) @@ -6100,15 +6043,15 @@ This will be slow for arcs and curves."] ((APPLY* REGIONFN GELT]) (SK.LOCAL.ITEMS.IN.REGION - [LAMBDA (HOTSPOTCACHE LEFT BOTTOM RIGHT TOP) (* rrb "31-Jan-85 11:38") - - (* * returns a list of the LOCALITEMS that are within LOCALREGION) - - (* changed to take a hotspot cache instead of a list of local items. - OLD ARGS were (HOTSPOTCACHE LOCALREGION SCALE) OLD CODE - (PROG ((SKREGION (UNSCALE.REGION LOCALREGION SCALE))) - (RETURN (for SCRELT in LOCALITEMS when (SK.INSIDE.REGION - (fetch (SCREENELT GLOBALPART) of SCRELT) SKREGION) collect SCRELT)))) + [LAMBDA (HOTSPOTCACHE LEFT BOTTOM RIGHT TOP) (* rrb "31-Jan-85 11:38") + + (* * returns a list of the LOCALITEMS that are within LOCALREGION) + + (* changed to take a hotspot cache instead of a list of local items. + OLD ARGS were (HOTSPOTCACHE LOCALREGION SCALE) OLD CODE + (PROG ((SKREGION (UNSCALE.REGION LOCALREGION SCALE))) + (RETURN (for SCRELT in LOCALITEMS when (SK.INSIDE.REGION + (fetch (SCREENELT GLOBALPART) of SCRELT) SKREGION) collect SCRELT)))) (PROG ((RLEFT (DIFFERENCE LEFT SK.POINT.WIDTH)) (RBOTTOM (DIFFERENCE BOTTOM SK.POINT.WIDTH)) @@ -6133,48 +6076,48 @@ This will be slow for arcs and curves."] (RETURN ELTS]) (SK.REGIONFN - [LAMBDA (ELEMENTTYPE) (* rrb " 5-Sep-84 16:06") - - (* * access fn for getting the function that returns the region of an item from - its type.) + [LAMBDA (ELEMENTTYPE) (* rrb " 5-Sep-84 16:06") + + (* * access fn for getting the function that returns the region of an item from + its type.) (fetch (SKETCHTYPE REGIONFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.GLOBAL.REGIONFN - [LAMBDA (ELEMENTTYPE) (* rrb "18-Oct-85 10:30") - - (* * access fn for getting the function that returns the global region of a - global sketch element from its type.) + [LAMBDA (ELEMENTTYPE) (* rrb "18-Oct-85 10:30") + + (* * access fn for getting the function that returns the global region of a + global sketch element from its type.) (fetch (SKETCHTYPE GLOBALREGIONFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.REMOVE.SELECTION - [LAMBDA (ITEM/POS WINDOW MARKBM) (* rrb " 9-May-85 10:31") + [LAMBDA (ITEM/POS WINDOW MARKBM) (* rrb " 9-May-85 10:31") (* removes an item from the selection  list of WINDOW.) (COND ((MEMBER ITEM/POS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) - - (* must remove element from window selections before turning off its selection - because the display of the selection check to see if the points are still - selected in another element.) + + (* must remove element from window selections before turning off its selection + because the display of the selection check to see if the points are still + selected in another element.) (WINDOWDELPROP WINDOW 'SKETCH.SELECTIONS ITEM/POS) (SK.DESELECT.ELT ITEM/POS WINDOW MARKBM]) (SK.SELECT.MULTIPLE.ITEMS - [LAMBDA (WINDOW ITEMFLG SELITEMS OPERATION) (* rrb "10-Dec-85 17:34") - - (* * selects allows the user to select a group of the sketch elements from the - sketch WINDOW. If ITEMFLG is NIL, the user is allows to select control points - as well as complete items and the returned value may be the position of a - control point. If SELITEMS is given it is used as the items to be marked and - selected from. Keeps control and probably shouldn't) - - (* the selection protocol is left to add, right to delete. - Multiple clicking in the same place upscales for both select and deselect. - Sweeping will select or deselect all of the items in the swept out area. - Also it keeps control as long as a shift key is down.) + [LAMBDA (WINDOW ITEMFLG SELITEMS OPERATION) (* rrb "10-Dec-85 17:34") + + (* * selects allows the user to select a group of the sketch elements from the + sketch WINDOW. If ITEMFLG is NIL, the user is allows to select control points as + well as complete items and the returned value may be the position of a control + point. If SELITEMS is given it is used as the items to be marked and selected + from. Keeps control and probably shouldn't) + + (* the selection protocol is left to add, right to delete. + Multiple clicking in the same place upscales for both select and deselect. + Sweeping will select or deselect all of the items in the swept out area. + Also it keeps control as long as a shift key is down.) (PROG ((INTERIOR (DSPCLIPPINGREGION NIL WINDOW)) SELECTABLEITEMS HOTSPOTCACHE TIMER NOW OLDX ORIGX NEWX NEWY OLDY ORIGY OUTOFFIRSTPICK @@ -6195,45 +6138,42 @@ This will be slow for arcs and curves."] ((INSIDEP INTERIOR (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (SETQ MOUSEINSIDE? T)) - (T - - (* first press was outside of the window, don't select anything.) - + (T (* first press was outside of the + window, don't select anything.) (SK.TAKE.MARKS.DOWN WINDOW HOTSPOTCACHE) (RETURN))) SELECTLP (COND ((MOUSESTATE UP) (GO SELECTEXIT))) - - (* this label provides an entry for the code that tests if the shift key is - down.) + + (* this label provides an entry for the code that tests if the shift key is down.) SELAFTERTEST (SETQ NEWY (LASTMOUSEY WINDOW)) (SETQ NEWX (LASTMOUSEX WINDOW)) [COND [(NOT MOUSEINSIDE?) - - (* mouse is outside, don't do anything other than wait for it to come back in. - If the user has let up all buttons, the branch to SELECTEXIT will have been - taken.) + + (* mouse is outside, don't do anything other than wait for it to come back in. + If the user has let up all buttons, the branch to SELECTEXIT will have been + taken.) (COND ((INSIDEP INTERIOR NEWX NEWY) (SETQ MOUSEINSIDE? T) (* restore the saved selected items.) (for ELT in SELITEMS do (SK.ADD.SELECTION ELT WINDOW] ((NOT (INSIDEP INTERIOR NEWX NEWY)) - - (* mouse just went outside, remove selections but save them in case mouse comes - back in.) + + (* mouse just went outside, remove selections but save them in case mouse comes + back in.) (SETQ MOUSEINSIDE? NIL) (SETQ SELITEMS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (for ELT in SELITEMS do (SK.REMOVE.SELECTION ELT WINDOW))) [(NEQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) - - (* another button has gone down, mark this as the origin of a new box to sweep.) + + (* another button has gone down, mark this as the origin of a new box to sweep.) (SETQ PREVMOUSEBUTTONS LASTMOUSEBUTTONS) (SETQ ORIGX (LASTMOUSEX WINDOW)) @@ -6242,13 +6182,11 @@ This will be slow for arcs and curves."] ((NULL ITEMFLG) (* clear any selections that are of  single points.) (for SEL in (WINDOWPROP WINDOW 'SKETCH.SELECTIONS) when (POSITIONP SEL) - do (SK.REMOVE.SELECTION SEL WINDOW] - - (* add or delete the element that the button press occurred on if any.) - + do (SK.REMOVE.SELECTION SEL WINDOW] (* add or delete the element that the + button press occurred on if any.) (AND [SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE (create POSITION - XCOORD _ NEWX - YCOORD _ NEWY) + XCOORD ↠NEWX + YCOORD ↠NEWY) (AND (NULL ITEMFLG) (LASTMOUSESTATE (ONLY LEFT)) (NULL (WINDOWPROP WINDOW 'SKETCH.SELECTIONS] @@ -6263,25 +6201,21 @@ This will be slow for arcs and curves."] ((OR (IGREATERP (IABS (IDIFFERENCE ORIGX NEWX)) SK.NO.MOVE.DISTANCE) (IGREATERP (IABS (IDIFFERENCE ORIGY NEWY)) - SK.NO.MOVE.DISTANCE)) - - (* make the first pick move further so that it is easier to multiple click.) - - (SETQ OUTOFFIRSTPICK T))) - - (* cursor has moved more than the minimum amount since last noticed.) - - (* add or delete any with in the swept out area.) - + SK.NO.MOVE.DISTANCE)) (* make the first pick move further so + that it is easier to multiple click.) + (SETQ OUTOFFIRSTPICK T))) (* cursor has moved more than the + minimum amount since last noticed.) + (* add or delete any with in the swept + out area.) (COND ([AND (LASTMOUSESTATE (NOT UP)) (SETQ SELITEMS (SK.LOCAL.ITEMS.IN.REGION HOTSPOTCACHE (MIN ORIGX NEWX) (MIN ORIGY NEWY) (MAX ORIGX NEWX) (MAX ORIGY NEWY] - - (* if selecting multiple things, it must be whole items. - Update NOW to be an item if it isn't already.) + + (* if selecting multiple things, it must be whole items. + Update NOW to be an item if it isn't already.) [COND ((POSITIONP NOW) @@ -6317,9 +6251,9 @@ This will be slow for arcs and curves."] (SK.ADD.SELECTION (SETQ NOW (IN.SKETCH.ELT? HOTSPOTCACHE NOW)) WINDOW)) ((SCREENELEMENTP NOW) - - (* thing now selected is an item, select all selectable items keeping the first - one selected on the front.) + + (* thing now selected is an item, select all selectable items keeping the first + one selected on the front.) (for SELITEM in (SETQ NOW (CONS NOW (REMOVE NOW SELECTABLEITEMS))) do (SK.ADD.SELECTION SELITEM WINDOW] @@ -6327,23 +6261,19 @@ This will be slow for arcs and curves."] (GO CLICKLP))) SHIFTDOWNLP (COND - ((MOUSESTATE (NOT UP)) - - (* button went down again, initialize the button state and click position.) - + ((MOUSESTATE (NOT UP)) (* button went down again, initialize + the button state and click position.) (SETQ PREVMOUSEBUTTONS NIL) (SETQ OUTOFFIRSTPICK NIL) (GO SELAFTERTEST)) ((.SHIFTKEYDOWNP.) - - (* flip selection marks because if cursor is outside when shift key is let up, - nothing is selected.) + + (* flip selection marks because if cursor is outside when shift key is let up, + nothing is selected.) [COND - [(NOT MOUSEINSIDE?) - - (* mouse is outside%: if it comes back in, mark the selections.) - + [(NOT MOUSEINSIDE?) (* mouse is outside%: if it comes back + in, mark the selections.) (COND ((INSIDEP INTERIOR (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) @@ -6358,24 +6288,19 @@ This will be slow for arcs and curves."] (GO SHIFTDOWNLP))) (SETQ SELITEMS (WINDOWPROP WINDOW 'SKETCH.SELECTIONS)) (COND - (MOUSEINSIDE? - - (* unmark and remove the selected items from the window property list.) - + (MOUSEINSIDE? (* unmark and remove the selected + items from the window property list.) (for SEL in SELITEMS do (SK.REMOVE.SELECTION SEL WINDOW))) - (T - - (* they have already been unmarked, just remove them from the window.) - + (T (* they have already been unmarked, + just remove them from the window.) (WINDOWPROP WINDOW 'SKETCH.SELECTIONS NIL))) (SK.TAKE.MARKS.DOWN WINDOW HOTSPOTCACHE) (RETURN SELITEMS]) (SKETCH.GET.ELEMENTS - [LAMBDA (VIEWER SINGLEELEMENTFLG WHICHONES) (* rrb "17-Dec-85 15:35") - - (* hilites the selection points and lets the user select one or more.) - + [LAMBDA (VIEWER SINGLEELEMENTFLG WHICHONES) (* rrb "17-Dec-85 15:35") + (* hilites the selection points and + lets the user select one or more.) (PROG [[SELECTABLEITEMS (COND ((LISTP WHICHONES) (for ELT in WHICHONES collect (COND @@ -6395,53 +6320,49 @@ This will be slow for arcs and curves."] collect (fetch (SCREENELT GLOBALPART) of SCRELT]) (SK.PUT.MARKS.UP - [LAMBDA (SKETCHW HOTSPOTCACHE) (* rrb "29-Jan-85 17:40") - - (* makes sure the selection points are up in a window.) - + [LAMBDA (SKETCHW HOTSPOTCACHE) (* rrb "29-Jan-85 17:40") + (* makes sure the selection points are + up in a window.) (COND ((NULL (WINDOWPROP SKETCHW 'MARKS.UP)) (SK.SHOWMARKS SKETCHW HOTSPOTCACHE) (WINDOWPROP SKETCHW 'MARKS.UP T]) (SK.TAKE.MARKS.DOWN - [LAMBDA (SKETCHW HOTSPOTCACHE) (* rrb "29-Jan-85 17:41") - - (* makes sure the selection points are down in a window.) - + [LAMBDA (SKETCHW HOTSPOTCACHE) (* rrb "29-Jan-85 17:41") + (* makes sure the selection points are + down in a window.) (COND ((WINDOWPROP SKETCHW 'MARKS.UP) (SK.SHOWMARKS SKETCHW HOTSPOTCACHE) (WINDOWPROP SKETCHW 'MARKS.UP NIL]) (SK.TRANSLATE.GLOBALPART - [LAMBDA (GLOBALELT DELTAPOS RETURNELTIFCANTFLG) (* rrb "19-May-86 14:52") - - (* GLOBALELT is a sketch element that was selected for a translate operation. - DELTAPOS is the amount the item is to be translated.) + [LAMBDA (GLOBALELT DELTAPOS RETURNELTIFCANTFLG) (* rrb "19-May-86 14:52") + + (* GLOBALELT is a sketch element that was selected for a translate operation. + DELTAPOS is the amount the item is to be translated.) (PROG ((TRANSLATEFN (SK.TRANSLATEFN (fetch (GLOBALPART GTYPE) of GLOBALELT))) NEWGLOBAL OLDGLOBAL ACTIVEREGION) (RETURN (COND ((OR (NULL TRANSLATEFN) - (EQ TRANSLATEFN 'NILL)) - - (* if can't translate, return the same thing. - This is probably an error condition.) - + (EQ TRANSLATEFN 'NILL)) (* if can't translate, return the same + thing. This is probably an error + condition.) GLOBALELT) ((SETQ NEWGLOBAL (APPLY* TRANSLATEFN GLOBALELT DELTAPOS)) - - (* copy the property list so that undoing works and because this code is used - to make copies too.) + + (* copy the property list so that undoing works and because this code is used to + make copies too.) (SK.COPY.ELEMENT.PROPERTY.LIST NEWGLOBAL) [COND ([AND (SETQ ACTIVEREGION (GETSKETCHELEMENTPROP NEWGLOBAL 'ACTIVEREGION)) (EQUAL ACTIVEREGION (GETSKETCHELEMENTPROP GLOBALELT 'ACTIVEREGION] - - (* update the ACTIVEREGION if the element has one and it is the same in the new - element.) + + (* update the ACTIVEREGION if the element has one and it is the same in the new + element.) (PUTSKETCHELEMENTPROP NEWGLOBAL 'ACTIVEREGION (REL.MOVE.REGION ACTIVEREGION @@ -6450,17 +6371,15 @@ This will be slow for arcs and curves."] (fetch (POSITION YCOORD) of DELTAPOS] NEWGLOBAL) - (RETURNELTIFCANTFLG - - (* in the case of translating a whole sketch, need to return something.) - + (RETURNELTIFCANTFLG (* in the case of translating a whole + sketch, need to return something.) GLOBALELT]) (SK.TRANSLATE.ITEM - [LAMBDA (SELELT GLOBALDELTAPOS W) (* rrb "21-Jan-85 18:35") - - (* SELELT is a sketch element that was selected for a translate operation. - GLOBALDELTAPOS is the amount the item is to be translated.) + [LAMBDA (SELELT GLOBALDELTAPOS W) (* rrb "21-Jan-85 18:35") + + (* SELELT is a sketch element that was selected for a translate operation. + GLOBALDELTAPOS is the amount the item is to be translated.) (PROG (NEWGLOBAL OLDGLOBAL) (COND @@ -6473,19 +6392,19 @@ This will be slow for arcs and curves."] (RETURN NEWGLOBAL]) (SK.TRANSLATEFN - [LAMBDA (ELEMENTTYPE) (* rrb " 4-Sep-84 17:01") + [LAMBDA (ELEMENTTYPE) (* rrb " 4-Sep-84 17:01") (fetch (SKETCHTYPE TRANSLATEFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (TRANSLATE.SKETCH - [LAMBDA (SKETCH NEWXORG NEWYORG) (* rrb " 9-Jul-85 12:36") - - (* * translates all the elements in a sketch to make the new {0, 0} be NEWXORG - NEWYORG) + [LAMBDA (SKETCH NEWXORG NEWYORG) (* rrb " 9-Jul-85 12:36") + + (* * translates all the elements in a sketch to make the new {0, 0} be NEWXORG + NEWYORG) (PROG [(DELTAPOS (create POSITION - XCOORD _ (MINUS NEWXORG) - YCOORD _ (MINUS NEWYORG] - (RETURN (create SKETCH using SKETCH SKETCHELTS _ (for GELT in (fetch (SKETCH SKETCHELTS) + XCOORD ↠(MINUS NEWXORG) + YCOORD ↠(MINUS NEWYORG] + (RETURN (create SKETCH using SKETCH SKETCHELTS ↠(for GELT in (fetch (SKETCH SKETCHELTS) of SKETCH) collect (SK.TRANSLATE.GLOBALPART GELT DELTAPOS T]) @@ -6511,7 +6430,7 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.INPUT.SCALE - [LAMBDA (SKW) (* rrb " 4-Sep-85 15:35") + [LAMBDA (SKW) (* rrb " 4-Sep-85 15:35") (* returns the scale that input should  be) (PROG [(SK (WINDOWPROP SKW 'SKETCHCONTEXT] @@ -6521,19 +6440,16 @@ This will be slow for arcs and curves."] (RETURN NIL))) (RETURN (COND ((fetch (SKETCHCONTEXT SKETCHINPUTSCALE) of SK)) - (T - - (* early form of sketch that doesn't have an input scale.) - + (T (* early form of sketch that doesn't + have an input scale.) (SK.UPDATE.SKETCHCONTEXT SK) (replace (SKETCHCONTEXT SKETCHINPUTSCALE) of SK with 1.0) 1.0]) (SK.UPDATE.SKETCHCONTEXT - [LAMBDA (SKETCHCONTEXT) (* rrb " 4-Sep-85 14:55") - - (* updates an instance of a sketch context to have enough fields.) - + [LAMBDA (SKETCHCONTEXT) (* rrb " 4-Sep-85 14:55") + (* updates an instance of a sketch + context to have enough fields.) (PROG ((NEWSK (CREATE.DEFAULT.SKETCH.CONTEXT))) [COND ((GREATERP (DIFFERENCE (LENGTH NEWSK) @@ -6543,7 +6459,7 @@ This will be slow for arcs and curves."] (RETURN SKETCHCONTEXT]) (SK.SET.INPUT.SCALE - [LAMBDA (W) (* rrb "19-Aug-86 11:52") + [LAMBDA (W) (* rrb "19-Aug-86 11:52") (* sets the size of the  (input scale)) (SK.SET.INPUT.SCALE.VALUE (RNUMBER (CONCAT "Input scale is now " (SK.INPUT.SCALE W) @@ -6554,15 +6470,14 @@ This will be slow for arcs and curves."] W]) (SK.SET.INPUT.SCALE.CURRENT - [LAMBDA (W) (* rrb "11-Jul-86 15:51") - - (* sets the size of the input scale to the scale of the current window.) - + [LAMBDA (W) (* rrb "11-Jul-86 15:51") + (* sets the size of the input scale to + the scale of the current window.) (SK.SET.INPUT.SCALE.VALUE (VIEWER.SCALE W) W]) (SK.SET.INPUT.SCALE.VALUE - [LAMBDA (NEWINPUTSCALE SKW) (* rrb "14-May-86 19:29") + [LAMBDA (NEWINPUTSCALE SKW) (* rrb "14-May-86 19:29") (* sets the input scale to  NEWINPUTSCALE) (AND (NUMBERP NEWINPUTSCALE) @@ -6578,14 +6493,14 @@ This will be slow for arcs and curves."] (DEFINEQ (SK.SET.FEEDBACK.MODE - [LAMBDA (VALUE) (* rrb "19-Nov-85 13:25") - - (* sets the control on how much feedback to give the user as they are entering - new figure elements.) + [LAMBDA (VALUE) (* rrb "19-Nov-85 13:25") + + (* sets the control on how much feedback to give the user as they are entering + new figure elements.) [OR (MEMB VALUE '(POINTS T ALWAYS)) (SETQ VALUE (\CURSOR.IN.MIDDLE.MENU (create MENU - ITEMS _ '(("Points only" 'POINTS + ITEMS ↠'(("Points only" 'POINTS "Only the control points will be shown when entering elements." ) ("Fast figures" T @@ -6594,7 +6509,7 @@ This will be slow for arcs and curves."] ("All figures" 'ALWAYS "Most elements are shown while they are being entered. This will be slow for arcs and curves.")) - CENTERFLG _ T] + CENTERFLG ↠T] (AND VALUE (SETQ SKETCH.VERBOSE.FEEDBACK (SELECTQ VALUE (POINTS NIL) VALUE]) @@ -6604,10 +6519,8 @@ This will be slow for arcs and curves.")) (SK.SET.FEEDBACK.MODE 'POINTS]) (SK.SET.FEEDBACK.VERBOSE - [LAMBDA NIL - - (* sets the feedback to provide images on elements that are fast.) - + [LAMBDA NIL (* sets the feedback to provide images + on elements that are fast.) (SK.SET.FEEDBACK.MODE T]) (SK.SET.FEEDBACK.ALWAYS @@ -6635,8 +6548,34 @@ This will be slow for arcs and curves.")) (fetch (SKETCH SKETCHNAME) of (INSURE.SKETCH SKW]) (SK.SHRINK.ICONCREATE -(LAMBDA (W OLD-ICON POSITION) (* ; "Edited 25-Apr-88 15:44 by drc:") (* ;;; "Create the icon that represents this window.") (LET ((ICONTITLE (WINDOWPROP W (QUOTE SKETCH.ICON.TITLE))) (TITLE (SKETCH.TITLE W)) (ICON (OR OLD-ICON (WINDOWPROP W (QUOTE ICON))))) (COND (ICON (CL:UNLESS (OR (EQUAL ICONTITLE TITLE) (NOT ICONTITLE)) (* ;; "if we built this and the title is the same, or he has already put an icon on this, then we don't need to update it.") (SETQ ICONTITLE (OR TITLE "")) (WINDOWPROP W (QUOTE SKETCH.ICON.TITLE) ICONTITLE) (ICONTITLE ICONTITLE NIL NIL ICON)) ICON) (T (* ;; "make a new icon. Give it a title of '' so it can be distinguished from an ICON that the user supplied without an ICONTITLE.") (SETQ ICONTITLE (OR TITLE "")) (WINDOWPROP W (QUOTE SKETCH.ICON.TITLE) ICONTITLE) (TITLEDICONW SKETCH.TITLED.ICON.TEMPLATE ICONTITLE (COND ((NEQ TEDIT.ICON.FONT (QUOTE NOBIND)) TEDIT.ICON.FONT) (T (DEFAULTFONT (QUOTE DISPLAY)))) POSITION T NIL (QUOTE FILE)))))) -) + [LAMBDA (W OLD-ICON POSITION) (* ; "Edited 25-Apr-88 15:44 by drc:") + +(* ;;; "Create the icon that represents this window.") + + (LET [(ICONTITLE (WINDOWPROP W 'SKETCH.ICON.TITLE)) + (TITLE (SKETCH.TITLE W)) + (ICON (OR OLD-ICON (WINDOWPROP W 'ICON] + (COND + (ICON (CL:UNLESS (OR (EQUAL ICONTITLE TITLE) + (NOT ICONTITLE)) + + (* ;; "if we built this and the title is the same, or he has already put an icon on this, then we don't need to update it.") + + (SETQ ICONTITLE (OR TITLE "")) + (WINDOWPROP W 'SKETCH.ICON.TITLE ICONTITLE) + (ICONTITLE ICONTITLE NIL NIL ICON)) + ICON) + (T + (* ;; "make a new icon. Give it a title of '' so it can be distinguished from an ICON that the user supplied without an ICONTITLE.") + + (SETQ ICONTITLE (OR TITLE "")) + (WINDOWPROP W 'SKETCH.ICON.TITLE ICONTITLE) + (TITLEDICONW SKETCH.TITLED.ICON.TEMPLATE ICONTITLE [COND + ((NEQ TEDIT.ICON.FONT + 'NOBIND) + TEDIT.ICON.FONT) + (T (DEFAULTFONT 'DISPLAY] + POSITION T NIL 'FILE]) ) (READVARS-FROM-STRINGS '(SKETCH.TITLED.ICON.TEMPLATE) @@ -6840,15 +6779,15 @@ This will be slow for arcs and curves.")) (DEFINEQ (READBRUSHSHAPE - [LAMBDA NIL (* rrb " 6-Nov-85 09:57") + [LAMBDA NIL (* rrb " 6-Nov-85 09:57") (* reads a brush shape from the user.) (\CURSOR.IN.MIDDLE.MENU (create MENU - CENTERFLG _ T - TITLE _ "pick a shape" - ITEMS _ '(ROUND SQUARE VERTICAL HORIZONTAL DIAGONAL]) + CENTERFLG ↠T + TITLE ↠"pick a shape" + ITEMS ↠'(ROUND SQUARE VERTICAL HORIZONTAL DIAGONAL]) (READ.FUNCTION - [LAMBDA (PRMPT W) (* rrb "11-May-84 15:41") + [LAMBDA (PRMPT W) (* rrb "11-May-84 15:41") (PROG ((PROMPTWIN (GETPROMPTWINDOW W 3)) OLDTTYDS LST) (SETQ OLDTTYDS (TTYDISPLAYSTREAM PROMPTWIN)) @@ -6861,7 +6800,7 @@ This will be slow for arcs and curves.")) (RETURN (CAR LST]) (READBRUSHSIZE - [LAMBDA (NOWSIZE) (* rrb "19-May-86 15:44") + [LAMBDA (NOWSIZE) (* rrb "19-May-86 15:44") (PROG ((N (RNUMBER (COND (NOWSIZE (CONCAT "Current size is " NOWSIZE ". Enter new brush size.")) (T "Enter new brush size.")) @@ -6872,7 +6811,7 @@ This will be slow for arcs and curves.")) (N (ABS N]) (READANGLE - [LAMBDA NIL (* rrb "14-May-86 19:29") + [LAMBDA NIL (* rrb "14-May-86 19:29") (* interacts to get an angle from the  user.) (PROG ((NEWVALUE (RNUMBER "Enter arc angle in degrees." NIL NIL NIL T NIL T))) @@ -6882,38 +6821,37 @@ This will be slow for arcs and curves.")) (T NEWVALUE]) (READARCDIRECTION - [LAMBDA (MENUTITLE) (* rrb " 6-Nov-85 09:53") - - (* interacts to get whether an arc should go clockwise or counterclockwise) - + [LAMBDA (MENUTITLE) (* rrb " 6-Nov-85 09:53") + (* interacts to get whether an arc + should go clockwise or + counterclockwise) (\CURSOR.IN.MIDDLE.MENU (create MENU - TITLE _ (OR MENUTITLE "Which way should the arc go?") - ITEMS _ '(("Clockwise" 'CLOCKWISE + TITLE ↠(OR MENUTITLE "Which way should the arc go?") + ITEMS ↠'(("Clockwise" 'CLOCKWISE "The arc will be drawn clockwise from the first point to the second point." ) ("Counterclockwise" 'COUNTERCLOCKWISE "The arc will be drawn counterclockwise from the first point to the second point." )) - CENTERFLG _ T]) + CENTERFLG ↠T]) ) (DEFINEQ (SK.CHANGE.DASHING - [LAMBDA (ELTWITHLINE DASHING SKW) (* rrb " 9-Jan-86 16:58") - - (* changes the line dashing of ELTWITHLINE if it has one) - - (* knows about the various types of sketch elements and shouldn't.) - + [LAMBDA (ELTWITHLINE DASHING SKW) (* rrb " 9-Jan-86 16:58") + (* changes the line dashing of + ELTWITHLINE if it has one) + (* knows about the various types of + sketch elements and shouldn't.) (PROG (SIZE GLINELT TYPE NEWDASHING NOWDASHING 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.) (SETQ GLINELT (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELTWITHLINE)) - - (* the dashing may be stored in different places for the element types.) - + (* the dashing may be stored in + different places for the element + types.) [SETQ NEWDASHING (COND ((EQ DASHING 'NONE) (* no dashing is marked with NIL) NIL) @@ -6931,39 +6869,37 @@ This will be slow for arcs and curves.")) (ELLIPSE (fetch (ELLIPSE DASHING) of GLINELT)) (SHOULDNT))) (COND - ((EQUAL NEWDASHING NOWDASHING) - - (* if dashing isn't changing, don't bother creating a new one and repainting.) - + ((EQUAL NEWDASHING NOWDASHING) (* if dashing isn't changing, don't + bother creating a new one and + repainting.) (RETURN))) (SETQ NEWELT (SELECTQ TYPE - (WIRE (create WIRE using GLINELT OPENWIREDASHING _ NEWDASHING)) - (BOX (create BOX using GLINELT BOXDASHING _ NEWDASHING)) - (ARC (create ARC using GLINELT ARCDASHING _ NEWDASHING)) - (TEXTBOX (create TEXTBOX using GLINELT TEXTBOXDASHING _ NEWDASHING)) - (CLOSEDWIRE (create CLOSEDWIRE using GLINELT CLOSEDWIREDASHING _ + (WIRE (create WIRE using GLINELT OPENWIREDASHING ↠NEWDASHING)) + (BOX (create BOX using GLINELT BOXDASHING ↠NEWDASHING)) + (ARC (create ARC using GLINELT ARCDASHING ↠NEWDASHING)) + (TEXTBOX (create TEXTBOX using GLINELT TEXTBOXDASHING ↠NEWDASHING)) + (CLOSEDWIRE (create CLOSEDWIRE using GLINELT CLOSEDWIREDASHING ↠NEWDASHING)) - (CLOSEDCURVE (create CLOSEDCURVE using GLINELT DASHING _ NEWDASHING)) - (OPENCURVE (create OPENCURVE using GLINELT DASHING _ NEWDASHING)) - (CIRCLE (create CIRCLE using GLINELT DASHING _ NEWDASHING)) - (ELLIPSE (create ELLIPSE using GLINELT DASHING _ NEWDASHING)) + (CLOSEDCURVE (create CLOSEDCURVE using GLINELT DASHING ↠NEWDASHING)) + (OPENCURVE (create OPENCURVE using GLINELT DASHING ↠NEWDASHING)) + (CIRCLE (create CIRCLE using GLINELT DASHING ↠NEWDASHING)) + (ELLIPSE (create ELLIPSE using GLINELT DASHING ↠NEWDASHING)) (SHOULDNT))) (RETURN (create SKHISTORYCHANGESPEC - NEWELT _ (create GLOBALPART - COMMONGLOBALPART _ (fetch (GLOBALPART COMMONGLOBALPART) + NEWELT ↠(create GLOBALPART + COMMONGLOBALPART ↠(fetch (GLOBALPART COMMONGLOBALPART) of ELTWITHLINE) - INDIVIDUALGLOBALPART _ NEWELT) - OLDELT _ ELTWITHLINE - PROPERTY _ 'DASHING - NEWVALUE _ NEWDASHING - OLDVALUE _ NOWDASHING]) + INDIVIDUALGLOBALPART ↠NEWELT) + OLDELT ↠ELTWITHLINE + PROPERTY ↠'DASHING + NEWVALUE ↠NEWDASHING + OLDVALUE ↠NOWDASHING]) (READ.AND.SAVE.NEW.DASHING - [LAMBDA NIL (* rrb " 6-Nov-85 09:57") - - (* reads a new dashing, confirms it with the user and adds it to - SK.DASHING.PATTERNS) - + [LAMBDA NIL (* rrb " 6-Nov-85 09:57") + (* reads a new dashing, confirms it + with the user and adds it to + SK.DASHING.PATTERNS) (PROG (DASHING BM) LP (COND ((NULL (SETQ DASHING (READ.NEW.DASHING))) (* user aborted) @@ -6971,15 +6907,15 @@ This will be slow for arcs and curves.")) (SETQ BM (SK.DASHING.LABEL DASHING)) CONFIRM (SELECTQ (\CURSOR.IN.MIDDLE.MENU (create MENU - ITEMS _ (LIST (LIST BM T + ITEMS ↠(LIST (LIST BM T "Will use this as the dashing pattern." ) '(Yes T "Will accept this pattern.") '(No 'NO "Will ask you for another dashing pattern." )) - CENTERFLG _ T - TITLE _ "Is this pattern OK?")) + CENTERFLG ↠T + TITLE ↠"Is this pattern OK?")) (NO (GO LP)) (T (* add dashing to global list and  return it.) @@ -6991,15 +6927,15 @@ This will be slow for arcs and curves.")) (GO CONFIRM]) (READ.NEW.DASHING - [LAMBDA NIL (* rrb "14-May-86 19:30") + [LAMBDA NIL (* rrb "14-May-86 19:30") (* reads a value of dashing from the  user.) (PROMPTPRINT "You will be prompted for a series of numbers which specify the number of points ON and OFF. Enter 0 to end the dashing pattern. Enter 'Abort' to leave the dashing unchanged.") - (bind VAL DASHLST OFF? (ORIGPOS _ (create POSITION - XCOORD _ LASTMOUSEX - YCOORD _ LASTMOUSEY)) + (bind VAL DASHLST OFF? (ORIGPOS ↠(create POSITION + XCOORD ↠LASTMOUSEX + YCOORD ↠LASTMOUSEY)) until (OR (EQ (SETQ VAL (RNUMBER (CONCAT "Enter the number of points " (COND (OFF? 'OFF) (T 'ON)) @@ -7017,16 +6953,16 @@ Enter 'Abort' to leave the dashing unchanged.") (READ.DASHING.CHANGE [LAMBDA NIL - (DECLARE (GLOBALVARS SK.DASHING.PATTERNS)) (* rrb " 6-Nov-85 09:57") - - (* gets a description of how to change the arrow heads of a wire or curve.) + (DECLARE (GLOBALVARS SK.DASHING.PATTERNS)) (* rrb " 6-Nov-85 09:57") + + (* gets a description of how to change the arrow heads of a wire or curve.) (PROG (DASHING) (SELECTQ [SETQ DASHING (\CURSOR.IN.MIDDLE.MENU (create MENU - CENTERFLG _ T - TITLE _ "New dashing pattern?" - ITEMS _ (APPEND (for DASHPAT in SK.DASHING.PATTERNS + CENTERFLG ↠T + TITLE ↠"New dashing pattern?" + ITEMS ↠(APPEND (for DASHPAT in SK.DASHING.PATTERNS collect (LIST (CAR DASHPAT) (KWOTE (CADR DASHPAT)) @@ -7040,10 +6976,9 @@ Enter 'Abort' to leave the dashing unchanged.") (RETURN DASHING]) (SK.CACHE.DASHING - [LAMBDA (DASHING BITMAP) (* rrb " 3-May-85 14:33") - - (* adds a dashing and its bitmap label to the global cache.) - + [LAMBDA (DASHING BITMAP) (* rrb " 3-May-85 14:33") + (* adds a dashing and its bitmap label + to the global cache.) (OR (for DASH in SK.DASHING.PATTERNS when (EQUAL (CADR DASH) DASHING) do (RETURN T)) (COND @@ -7057,7 +6992,7 @@ Enter 'Abort' to leave the dashing unchanged.") DASHING]) (SK.DASHING.LABEL - [LAMBDA (DASHING) (* rrb " 3-May-85 14:32") + [LAMBDA (DASHING) (* rrb " 3-May-85 14:32") (* creates a bitmap label which shows  a dashing pattern.) (PROG (DS BM) @@ -7068,38 +7003,37 @@ Enter 'Abort' to leave the dashing unchanged.") (DEFINEQ (READ.FILLING.CHANGE - [LAMBDA NIL (* rrb " 6-Nov-85 09:58") + [LAMBDA NIL (* rrb " 6-Nov-85 09:58") (* reads a shade for the filling  texture.) (PROG (FILLING) (SELECTQ (SETQ FILLING (\CURSOR.IN.MIDDLE.MENU (create MENU - CENTERFLG _ T - TITLE _ "New filling?" - ITEMS _ [APPEND (for FILLPAT in SK.FILLING.PATTERNS + CENTERFLG ↠T + TITLE ↠"New filling?" + ITEMS ↠[APPEND (for FILLPAT in SK.FILLING.PATTERNS collect (LIST (CAR FILLPAT) (KWOTE (CADR FILLPAT)) "changes filling to this pattern" )) - '(("4x4 shade" '|4X4| + '(("4x4 shade" '4X4 "Allows creation of a 4 bits by 4 bits shade" ) - ("16x16 shade" '|16X16| + ("16x16 shade" '16X16 "Allows creation of a 16 bits by 16 bits shade" ) ("No filling" 'NONE "no filling will be used."] - MENUBORDERSIZE _ 1))) - (|4X4| (RETURN (READ.AND.SAVE.NEW.FILLING))) - (|16X16| (RETURN (READ.AND.SAVE.NEW.FILLING T))) + MENUBORDERSIZE ↠1))) + (4X4 (RETURN (READ.AND.SAVE.NEW.FILLING))) + (16X16 (RETURN (READ.AND.SAVE.NEW.FILLING T))) (RETURN FILLING]) (SK.CACHE.FILLING - [LAMBDA (FILLING) (* rrb " 8-Jun-85 14:58") - - (* adds a dashing and its bitmap label to the global cache.) - + [LAMBDA (FILLING) (* rrb " 8-Jun-85 14:58") + (* adds a dashing and its bitmap label + to the global cache.) (OR (for FILL in SK.FILLING.PATTERNS when (EQUAL (CADR FILL) FILLING) do (RETURN T)) (COND @@ -7110,11 +7044,10 @@ Enter 'Abort' to leave the dashing unchanged.") 'ADDED]) (READ.AND.SAVE.NEW.FILLING - [LAMBDA (16X16FLG) (* rrb " 8-Jun-85 14:58") - - (* reads a new filling, confirms it with the user and adds it to - SK.FILLING.PATTERNS) - + [LAMBDA (16X16FLG) (* rrb " 8-Jun-85 14:58") + (* reads a new filling, confirms it + with the user and adds it to + SK.FILLING.PATTERNS) (PROG (FILLING) (COND ([NULL (SETQ FILLING (EDITSHADE (COND @@ -7125,10 +7058,9 @@ Enter 'Abort' to leave the dashing unchanged.") (RETURN FILLING]) (SK.FILLING.LABEL - [LAMBDA (FILLING) (* rrb " 8-Jun-85 12:08") - - (* creates a bitmap label which fills it with the texture FILLING.) - + [LAMBDA (FILLING) (* rrb " 8-Jun-85 12:08") + (* creates a bitmap label which fills + it with the texture FILLING.) (PROG [(BM (BITMAPCREATE (PLUS 8 (STRINGWIDTH "16x16 shade" MENUFONT)) (FONTPROP MENUFONT 'HEIGHT] (BLTSHADE FILLING BM) @@ -7160,21 +7092,20 @@ Enter 'Abort' to leave the dashing unchanged.") (DEFINEQ (SK.GETGLOBALPOSITION - [LAMBDA (W CURSOR) (* rrb "20-May-86 10:56") - - (* gets a position from the user and returns the global value of it.) - + [LAMBDA (W CURSOR) (* rrb "20-May-86 10:56") + (* gets a position from the user and + returns the global value of it.) (SK.MAP.INPUT.PT.TO.GLOBAL (SK.READ.POINT.WITH.FEEDBACK W CURSOR) W]) (SKETCH.TRACK.ELEMENTS - [LAMBDA (ELEMENTS VIEWER CONSTRAINTFN HOTSPOT PROMPTMSG CONSTRAINTDATA FEEDBACKFN NOINITIALERASEFLG - NOFINALPAINTFLG) (* rrb "22-Jul-86 14:41") - - (* gets a point from the user by displaying an image of ELEMENTS. - It calls CONSTRAINTFN everytime the cursor moves to allow user constraints on - where the image is displayed. All positions and elements are in sketch - coordinates.) + [LAMBDA (ELEMENTS VIEWER CONSTRAINTFN HOTSPOT PROMPTMSG CONSTRAINTDATA FEEDBACKFN NOINITIALERASEFLG + NOFINALPAINTFLG) (* rrb "22-Jul-86 14:41") + + (* gets a point from the user by displaying an image of ELEMENTS. + It calls CONSTRAINTFN everytime the cursor moves to allow user constraints on + where the image is displayed. All positions and elements are in sketch + coordinates.) (PROG (SCRELTS FIGINFO FIRSTHOTSPOT GLOBALHOTSPOT NEWPOS LOWLFT IMAGEPOSX IMAGEPOSY IMAGEBM DELTAPOS NEWGLOBALS SKETCH GDELTAPOS) @@ -7218,10 +7149,10 @@ Enter 'Abort' to leave the dashing unchanged.") (RETURN (AND NEWPOS (PTDIFFERENCE NEWPOS GLOBALHOTSPOT]) (SK.PICKOUT.WHOLE.MOVE.ELEMENTS - [LAMBDA (MOVEELTLST) (* rrb "13-Dec-85 11:54") - - (* returns from a list of sketch elements that are being moved, the ones that - will be completely moved) + [LAMBDA (MOVEELTLST) (* rrb "13-Dec-85 11:54") + + (* returns from a list of sketch elements that are being moved, the ones that + will be completely moved) (COND ((EQ (CAR MOVEELTLST) @@ -7234,32 +7165,32 @@ Enter 'Abort' to leave the dashing unchanged.") T) collect (CDR X]) (MAP.SKETCH.ELEMENTS.INTO.VIEWER - [LAMBDA (ELEMENTS VIEWER) (* rrb "12-Dec-85 12:25") + [LAMBDA (ELEMENTS VIEWER) (* rrb "12-Dec-85 12:25") (* maps a list of elements into a  viewer) (for SKELT in ELEMENTS collect (SK.LOCAL.FROM.GLOBAL SKELT VIEWER]) (MAP.GLOBAL.POSITION.INTO.VIEWER - [LAMBDA (GPOS VIEWER) (* rrb "11-Jul-86 15:54") + [LAMBDA (GPOS VIEWER) (* rrb "11-Jul-86 15:54") (* maps a sketch coordinate into a  viewer coordinate.) (SK.SCALE.POSITION.INTO.VIEWER GPOS (VIEWER.SCALE VIEWER]) (SKETCH.TO.VIEWER.POSITION - [LAMBDA (POSITION VIEWERSCALE) (* rrb "11-Jul-86 15:54") - - (* Transforms a position from sketch coordinates into viewer coordinates. - VIEWERSCALE can be a scale or a viewer.) + [LAMBDA (POSITION VIEWERSCALE) (* rrb "11-Jul-86 15:54") + + (* Transforms a position from sketch coordinates into viewer coordinates. + VIEWERSCALE can be a scale or a viewer.) (SK.SCALE.POSITION.INTO.VIEWER POSITION (SK.INSURE.SCALE VIEWERSCALE]) (SKETCH.TRACK.IMAGE - [LAMBDA (WINDOW BITMAP OPERATION MSG XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN) + [LAMBDA (WINDOW BITMAP OPERATION MSG XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN) (* rrb "11-Jun-86 13:44") - - (* gets a position by tracking with a and calling a user provided constraint - function. The spec returns is actually (ONGRID? position) so that caller can - tell whether it was placed on grid or not.) + + (* gets a position by tracking with a and calling a user provided constraint + function. The spec returns is actually (ONGRID? position) so that caller can tell + whether it was placed on grid or not.) (PROG (WIDTH HEIGHT) (SETQ WIDTH (BITMAPWIDTH BITMAP)) @@ -7271,15 +7202,14 @@ Enter 'Abort' to leave the dashing unchanged.") XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN]) (SK.TRACK.IMAGE1 - [LAMBDA (W BITMAP BUFFER.BITMAP WIDTH HEIGHT OPERATION XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA - FEEDBACKFN) (* rrb "11-Jun-86 13:59") - - (* tracks BITMAP until a button goes down and comes up. - It calls CONSTRAINTFN to determine the position at which to display the image. - Returns a point in global space that the image was placed.) - - (* there is other code in BIGFONT that is probably better for this.) + [LAMBDA (W BITMAP BUFFER.BITMAP WIDTH HEIGHT OPERATION XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA + FEEDBACKFN) (* rrb "11-Jun-86 13:59") + (* tracks BITMAP until a button goes down and comes up. + It calls CONSTRAINTFN to determine the position at which to display the image. + Returns a point in global space that the image was placed.) + (* there is other code in BIGFONT that + is probably better for this.) (PROG (READPT) (SETQ READPT (SK.TRACK.BITMAP1 W BITMAP BUFFER.BITMAP WIDTH HEIGHT OPERATION XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA FEEDBACKFN)) @@ -7293,20 +7223,20 @@ Enter 'Abort' to leave the dashing unchanged.") (create POSITION]) (MAP.VIEWER.XY.INTO.GLOBAL - [LAMBDA (X Y VIEWER ONGRID? SCRATCHPT) (* rrb "11-Jul-86 15:52") - - (* maps from an x y pair in a window to the corresponding global position. - ONGRID? is T if the X Y should be interpreted as being on the grid. - SCRATCHPT is a scratch position that should be clobbered with the result.) + [LAMBDA (X Y VIEWER ONGRID? SCRATCHPT) (* rrb "11-Jul-86 15:52") + + (* maps from an x y pair in a window to the corresponding global position. + ONGRID? is T if the X Y should be interpreted as being on the grid. + SCRATCHPT is a scratch position that should be clobbered with the result.) (PROG ((SCALE (VIEWER.SCALE VIEWER)) GRID) [COND (ONGRID? (SETQ GRID (SK.GRIDFACTOR VIEWER))) (T - - (* map the point onto a grid location that would have the same screen position - as the given point.) + + (* map the point onto a grid location that would have the same screen position as + the given point.) (SETQ GRID (GREATESTPOWEROF2LT SCALE] (RETURN (SK.SET.POSITION (NEAREST.ON.GRID (TIMES X SCALE) @@ -7316,43 +7246,42 @@ Enter 'Abort' to leave the dashing unchanged.") SCRATCHPT]) (SK.SET.POSITION - [LAMBDA (X Y POSITION) (* rrb "21-May-86 16:09") - - (* sets the x and y coordinate fields of a position.) - + [LAMBDA (X Y POSITION) (* rrb "21-May-86 16:09") + (* sets the x and y coordinate fields + of a position.) (replace (POSITION XCOORD) of POSITION with X) (replace (POSITION YCOORD) of POSITION with Y) POSITION]) (MAP.VIEWER.PT.INTO.GLOBAL - [LAMBDA (PT VIEWER ONGRID?) (* rrb "11-Jul-86 15:52") - - (* maps from an PT in a window to the corresponding global position. - ONGRID? is T if the PT should be interpreted as being on the grid.) + [LAMBDA (PT VIEWER ONGRID?) (* rrb "11-Jul-86 15:52") + + (* maps from an PT in a window to the corresponding global position. + ONGRID? is T if the PT should be interpreted as being on the grid.) (PROG ((SCALE (VIEWER.SCALE VIEWER)) GRID) [COND (ONGRID? (SETQ GRID (SK.GRIDFACTOR VIEWER))) (T - - (* map the point onto a grid location that would have the same screen position - as the given point.) + + (* map the point onto a grid location that would have the same screen position as + the given point.) (SETQ GRID (GREATESTPOWEROF2LT SCALE] (RETURN (create POSITION - XCOORD _ (NEAREST.ON.GRID (TIMES (fetch (POSITION XCOORD) of PT) + XCOORD ↠(NEAREST.ON.GRID (TIMES (fetch (POSITION XCOORD) of PT) SCALE) GRID) - YCOORD _ (NEAREST.ON.GRID (TIMES (fetch (POSITION YCOORD) of PT) + YCOORD ↠(NEAREST.ON.GRID (TIMES (fetch (POSITION YCOORD) of PT) SCALE) GRID]) (VIEWER.TO.SKETCH.POSITION - [LAMBDA (POSITION VIEWERSCALE) (* rrb "11-Jul-86 15:56") - - (* Transforms a position from viewer coordinates into sketch coordinates. - VIEWERSCALE can be a scale or a viewer.) + [LAMBDA (POSITION VIEWERSCALE) (* rrb "11-Jul-86 15:56") + + (* Transforms a position from viewer coordinates into sketch coordinates. + VIEWERSCALE can be a scale or a viewer.) (SK.UNSCALE.POSITION.FROM.VIEWER POSITION (COND ((NUMBERP VIEWERSCALE)) @@ -7361,7 +7290,7 @@ Enter 'Abort' to leave the dashing unchanged.") (T (\ILLEGAL.ARG VIEWERSCALE]) (SK.INSURE.SCALE - [LAMBDA (VIEWERSCALE) (* rrb "11-Jul-86 15:52") + [LAMBDA (VIEWERSCALE) (* rrb "11-Jul-86 15:52") (COND ((NUMBERP VIEWERSCALE)) ((WINDOWP VIEWERSCALE) @@ -7369,10 +7298,10 @@ Enter 'Abort' to leave the dashing unchanged.") (T (\ILLEGAL.ARG VIEWERSCALE]) (SKETCH.TO.VIEWER.REGION - [LAMBDA (REGION VIEWERSCALE) (* rrb " 6-Jun-86 14:05") - - (* Transforms a region from sketch coordinates into viewer coordinates. - VIEWERSCALE can be a scale or a viewer.) + [LAMBDA (REGION VIEWERSCALE) (* rrb " 6-Jun-86 14:05") + + (* Transforms a region from sketch coordinates into viewer coordinates. + VIEWERSCALE can be a scale or a viewer.) (PROG ((SCALE (SK.INSURE.SCALE VIEWERSCALE))) (RETURN (CREATEREGION (QUOTIENT (fetch (REGION LEFT) of REGION) @@ -7385,175 +7314,169 @@ Enter 'Abort' to leave the dashing unchanged.") SCALE]) (VIEWER.TO.SKETCH.REGION - [LAMBDA (REGION VIEWERSCALE) (* rrb " 6-Jun-86 14:05") - - (* Transforms a region from viewer coordinates into sketch coordinates. - VIEWERSCALE can be a scale or a viewer.) + [LAMBDA (REGION VIEWERSCALE) (* rrb " 6-Jun-86 14:05") + + (* Transforms a region from viewer coordinates into sketch coordinates. + VIEWERSCALE can be a scale or a viewer.) (UNSCALE.REGION REGION (SK.INSURE.SCALE VIEWERSCALE]) (SK.READ.POINT.WITH.FEEDBACK - [LAMBDA (WINDOW CURSOR FEEDBACKFN FEEDBACKFNDATA BUTTONFOREXISTINGPTS CONSTRAINTFN NUMBERPADTOOFLG) + [LAMBDA (WINDOW CURSOR FEEDBACKFN FEEDBACKFNDATA BUTTONFOREXISTINGPTS CONSTRAINTFN NUMBERPADTOOFLG) (* rrb "11-Jul-86 15:52") - - (* internal function that reads a point from the user. - Each time the cursor moves, a feedback fn is called passing it the new X, new - Y, WINDOW and FEEDBACKDATA It is expected to XOR something on the screen that - tells the user something.) - (RESETLST (RESETSAVE (CURSOR (OR CURSOR CROSSHAIRS))) - (RESETSAVE NIL (LIST 'DSPOPERATION (DSPOPERATION 'INVERT WINDOW) - WINDOW)) - (PROG ((USEGRID (WINDOWPROP WINDOW 'USEGRID)) - (GRID (SK.GRIDFACTOR WINDOW)) - (SCALE (VIEWER.SCALE WINDOW)) - (HOTSPOTCACHE (SK.HOTSPOT.CACHE WINDOW)) - (SCRATCHPT (AND CONSTRAINTFN (create POSITION))) - XSCREEN YSCREEN XGRID YGRID NEWX NEWY MOUSEDOWN LASTBUTTONSTATE ONGRID? NEARPOS - CONSTRAINTPT POSITIONPAD) - (OR FEEDBACKFN (SETQ FEEDBACKFN 'SHOWSKETCHXY)) - [COND - (NUMBERPADTOOFLG - - (* IT WOULD BE NICER TO PUT THE POSITION READER OVERTOP OF THE MENU BUT THIS - ROUTINE IS CALLED SEVERAL TIMES BY SEVERAL OF THE POINT READERS AND IT FLIPS UP - AND DOWN SO STILL NEEDS MORE WORK TO GET RIGHT - (* detach the window menu so that it doesn't come to top over the position - reader.) (AND (OPENWP (SETQ MENUW (SK.INSURE.HAS.MENU WINDOW))) - (RESETSAVE (DETACHWINDOW MENUW) (LIST (QUOTE SK.FIX.MENU) WINDOW)))) + (* internal function that reads a point from the user. + Each time the cursor moves, a feedback fn is called passing it the new X, new Y, + WINDOW and FEEDBACKDATA It is expected to XOR something on the screen that tells + the user something.) - (RESETSAVE NIL (LIST 'CLOSEW (SETQ POSITIONPAD ( - SK.POSITION.PAD.FROM.VIEWER - WINDOW] - (RETURN (PROG1 (until [PROGN (GETMOUSESTATE) - (COND - [(AND POSITIONPAD (INSIDEP (WINDOWPROP POSITIONPAD - 'REGION) - LASTMOUSEX LASTMOUSEY)) - (COND - ((AND XGRID (INSIDEP WINDOW XGRID YGRID)) + (RESETLST + (RESETSAVE (CURSOR (OR CURSOR CROSSHAIRS))) + (RESETSAVE NIL (LIST 'DSPOPERATION (DSPOPERATION 'INVERT WINDOW) + WINDOW)) + [PROG ((USEGRID (WINDOWPROP WINDOW 'USEGRID)) + (GRID (SK.GRIDFACTOR WINDOW)) + (SCALE (VIEWER.SCALE WINDOW)) + (HOTSPOTCACHE (SK.HOTSPOT.CACHE WINDOW)) + (SCRATCHPT (AND CONSTRAINTFN (create POSITION))) + XSCREEN YSCREEN XGRID YGRID NEWX NEWY MOUSEDOWN LASTBUTTONSTATE ONGRID? NEARPOS + CONSTRAINTPT POSITIONPAD) + (OR FEEDBACKFN (SETQ FEEDBACKFN 'SHOWSKETCHXY)) + [COND + (NUMBERPADTOOFLG + + (* IT WOULD BE NICER TO PUT THE POSITION READER OVERTOP OF THE MENU BUT THIS + ROUTINE IS CALLED SEVERAL TIMES BY SEVERAL OF THE POINT READERS AND IT FLIPS UP + AND DOWN SO STILL NEEDS MORE WORK TO GET RIGHT + (* detach the window menu so that it doesn't come to top over the position + reader.) (AND (OPENWP (SETQ MENUW (SK.INSURE.HAS.MENU WINDOW))) + (RESETSAVE (DETACHWINDOW MENUW) (LIST (QUOTE SK.FIX.MENU) WINDOW)))) + + (RESETSAVE NIL (LIST 'CLOSEW (SETQ POSITIONPAD (SK.POSITION.PAD.FROM.VIEWER + WINDOW] + (RETURN (PROG1 (until [PROGN (GETMOUSESTATE) + (COND + [(AND POSITIONPAD (INSIDEP (WINDOWPROP POSITIONPAD + 'REGION) + LASTMOUSEX LASTMOUSEY)) + (COND + ((AND XGRID (INSIDEP WINDOW XGRID YGRID)) (* leaving the window, turn off the  last feedback.) - (APPLY* FEEDBACKFN XGRID YGRID WINDOW - FEEDBACKFNDATA) - (SETQ XGRID))) - - (* invoke position reader If it returns a position, return it.) + (APPLY* FEEDBACKFN XGRID YGRID WINDOW + FEEDBACKFNDATA) + (SETQ XGRID))) + (* invoke position reader If it + returns a position, return it.) + (AND (SETQ YSCREEN (SK.READ.POSITION.PAD.HANDLER + POSITIONPAD WINDOW FEEDBACKFN + FEEDBACKFNDATA CONSTRAINTFN)) + (COND + [(EQ YSCREEN 'ABORT) + (COND + ((EQ NUMBERPADTOOFLG 'MULTIPLE) - (AND (SETQ YSCREEN (SK.READ.POSITION.PAD.HANDLER - POSITIONPAD WINDOW FEEDBACKFN - FEEDBACKFNDATA CONSTRAINTFN)) - (COND - [(EQ YSCREEN 'ABORT) - (COND - ((EQ NUMBERPADTOOFLG 'MULTIPLE) - - (* if NUMBERPADTOOFLG is MULTIPLE, this is a context in which multiple values - are being read and the only way to abort is to error. - Note%: this leaves stuff on the screen.) + (* if NUMBERPADTOOFLG is MULTIPLE, this is a context in which multiple values are + being read and the only way to abort is to error. + Note%: this leaves stuff on the screen.) - (ERROR!)) - (T (RETURN NIL] - ((EQ YSCREEN 'STOP) - (RETURN NIL)) - (T (RETURN YSCREEN] - (MOUSEDOWN (LASTMOUSESTATE UP)) - ((LASTMOUSESTATE (OR LEFT MIDDLE RIGHT)) - (COND - ((INSIDEP (WINDOWPROP WINDOW 'REGION) - LASTMOUSEX LASTMOUSEY) - (SETQ MOUSEDOWN T) - NIL) - (T (RETURN] - do (SETQ NEWX (LASTMOUSEX WINDOW)) - (SETQ NEWY (LASTMOUSEY WINDOW)) - [COND - ((OR (NEQ NEWX XSCREEN) - (NEQ NEWY YSCREEN) - (NEQ LASTBUTTONSTATE LASTMOUSEBUTTONS)) - - (* cursor changed position or a button went down, check if grid pt moved.) - - (SKETCHW.UPDATE.LOCATORS WINDOW) - (SETQ XSCREEN NEWX) - (SETQ YSCREEN NEWY) - (SETQ LASTBUTTONSTATE LASTMOUSEBUTTONS) - [COND - ((AND HOTSPOTCACHE (SELECTQ BUTTONFOREXISTINGPTS - (MIDDLE (LASTMOUSESTATE MIDDLE)) - (LEFT (LASTMOUSESTATE LEFT)) - NIL) - (SETQ NEARPOS (NEAREST.HOT.SPOT HOTSPOTCACHE NEWX - NEWY))) + (ERROR!)) + (T (RETURN NIL] + ((EQ YSCREEN 'STOP) + (RETURN NIL)) + (T (RETURN YSCREEN] + (MOUSEDOWN (LASTMOUSESTATE UP)) + ((LASTMOUSESTATE (OR LEFT MIDDLE RIGHT)) + (COND + ((INSIDEP (WINDOWPROP WINDOW 'REGION) + LASTMOUSEX LASTMOUSEY) + (SETQ MOUSEDOWN T) + NIL) + (T (RETURN] + do (SETQ NEWX (LASTMOUSEX WINDOW)) + (SETQ NEWY (LASTMOUSEY WINDOW)) + [COND + ((OR (NEQ NEWX XSCREEN) + (NEQ NEWY YSCREEN) + (NEQ LASTBUTTONSTATE LASTMOUSEBUTTONS)) + (* cursor changed position or a button + went down, check if grid pt moved.) + (SKETCHW.UPDATE.LOCATORS WINDOW) + (SETQ XSCREEN NEWX) + (SETQ YSCREEN NEWY) + (SETQ LASTBUTTONSTATE LASTMOUSEBUTTONS) + [COND + ((AND HOTSPOTCACHE (SELECTQ BUTTONFOREXISTINGPTS + (MIDDLE (LASTMOUSESTATE MIDDLE)) + (LEFT (LASTMOUSESTATE LEFT)) + NIL) + (SETQ NEARPOS (NEAREST.HOT.SPOT HOTSPOTCACHE NEWX + NEWY))) (* on middle, pick the closest point) - (SETQ NEWX (fetch (POSITION XCOORD) of NEARPOS)) - (SETQ NEWY (fetch (POSITION YCOORD) of NEARPOS)) - (SETQ ONGRID? NIL)) - ((SETQ ONGRID? (COND - ((LASTMOUSESTATE RIGHT) + (SETQ NEWX (fetch (POSITION XCOORD) of NEARPOS)) + (SETQ NEWY (fetch (POSITION YCOORD) of NEARPOS)) + (SETQ ONGRID? NIL)) + ((SETQ ONGRID? (COND + ((LASTMOUSESTATE RIGHT) (* if right is down, flip sense of  using grid) - (NOT USEGRID)) - (T + (NOT USEGRID)) + (T (* otherwise use the grid if told to.) - USEGRID))) - (SETQ NEWX (MAP.WINDOW.ONTO.GRID NEWX SCALE GRID)) - (SETQ NEWY (MAP.WINDOW.ONTO.GRID NEWY SCALE GRID] - (PROGN [COND - ([AND CONSTRAINTFN - (POSITIONP (SETQ CONSTRAINTPT - (APPLY* CONSTRAINTFN - ( - MAP.VIEWER.XY.INTO.GLOBAL - NEWX NEWY VIEWER - ONGRID? SCRATCHPT) - W FEEDBACKFNDATA] - (SETQ NEWX (FIXR (QUOTIENT (fetch (POSITION - XCOORD) - of CONSTRAINTPT) - SCALE))) - (SETQ NEWY (FIXR (QUOTIENT (fetch (POSITION - YCOORD) - of CONSTRAINTPT) - SCALE] - (COND - ((OR (NEQ XGRID NEWX) - (NEQ YGRID NEWY)) - - (* grid point has changed too. Call the feedback function if the point is in - the window. If it is outside, don't show anything.) + USEGRID))) + (SETQ NEWX (MAP.WINDOW.ONTO.GRID NEWX SCALE GRID)) + (SETQ NEWY (MAP.WINDOW.ONTO.GRID NEWY SCALE GRID] + (PROGN [COND + ([AND CONSTRAINTFN + (POSITIONP (SETQ CONSTRAINTPT + (APPLY* CONSTRAINTFN + (MAP.VIEWER.XY.INTO.GLOBAL + NEWX NEWY VIEWER ONGRID? + SCRATCHPT) + W FEEDBACKFNDATA] + (SETQ NEWX (FIXR (QUOTIENT (fetch (POSITION XCOORD) + of CONSTRAINTPT) + SCALE))) + (SETQ NEWY (FIXR (QUOTIENT (fetch (POSITION YCOORD) + of CONSTRAINTPT) + SCALE] + (COND + ((OR (NEQ XGRID NEWX) + (NEQ YGRID NEWY)) - (AND XGRID (INSIDEP WINDOW XGRID YGRID) - (APPLY* FEEDBACKFN XGRID YGRID WINDOW - FEEDBACKFNDATA)) - (AND (INSIDEP WINDOW (SETQ XGRID NEWX) - (SETQ YGRID NEWY)) - (APPLY* FEEDBACKFN XGRID YGRID WINDOW - FEEDBACKFNDATA] - finally (RETURN (COND - ((AND XGRID (INSIDEP WINDOW XGRID YGRID)) - - (* if the cursor was outside the window when let up, return NIL) + (* grid point has changed too. Call the feedback function if the point is in the + window. If it is outside, don't show anything.) + (AND XGRID (INSIDEP WINDOW XGRID YGRID) (APPLY* FEEDBACKFN XGRID YGRID WINDOW - FEEDBACKFNDATA) - (create INPUTPT - INPUT.ONGRID? _ ONGRID? - INPUT.POSITION _ - (create POSITION - XCOORD _ XGRID - YCOORD _ YGRID]) + FEEDBACKFNDATA)) + (AND (INSIDEP WINDOW (SETQ XGRID NEWX) + (SETQ YGRID NEWY)) + (APPLY* FEEDBACKFN XGRID YGRID WINDOW + FEEDBACKFNDATA] + finally (RETURN (COND + ((AND XGRID (INSIDEP WINDOW XGRID YGRID)) + (* if the cursor was outside the + window when let up, return NIL) + (APPLY* FEEDBACKFN XGRID YGRID WINDOW + FEEDBACKFNDATA) + (create INPUTPT + INPUT.ONGRID? ↠ONGRID? + INPUT.POSITION ↠+ (create POSITION + XCOORD ↠XGRID + YCOORD ↠YGRID])]) (SKETCH.GET.POSITION - [LAMBDA (VIEWER CURSOR FEEDBACKFN FEEDBACKFNDATA CONSTRAINTFN) + [LAMBDA (VIEWER CURSOR FEEDBACKFN FEEDBACKFNDATA CONSTRAINTFN) (* rrb "21-May-86 16:51") (* user available version of  SK.READ.POINT.WITH.FEEDBACK.) - - (* reads a point from the user. Each time the cursor moves, a feedback fn is - called passing it the new X, new Y, VIEWER and FEEDBACKDATA It is expected to - XOR something on the screen that tells the user something. - CONSTRAINTFN is called to constrain the read point.) + + (* reads a point from the user. Each time the cursor moves, a feedback fn is + called passing it the new X, new Y, VIEWER and FEEDBACKDATA It is expected to XOR + something on the screen that tells the user something. + CONSTRAINTFN is called to constrain the read point.) (PROG (READPT) (SETQ READPT (SK.READ.POINT.WITH.FEEDBACK VIEWER CURSOR FEEDBACKFN FEEDBACKFNDATA @@ -7574,10 +7497,10 @@ Enter 'Abort' to leave the dashing unchanged.") (create POSITION]) (\CLOBBER.POSITION - [LAMBDA (X Y OLDPT) (* rrb " 4-Apr-86 13:34") - - (* returns a position with values x and y. - Clobbers OLDPT if it is a POSITION.) + [LAMBDA (X Y OLDPT) (* rrb " 4-Apr-86 13:34") + + (* returns a position with values x and y. + Clobbers OLDPT if it is a POSITION.) (COND ((POSITIONP OLDPT) @@ -7587,7 +7510,7 @@ Enter 'Abort' to leave the dashing unchanged.") (T (CREATEPOSITION X Y]) (NEAREST.HOT.SPOT - [LAMBDA (CACHE X Y) (* rrb "31-Jul-85 10:14") + [LAMBDA (CACHE X Y) (* rrb "31-Jul-85 10:14") (* returns the nearest hot spot to X Y) (PROG ((BESTMEASURE 10000) BESTX BESTY YDIF THISDIF) @@ -7606,13 +7529,12 @@ Enter 'Abort' to leave the dashing unchanged.") (SETQ BESTX (CAR XBUCKET)) (SETQ BESTY (CAR YBUCKET] (RETURN (AND BESTX (create POSITION - XCOORD _ BESTX - YCOORD _ BESTY]) + XCOORD ↠BESTX + YCOORD ↠BESTY]) (GETWREGION - [LAMBDA (W NEWREGIONFN NEWREGIONFNDATA MINWIDTH MINHEIGHT) - (* ; "Edited 12-Jun-90 13:25 by mitani") - (* gets a region from a window) + [LAMBDA (W NEWREGIONFN NEWREGIONFNDATA MINWIDTH MINHEIGHT)(* ; "Edited 12-Jun-90 13:25 by mitani") + (* gets a region from a window) (PROG ((REG (GETREGION MINWIDTH MINHEIGHT NIL NEWREGIONFN NEWREGIONFNDATA))) (RETURN (CREATEREGION (IDIFFERENCE (fetch (REGION LEFT) of REG) (DSPXOFFSET NIL W)) @@ -7622,11 +7544,10 @@ Enter 'Abort' to leave the dashing unchanged.") (fetch (REGION HEIGHT) of REG]) (GET.BITMAP.POSITION - [LAMBDA (WINDOW BITMAP OPERATION MSG XOFFSET YOFFSET) (* rrb "11-Jul-85 11:00") - - (* gets a position by tracking with a bitmap The spec returns is actually - (ONGRID? position) so that caller can tell whether it was placed on grid or - not.) + [LAMBDA (WINDOW BITMAP OPERATION MSG XOFFSET YOFFSET) (* rrb "11-Jul-85 11:00") + + (* gets a position by tracking with a bitmap The spec returns is actually + (ONGRID? position) so that caller can tell whether it was placed on grid or not.) (PROG (BUFFER.BITMAP WIDTH HEIGHT) (SETQ WIDTH (BITMAPWIDTH BITMAP)) @@ -7639,16 +7560,15 @@ Enter 'Abort' to leave the dashing unchanged.") XOFFSET YOFFSET]) (SK.TRACK.BITMAP1 - [LAMBDA (W BITMAP BUFFER.BITMAP WIDTH HEIGHT OPERATION XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA - FEEDBACKFN) (* rrb "11-Jul-86 15:52") - - (* tracks BITMAP until a button goes down and comes up. - It calls CONSTRAINTFN to determine the position at which to display the image. - Returns a list of (ongrid? position) so that caller can know whether the point - chosen was on a grid or not.) - - (* there is other code in BIGFONT that might be better for this.) + [LAMBDA (W BITMAP BUFFER.BITMAP WIDTH HEIGHT OPERATION XOFFSET YOFFSET CONSTRAINTFN CONSTRAINTDATA + FEEDBACKFN) (* rrb "11-Jul-86 15:52") + (* tracks BITMAP until a button goes down and comes up. + It calls CONSTRAINTFN to determine the position at which to display the image. + Returns a list of (ongrid? position) so that caller can know whether the point + chosen was on a grid or not.) + (* there is other code in BIGFONT that + might be better for this.) (PROG [DOWN LEFT BOTTOM NEW.LEFT NEW.BOTTOM GRID.LEFT GRID.BOTTOM ONGRID? NEARPOS CONSTRAINTPT (DSP (WINDOWPROP W 'DSP)) (USEGRID (WINDOWPROP W 'USEGRID)) @@ -7735,19 +7655,18 @@ Enter 'Abort' to leave the dashing unchanged.") (BITBLT BUFFER.BITMAP 0 0 W (IPLUS GRID.LEFT XOFFSET) (IPLUS GRID.BOTTOM YOFFSET) WIDTH HEIGHT 'INPUT 'REPLACE] - - (* return the position if any part of the bitmap is visible.) - + (* return the position if any part of + the bitmap is visible.) (RETURN (AND (REGIONSINTERSECTP (DSPCLIPPINGREGION NIL DSP) (CREATEREGION (IPLUS LEFT XOFFSET) (IPLUS BOTTOM YOFFSET) WIDTH HEIGHT)) (create INPUTPT - INPUT.ONGRID? _ ONGRID? - INPUT.POSITION _ + INPUT.ONGRID? ↠ONGRID? + INPUT.POSITION ↠(create POSITION - XCOORD _ GRID.LEFT - YCOORD _ GRID.BOTTOM]) + XCOORD ↠GRID.LEFT + YCOORD ↠GRID.BOTTOM]) ) (DECLARE%: EVAL@COMPILE @@ -7773,10 +7692,10 @@ Enter 'Abort' to leave the dashing unchanged.") (DEFINEQ (SK.BRING.UP.POSITION.PAD - [LAMBDA (VIEWER MSG OPENFLG) (* rrb "10-Jun-86 15:26") - - (* * brings up a position reading number pad associated with VIEWER. - Puts it over the menu if it is up.) + [LAMBDA (VIEWER MSG OPENFLG) (* rrb "10-Jun-86 15:26") + + (* * brings up a position reading number pad associated with VIEWER. + Puts it over the menu if it is up.) (RESETFORM (RADIX 10) (PROG ((NUMBER/READER/MAXDIGITS 8) @@ -7793,16 +7712,16 @@ Enter 'Abort' to leave the dashing unchanged.") (SETQ XNUMBERPAD (\POSITION.READER.NUMBERPAD DIGITFONT TOTALSWIDTH)) (SETQ YNUMBERPAD (\POSITION.READER.NUMBERPAD DIGITFONT TOTALSWIDTH)) (SETQ COMMANDPAD (create MENU - ITEMS _ '(abort enter quit) - CENTERFLG _ T - MENUFONT _ DIGITFONT - WHENHELDFN _ (FUNCTION POSITIONPAD.HELDFN) - WHENSELECTEDFN _ (FUNCTION POSITION.PAD.READER.HANDLER) - MENUBORDERSIZE _ 1 - MENUOUTLINESIZE _ 2 - ITEMHEIGHT _ (PLUS 6 TOTALSHEIGHT))) - - (* leave room for three lines and the number at the top) + ITEMS ↠'(abort enter quit) + CENTERFLG ↠T + MENUFONT ↠DIGITFONT + WHENHELDFN ↠(FUNCTION POSITIONPAD.HELDFN) + WHENSELECTEDFN ↠(FUNCTION POSITION.PAD.READER.HANDLER) + MENUBORDERSIZE ↠1 + MENUOUTLINESIZE ↠2 + ITEMHEIGHT ↠(PLUS 6 TOTALSHEIGHT))) + (* leave room for three lines and the + number at the top) (* use the numberpad's width so things  look better.) (SETQ TOTALSWIDTH (fetch (MENU IMAGEWIDTH) of XNUMBERPAD)) @@ -7812,9 +7731,9 @@ Enter 'Abort' to leave the dashing unchanged.") MARGIN)) (SETQ WINHEIGHT (IPLUS (COND [MSG - - (* if there is a msg, leave room for it at the top. - In any case, leave room for the labels X and Y.) + + (* if there is a msg, leave room for it at the top. + In any case, leave room for the labels X and Y.) (ITIMES (LENGTH (SETQ MSGLINES (BREAK.MSG.INTO.LINES MSG MSGFONT WINWIDTH) @@ -7834,10 +7753,8 @@ Enter 'Abort' to leave the dashing unchanged.") (MOVEW WIN (SK.PAD.READER.POSITION VIEWER WIN)) (WINDOWADDPROP WIN 'REPAINTFN (FUNCTION SK.POSITION.READER.REPAINTFN)) [COND - (MSG - - (* save msg on the window so repaintfn can get at it) - + (MSG (* save msg on the window so repaintfn + can get at it) (WINDOWPROP WIN 'MESSAGE MSGLINES) (WINDOWPROP WIN 'MESSAGEFONT MSGFONT) (* note where the message begins.) @@ -7845,9 +7762,9 @@ Enter 'Abort' to leave the dashing unchanged.") (WINDOWPROP WIN 'MESSAGEBOTTOM (DSPYPOSITION NIL WIN] (WINDOWPROP WIN 'DIGITFONT DIGITFONT) (OPENW WIN) - - (* window is opened because of bug in ADDMENU that it doesn't work unless - window is open.) + + (* window is opened because of bug in ADDMENU that it doesn't work unless window + is open.) (\POSITION.PAD.ADD.DIGIT.MENU WIN MARGIN MARGIN 'X XNUMBERPAD TOTALSWIDTH TOTALSHEIGHT NUMBER/READER/MAXDIGITS) @@ -7856,9 +7773,9 @@ Enter 'Abort' to leave the dashing unchanged.") 'Y YNUMBERPAD TOTALSWIDTH TOTALSHEIGHT NUMBER/READER/MAXDIGITS) (REDISPLAYW WIN NIL T) [ADDMENU COMMANDPAD WIN (create POSITION - XCOORD _ (PLUS MARGIN (TIMES 2 (PLUS MARGIN + XCOORD ↠(PLUS MARGIN (TIMES 2 (PLUS MARGIN TOTALSWIDTH))) - YCOORD _ (PLUS MARGIN + YCOORD ↠(PLUS MARGIN (QUOTIENT (DIFFERENCE (fetch (MENU IMAGEHEIGHT) of XNUMBERPAD) @@ -7869,10 +7786,10 @@ Enter 'Abort' to leave the dashing unchanged.") (RETURN WIN]) (SK.PAD.READER.POSITION - [LAMBDA (VIEWER READERWINDOW) (* rrb "10-Jun-86 12:24") - - (* returns the lower left corner where a position reading pad should be placed - for the sketch viewer VIEWER.) + [LAMBDA (VIEWER READERWINDOW) (* rrb "10-Jun-86 12:24") + + (* returns the lower left corner where a position reading pad should be placed + for the sketch viewer VIEWER.) (PROG ((VIEWERREGION (WINDOWPROP VIEWER 'REGION)) (READERREGION (WINDOWPROP READERWINDOW 'REGION)) @@ -7884,30 +7801,28 @@ Enter 'Abort' to leave the dashing unchanged.") [(OR (GREATERP VLFT PWID) (GREATERP VLFT VBTM) (GREATERP PWID (fetch (REGION WIDTH) of VIEWERREGION))) - - (* the position reader will fit to the left, or there is more room on the left, - or the position pad reader is wider than the viewer.) + + (* the position reader will fit to the left, or there is more room on the left, + or the position pad reader is wider than the viewer.) (create POSITION - XCOORD _ (DIFFERENCE (MAX 10 VLFT) + XCOORD ↠(DIFFERENCE (MAX 10 VLFT) PWID) - YCOORD _ (DIFFERENCE (fetch (REGION PTOP) of VIEWERREGION) + YCOORD ↠(DIFFERENCE (fetch (REGION PTOP) of VIEWERREGION) (fetch (REGION HEIGHT) of READERREGION] (T (* more room on the bottom) (create POSITION - XCOORD _ (MAX 10 VLFT) - YCOORD _ (DIFFERENCE VBTM (fetch (REGION HEIGHT) of READERREGION]) + XCOORD ↠(MAX 10 VLFT) + YCOORD ↠(DIFFERENCE VBTM (fetch (REGION HEIGHT) of READERREGION]) (SK.POSITION.READER.REPAINTFN - [LAMBDA (POSITIONPAD) (* rrb "11-Jun-86 13:28") + [LAMBDA (POSITIONPAD) (* rrb "11-Jun-86 13:28") (* repaints a position pad reader) (PROG ((MSGLINES (WINDOWPROP POSITIONPAD 'MESSAGE)) NUMBERMENU TOTALREGION) [COND - (MSGLINES - - (* if there is a msg, print it at the top.) - + (MSGLINES (* if there is a msg, print it at the + top.) (DSPFONT (WINDOWPROP POSITIONPAD 'MESSAGEFONT) POSITIONPAD) (MOVETO 0 (WINDOWPROP POSITIONPAD 'MESSAGEBOTTOM) @@ -7915,11 +7830,9 @@ Enter 'Abort' to leave the dashing unchanged.") (for LINE in MSGLINES do (PRIN3 LINE POSITIONPAD) (TERPRI POSITIONPAD] (DSPFONT (WINDOWPROP POSITIONPAD 'DIGITFONT) - POSITIONPAD) - - (* the actual displaying of the menus is done by the repaintfn supplied by - ADDMENU) - + POSITIONPAD) (* the actual displaying of the menus + is done by the repaintfn supplied by + ADDMENU) (for LABEL in '(X Y) do (SETQ NUMBERMENU (WINDOWPROP POSITIONPAD LABEL)) (SETQ TOTALREGION (GETMENUPROP NUMBERMENU 'TOTALREG)) (\READNUMBER.OUTLINEREGION TOTALREGION POSITIONPAD 2) @@ -7931,18 +7844,15 @@ Enter 'Abort' to leave the dashing unchanged.") (DISPLAY.POSITION.READER.TOTAL NUMBERMENU]) (SK.POSITION.PAD.FROM.VIEWER - [LAMBDA (VIEWER) (* rrb "11-Jun-86 14:17") - - (* cache the position pad because it takes a while to create. - Opens it too.) - + [LAMBDA (VIEWER) (* rrb "11-Jun-86 14:17") + (* cache the position pad because it + takes a while to create. + Opens it too.) (PROG (PAD) (COND ((SETQ PAD (WINDOWPROP VIEWER 'POSITION.PAD)) - (WINDOWPROP PAD 'FINISHEDFLG NIL) - - (* move the pad in case the window has moved or been reshaped.) - + (WINDOWPROP PAD 'FINISHEDFLG NIL) (* move the pad in case the window has + moved or been reshaped.) (MOVEW PAD (SK.PAD.READER.POSITION VIEWER PAD)) (OPENW PAD) (* initialize some values) (SK.INIT.POSITION.NUMBER.PAD.MENU (WINDOWPROP PAD 'X)) @@ -7952,24 +7862,24 @@ Enter 'Abort' to leave the dashing unchanged.")  require font search) (RESETFORM (CURSOR WAITINGCURSOR) (SETQ PAD (SK.BRING.UP.POSITION.PAD VIEWER - "Select the location of the desired position in the window or enter its X and Y coordinates here." + "Select the location of the desired position in the window or enter its X and Y coordinates here." T))) (WINDOWPROP VIEWER 'POSITION.PAD PAD) (RETURN PAD]) (SK.INIT.POSITION.NUMBER.PAD.MENU - [LAMBDA (MNU) (* rrb "21-May-86 15:29") + [LAMBDA (MNU) (* rrb "21-May-86 15:29") (* reinitializes a numberpad reader) (PUTMENUPROP MNU 'TOTAL 0) (PUTMENUPROP MNU 'DECIMALPOWER NIL) (DISPLAY.POSITION.READER.TOTAL MNU]) (SK.READ.POSITION.PAD.HANDLER - [LAMBDA (POSITIONPAD VIEWER FEEDBACKFN FEEDBACKFNDATA CONSTRAINTFN) + [LAMBDA (POSITIONPAD VIEWER FEEDBACKFN FEEDBACKFNDATA CONSTRAINTFN) (* rrb "11-Jul-86 15:54") - - (* tracks the cursor while it is in the position pad and sets variables for - SK.READ.POINT.WITH.FEEDBACK and returned T if it succeeded) + + (* tracks the cursor while it is in the position pad and sets variables for + SK.READ.POINT.WITH.FEEDBACK and returned T if it succeeded) (* uses many variable freely from  SK.READ.POINT.WITH.FEEDBACK) (PROG (NEWX NEWY CONSTRX CONSTRY PREVX PREVY FINISHVAL (SCALE (VIEWER.SCALE VIEWER))) @@ -7992,9 +7902,9 @@ Enter 'Abort' to leave the dashing unchanged.") (NEQ NEWY PREVY)) (* user entered a new number) (SETQ PREVX NEWX) (SETQ PREVY NEWY) - - (* this code is differerent from the code in SK.READ.POINT.WITH.FEEDBACK in - that is works in sketch coordinates.) + + (* this code is differerent from the code in SK.READ.POINT.WITH.FEEDBACK in that + is works in sketch coordinates.) [COND ([AND CONSTRAINTFN (POSITIONP (SETQ CONSTRAINTPT @@ -8007,10 +7917,10 @@ Enter 'Abort' to leave the dashing unchanged.") (COND ((OR (NEQ CONSTRX NEWX) (NEQ CONSTRY NEWY)) - - (* grid point has changed too. Update the position numberpads and Call the - feedback function if the point is in the window. - If it is outside, don't show anything.) + + (* grid point has changed too. Update the position numberpads and Call the + feedback function if the point is in the window. + If it is outside, don't show anything.) (PUTMENUPROP (WINDOWPROP POSITIONPAD 'X) 'TOTAL NEWX) @@ -8025,39 +7935,36 @@ Enter 'Abort' to leave the dashing unchanged.") (QUOTIENT (SETQ CONSTRY NEWY) SCALE) VIEWER FEEDBACKFNDATA] - finally - - (* remove the closefn so that it doesn't get run on the way out.) - + finally (* remove the closefn so that it + doesn't get run on the way out.) (WINDOWDELPROP POSITIONPAD 'CLOSEFN (FUNCTION \NUMBERPAD.READER.CLOSEFN)) (AND CONSTRX (APPLY* FEEDBACKFN CONSTRX CONSTRY VIEWER FEEDBACKFNDATA)) (RETURN (COND ((MEMB FINISHVAL '(STOP ABORT)) - - (* means the numberpad reader was closed. - If the number pad includes the ABORT command, do what it would do, otherwise - the program is not expecting NIL so cause an error.) + + (* means the numberpad reader was closed. + If the number pad includes the ABORT command, do what it would do, otherwise the + program is not expecting NIL so cause an error.) (RETURN FINISHVAL)) (FINISHVAL (AND CONSTRX (SETQ FINISHVAL (create POSITION - XCOORD _ CONSTRX - YCOORD _ CONSTRY)) + XCOORD ↠CONSTRX + YCOORD ↠CONSTRY)) (create INPUTPT - INPUT.ONGRID? _ 'GLOBAL - INPUT.POSITION _ ( + INPUT.ONGRID? ↠'GLOBAL + INPUT.POSITION ↠( SK.SCALE.POSITION.INTO.VIEWER FINISHVAL SCALE) - INPUT.GLOBALPOSITION _ FINISHVAL))) + INPUT.GLOBALPOSITION ↠FINISHVAL))) (T (* mouse left the window, return) NIL]) (DISPLAY.POSITION.READER.TOTAL - [LAMBDA (MNU) (* rrb "19-May-86 17:09") - - (* displays the number total in the box in the window.) - + [LAMBDA (MNU) (* rrb "19-May-86 17:09") + (* displays the number total in the + box in the window.) (PROG ((TOTALREG (GETMENUPROP MNU 'TOTALREG)) (DECIMALPLACES (GETMENUPROP MNU 'DECIMALPOWER)) (WIN (WFROMMENU MNU))) @@ -8067,9 +7974,9 @@ Enter 'Abort' to leave the dashing unchanged.") (CENTERPRINTINREGION [COND [DECIMALPLACES - - (* printing a decimal number must check to make sure the correct number of - decimal places print.) + + (* printing a decimal number must check to make sure the correct number of + decimal places print.) (PROG ([TOTSTR (MKSTRING (GETMENUPROP MNU 'TOTAL] DECPOS NAFTERDEC NCHARS) @@ -8095,15 +8002,14 @@ Enter 'Abort' to leave the dashing unchanged.") TOTALREG WIN]) (POSITION.PAD.READER.HANDLER - [LAMBDA (DIGIT MNU) (* rrb "10-Jun-86 15:50") - - (* handles a key stroke or menu digit selection for a number pad reader.) - + [LAMBDA (DIGIT MNU) (* rrb "10-Jun-86 15:50") + (* handles a key stroke or menu digit + selection for a number pad reader.) (PROG (TOTAL POWER OPERATION TOPOFSTACK (WIN (WFROMMENU MNU))) (SETQ TOTAL (GETMENUPROP MNU 'TOTAL)) [PUTMENUPROP MNU 'TOTAL (SELECTQ DIGIT - ((¬ bs) + ((_ bs) (COND ((NULL (GETMENUPROP MNU 'DIGITYET)) (* bs was the first key) @@ -8119,43 +8025,41 @@ Enter 'Abort' to leave the dashing unchanged.") (T (PUTMENUPROP MNU 'DECIMALPOWER (SETQ POWER (SUB1 POWER))) (* dirty but effective.) (PROG ((TOTSTR (MKSTRING TOTAL))) - - (* SUBSTRING will be NIL if the total has a trailing zero.) - + (* SUBSTRING will be NIL if the total + has a trailing zero.) (RETURN (MKATOM (OR (SUBSTRING TOTSTR 1 (PLUS (STRPOS "." TOTSTR) (SUB1 POWER))) TOTSTR] (T (* no decimal point) (IQUOTIENT TOTAL 10)))) - (± (* +/- sign) + (± (* +/- sign) (MINUS TOTAL)) - ((¸ ´ - + =) (* operation sign) + ((÷ × - + =) (* operation sign) [COND ((NULL (GETMENUPROP MNU 'DIGITYET)) - - (* last thing hit was an operation, just save this one.) - + (* last thing hit was an operation, + just save this one.) (PUTMENUPROP MNU 'OPERATION (COND ((EQ DIGIT '=) NIL) (T DIGIT))) (RETURN)) ((SETQ OPERATION (GETMENUPROP MNU 'OPERATION)) - - (* perform the operation that is stored between the top of stack and the - current total) + + (* perform the operation that is stored between the top of stack and the current + total) (COND [(SETQ TOPOFSTACK (GETMENUPROP MNU 'TOPOFSTACK)) (* a previous value exists) (SETQ TOTAL (SELECTQ OPERATION - (¸ (* divide, check for 0 divisor) + (÷ (* divide, check for 0 divisor) (COND ((ZEROP TOTAL) (PROMPTPRINT "Can't divide by zero")) (T (QUOTIENT TOPOFSTACK TOTAL)))) - (´ (* times) + (× (* times) (TIMES TOPOFSTACK TOTAL)) (- (* minus) (DIFFERENCE TOPOFSTACK TOTAL)) @@ -8203,9 +8107,8 @@ Enter 'Abort' to leave the dashing unchanged.") [(NUMBERP DIGIT) (COND ((NULL (GETMENUPROP MNU 'DIGITYET)) - - (* first key hit after an operation, note this and clear the total.) - + (* first key hit after an operation, + note this and clear the total.) (PUTMENUPROP MNU 'DIGITYET T) (SETQ TOTAL 0))) (COND @@ -8216,7 +8119,7 @@ Enter 'Abort' to leave the dashing unchanged.") [(SETQ POWER (GETMENUPROP MNU 'DECIMALPOWER)) (* have read decimal pt) (PUTMENUPROP MNU 'DECIMALPOWER (ADD1 POWER)) - (SETQ POWER (bind (N _ 1.0) for I from 1 to POWER + (SETQ POWER (bind (N ↠1.0) for I from 1 to POWER do (SETQ N (FTIMES N 0.1)) finally (RETURN N))) (COND ((GEQ TOTAL 0) @@ -8232,7 +8135,7 @@ Enter 'Abort' to leave the dashing unchanged.") (DISPLAY.POSITION.READER.TOTAL MNU]) (POSITIONPAD.HELDFN - [LAMBDA (ITEM MENU BUTTON) (* rrb "10-Jun-86 15:29") + [LAMBDA (ITEM MENU BUTTON) (* rrb "10-Jun-86 15:29") (* prints the help information for a  numberpad.) (PROMPTPRINT (SELECTQ ITEM @@ -8243,61 +8146,59 @@ Enter 'Abort' to leave the dashing unchanged.") "performs the previously specified operation between the memory and the current total") (+ "Will read another number to be added to the current total") (- "Will read another number to be subtracted to the current total") - (´ "Will read another number to be multiplied by the current total") - (¸ "Will read another number and divides the current total by it") + (× "Will read another number to be multiplied by the current total") + (÷ "Will read another number and divides the current total by it") (quit "Will stop prompting you for points.") (abort "will abort this sketch operation.") - (± " will change the sign of the total") + (± " will change the sign of the total") (%. "will enter a decimal point.") - ((bs ¬) + ((bs _) "Will erase the last digit entered.") (% "doesn't do anything.") "Will put this digit on the right of the total."]) (\POSITION.PAD.ADD.DIGIT.MENU - [LAMBDA (WIN LEFT MARGIN LABEL MENU TOTALSWIDTH TOTALSHEIGHT NUMBER/READER/MAXDIGITS) + [LAMBDA (WIN LEFT MARGIN LABEL MENU TOTALSWIDTH TOTALSHEIGHT NUMBER/READER/MAXDIGITS) (* rrb "10-Jun-86 12:06") - - (* * adds a menu which is a number pad menu to WIN, allocates the total region - for it.) + + (* * adds a menu which is a number pad menu to WIN, allocates the total region + for it.) (PROG (TOTALREGION) (ADDMENU MENU WIN (create POSITION - XCOORD _ LEFT - YCOORD _ MARGIN)) + XCOORD ↠LEFT + YCOORD ↠MARGIN)) (PUTMENUPROP MENU 'TOTALREG (SETQ TOTALREGION (create REGION - LEFT _ LEFT - BOTTOM _ (PLUS (fetch (MENU + LEFT ↠LEFT + BOTTOM ↠(PLUS (fetch (MENU IMAGEHEIGHT ) of MENU) MARGIN MARGIN) - WIDTH _ TOTALSWIDTH - HEIGHT _ TOTALSHEIGHT))) + WIDTH ↠TOTALSWIDTH + HEIGHT ↠TOTALSHEIGHT))) (PUTMENUPROP MENU 'TOTAL 0) (PUTMENUPROP MENU 'MAXDIGITS NUMBER/READER/MAXDIGITS) - - (* put link to the menu so the window can eventually get the values.) - + (* put link to the menu so the window + can eventually get the values.) (WINDOWPROP WIN LABEL MENU) (RETURN WIN]) (\POSITION.READER.NUMBERPAD - [LAMBDA (DIGITFONT WIDTH) (* rrb "10-Jun-86 15:33") - - (* returns a menu which is a numberpad suitable for a position reader.) - + [LAMBDA (DIGITFONT WIDTH) (* rrb "10-Jun-86 15:33") + (* returns a menu which is a numberpad + suitable for a position reader.) (create MENU - ITEMS _ - '(¬ ce C ¸ 1 2 3 ´ 4 5 6 - 7 8 9 + ± 0 %. =) - MENUCOLUMNS _ 4 - CENTERFLG _ T - MENUFONT _ DIGITFONT - WHENHELDFN _ (FUNCTION POSITIONPAD.HELDFN) - WHENSELECTEDFN _ (FUNCTION POSITION.PAD.READER.HANDLER) - MENUOUTLINESIZE _ 2 - ITEMHEIGHT _ (IPLUS 2 (FONTPROP DIGITFONT 'HEIGHT)) - ITEMWIDTH _ (AND WIDTH (QUOTIENT (DIFFERENCE WIDTH 8) + ITEMS ↠+ '(_ ce C ÷ 1 2 3 × 4 5 6 - 7 8 9 + ± 0 %. =) + MENUCOLUMNS ↠4 + CENTERFLG ↠T + MENUFONT ↠DIGITFONT + WHENHELDFN ↠(FUNCTION POSITIONPAD.HELDFN) + WHENSELECTEDFN ↠(FUNCTION POSITION.PAD.READER.HANDLER) + MENUOUTLINESIZE ↠2 + ITEMHEIGHT ↠(IPLUS 2 (FONTPROP DIGITFONT 'HEIGHT)) + ITEMWIDTH ↠(AND WIDTH (QUOTIENT (DIFFERENCE WIDTH 8) 4]) ) @@ -8403,13 +8304,13 @@ Enter 'Abort' to leave the dashing unchanged.") (DEFINEQ (SK.DRAWFN - [LAMBDA (ELEMENTTYPE) (* rrb "17-MAR-83 22:28") + [LAMBDA (ELEMENTTYPE) (* rrb "17-MAR-83 22:28") (* goes from an element type name to  its DRAWFN) (fetch (SKETCHTYPE DRAWFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.TRANSFORMFN - [LAMBDA (ELEMENTTYPE) (* rrb " 7-Feb-85 12:08") + [LAMBDA (ELEMENTTYPE) (* rrb " 7-Feb-85 12:08") (* goes from an element type name to  its TRANSFORMFN) (fetch (SKETCHTYPE TRANSFORMFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) @@ -8420,37 +8321,35 @@ Enter 'Abort' to leave the dashing unchanged.") (fetch (SKETCHTYPE EXPANDFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) (SK.INPUT - [LAMBDA (ELEMENTTYPE SKETCHW) (* rrb "11-MAR-83 09:54") + [LAMBDA (ELEMENTTYPE SKETCHW) (* rrb "11-MAR-83 09:54") (* applies an element types input  function to a window.) (APPLY* (fetch (SKETCHTYPE INPUTFN) of ELEMENTTYPE) SKETCHW]) (SK.INSIDEFN - [LAMBDA (ELEMENTTYPE) (* rrb " 4-Oct-86 11:02") - - (* goes from an element type name to its inside predicate) - + [LAMBDA (ELEMENTTYPE) (* rrb " 4-Oct-86 11:02") + (* goes from an element type name to + its inside predicate) (PROG (SKTYPE) LP (COND ([NULL (SETQ SKTYPE (GETPROP ELEMENTTYPE 'SKETCHTYPE] - - (* unknown sketch type and this is the first place where such is encountered.) - + (* unknown sketch type and this is the + first place where such is encountered.) (ERROR ELEMENTTYPE "Unknown sketch type. If you can load the file containing it, do so and type 'RETURN'. -Otherwise, type '^'.") +Otherwise, type '↑'.") (GO LP))) (RETURN (fetch (SKETCHTYPE INSIDEFN) of SKTYPE]) (SK.UPDATEFN - [LAMBDA (ELEMENTTYPE) (* rrb "21-Dec-84 11:28") - - (* goes from an element type name to its updatefn The update function is called - when an element in a window has changed. - It will get args of the old local screen element, the new global element and - the window. If it can update the display more efficiently than erasing and - redrawing, it should and return the new local sketch element.) + [LAMBDA (ELEMENTTYPE) (* rrb "21-Dec-84 11:28") + + (* goes from an element type name to its updatefn The update function is called + when an element in a window has changed. It will get args of the old local screen + element, the new global element and the window. + If it can update the display more efficiently than erasing and redrawing, it + should and return the new local sketch element.) (fetch (SKETCHTYPE UPDATEFN) of (GETPROP ELEMENTTYPE 'SKETCHTYPE]) ) @@ -8639,11 +8538,11 @@ Otherwise, type '^'.") (DEFINEQ (SK.CHECK.SKETCH.VERSION - [LAMBDA (SKETCH) (* ; - "Edited 21-Oct-92 18:40 by sybalsky:mv:envos") + [LAMBDA (SKETCH) (* ; + "Edited 21-Oct-92 18:40 by sybalsky:mv:envos") (* ;; - "makes sure the sketch is the correct version. If not, it tries to update it. Returns SKETCH.") + "makes sure the sketch is the correct version. If not, it tries to update it. Returns SKETCH.") (COND ((EQ (LISTGET (fetch (SKETCH SKETCHPROPS) of SKETCH) @@ -8653,46 +8552,43 @@ Otherwise, type '^'.") (T (SK.INSURE.RECORD.LENGTH (fetch (SKETCH SKETCHELTS) of SKETCH)) (* ;; - "this is basically a PUTSKETCHPROP expanded in line to avoid coersions which can cause loops.") + "this is basically a PUTSKETCHPROP expanded in line to avoid coersions which can cause loops.") [PROG (PLIST) (SETQ PLIST (fetch (SKETCH SKETCHPROPS) of SKETCH)) (COND ((SETQ PLIST (fetch (SKETCH SKETCHPROPS) of SKETCH)) (LISTPUT PLIST 'VERSION SKETCH.VERSION)) - (T (replace (SKETCH SKETCHPROPS) of SKETCH with - (LIST 'VERSION - SKETCH.VERSION] + (T (replace (SKETCH SKETCHPROPS) of SKETCH with (LIST 'VERSION SKETCH.VERSION] SKETCH]) (SK.INSURE.RECORD.LENGTH - [LAMBDA (SKETCHELTS) (* ; - "Edited 21-Oct-92 18:35 by sybalsky:mv:envos") + [LAMBDA (SKETCHELTS) (* ; + "Edited 21-Oct-92 18:35 by sybalsky:mv:envos") (* ;; "makes sure the elements have the proper number of fields.") (bind INDPART TYPE NFIELDS for ELT in SKETCHELTS do (SETQ INDPART (fetch (GLOBALPART INDIVIDUALGLOBALPART) of ELT)) - (SETQ TYPE (fetch (INDIVIDUALGLOBALPART GTYPE) of INDPART)) - (COND - ([OR (SETQ NFIELDS (SK.RECORD.LENGTH TYPE)) - (AND (RECLOOK TYPE) - (SETQ SKETCH.RECORD.LENGTHS - (NCONC1 SKETCH.RECORD.LENGTHS (LIST TYPE - (SETQ NFIELDS - (LENGTH (EVAL (LIST 'CREATE TYPE] - (SK.INSURE.HAS.LENGTH INDPART NFIELDS TYPE))) + (SETQ TYPE (fetch (INDIVIDUALGLOBALPART GTYPE) of INDPART)) + (COND + ([OR (SETQ NFIELDS (SK.RECORD.LENGTH TYPE)) + (AND (RECLOOK TYPE) + (SETQ SKETCH.RECORD.LENGTHS (NCONC1 SKETCH.RECORD.LENGTHS + (LIST TYPE + (SETQ NFIELDS + (LENGTH (EVAL (LIST 'CREATE TYPE] + (SK.INSURE.HAS.LENGTH INDPART NFIELDS TYPE))) - (* ;; "if it's not a record, either it's an unknown sketch element type or its declaration wasn't copied to the compiled file. In either case, assume it has the correct number of fields.") + (* ;; "if it's not a record, either it's an unknown sketch element type or its declaration wasn't copied to the compiled file. In either case, assume it has the correct number of fields.") - (COND - ((EQ TYPE 'GROUP) (* ; - "recurse thru the subelements too.") - (SK.INSURE.RECORD.LENGTH (fetch (GROUP LISTOFGLOBALELTS) of INDPART]) + (COND + ((EQ TYPE 'GROUP) (* ; "recurse thru the subelements too.") + (SK.INSURE.RECORD.LENGTH (fetch (GROUP LISTOFGLOBALELTS) of INDPART]) (SK.INSURE.HAS.LENGTH - [LAMBDA (LIST N TYPE) (* ; - "Edited 21-Oct-92 18:36 by sybalsky:mv:envos") + [LAMBDA (LIST N TYPE) (* ; + "Edited 21-Oct-92 18:36 by sybalsky:mv:envos") (* ;; "makes sure LIST is at least N long. If not, it creates a record of type TYPE and nconcs the enough fields from the end to make it be N long.") @@ -8705,14 +8601,14 @@ Otherwise, type '^'.") (for I from (ADD1 (LENGTH LIST)) to N collect NIL]) (SK.RECORD.LENGTH - [LAMBDA (SKETCHRECORDTYPE) (* rrb "20-Mar-86 14:11") + [LAMBDA (SKETCHRECORDTYPE) (* rrb "20-Mar-86 14:11") (CADR (ASSOC SKETCHRECORDTYPE SKETCH.RECORD.LENGTHS]) (SK.SET.RECORD.LENGTHS - [LAMBDA NIL (* rrb "18-Oct-85 15:35") - - (* sets up a variable that contains the lengths of the sketch element records.) - + [LAMBDA NIL (* rrb "18-Oct-85 15:35") + (* sets up a variable that contains + the lengths of the sketch element + records.) (SETQ SKETCH.RECORD.LENGTHS (SK.SET.RECORD.LENGTHS.MACRO]) ) (DECLARE%: EVAL@COMPILE @@ -8736,19 +8632,17 @@ Otherwise, type '^'.") (DEFINEQ (SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER - [LAMBDA NIL (* ; "Edited 12-Feb-88 16:49 by rrb") - - (* adds sketch as an option to the file browser edit command.) - + [LAMBDA NIL (* ; "Edited 12-Feb-88 16:49 by rrb") + (* adds sketch as an option to the + file browser edit command.) (AND (BOUNDP 'FB.MENU.ITEMS) (PROG [(PTRX (for MITEM in FB.MENU.ITEMS when (STRING-EQUAL (CAR MITEM) - "Edit") - do (RETURN MITEM] + "Edit") do (RETURN MITEM] (SETQ PTRX (ASSOC 'SUBITEMS PTRX)) (for SUBI in PTRX when (STRING-EQUAL (CAR SUBI) - "Sketch") do (RETURN) - finally (NCONC1 PTRX (LIST '"Sketch" '(FB.EDITCOMMAND SKETCH) - "Calls the Sketch editor on selected files"]) + "Sketch") do (RETURN) + finally (NCONC1 PTRX (LIST '"Sketch" '(FB.EDITCOMMAND SKETCH) + "Calls the Sketch editor on selected files"]) ) (SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER) @@ -8761,151 +8655,151 @@ Otherwise, type '^'.") (ADDTOVAR LAMA SK.UNIONREGIONS SKETCH.CREATE) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (18222 20092 (SKETCH.FLUSH.EXISTING 18232 . 20090)) (20202 31352 (SKETCH.FROM.A.FILE -20212 . 20527) (SK.PUT.ON.FILE 20529 . 21981) (SKETCH.PUT 21983 . 24626) (SK.OUTPUT.FILE.NAME 24628 . -25113) (SK.INCLUDE.FILE 25115 . 27981) (SK.GET.IMAGEOBJ.FROM.FILE 27983 . 30146) (SK.GET.FROM.FILE -30148 . 31041) (SKETCH.GET 31043 . 31350)) (31353 83865 (SKETCH 31363 . 33468) (SKETCHW.CREATE 33470 - . 38044) (SKETCH.RESET 38046 . 39568) (SKETCHW.FIG.CHANGED 39570 . 39910) (SK.WINDOW.TITLE 39912 . -40299) (EDITSLIDE 40301 . 40707) (EDITSKETCH 40709 . 41033) (ADD.SKETCH.TO.VIEWER 41035 . 43621) ( -SK.ADD.ELEMENTS.TO.SKETCH 43623 . 44137) (SKETCH.SET.A.DEFAULT 44139 . 51690) (SK.POPUP.SELECTIONFN -51692 . 52234) (GETSKETCHWREGION 52236 . 52442) (SK.ADD.ELEMENT 52444 . 54023) ( -SK.ADD.PRIORITY.ELEMENT.TO.SKETCH 54025 . 55419) (SK.ELTS.BY.PRIORITY 55421 . 55717) ( -SK.ORDER.ELEMENTS 55719 . 55986) (SK.ADD.PRIORITY.LOCAL.ELEMENT.TO.SKETCH 55988 . 57482) ( -SK.ADD.ELEMENTS 57484 . 58008) (SK.CHECK.WHENADDEDFN 58010 . 58740) (SK.APPLY.MENU.COMMAND 58742 . -59540) (SK.DELETE.ELEMENT1 59542 . 61120) (SK.MARK.DIRTY 61122 . 61788) (SK.MARK.UNDIRTY 61790 . 62121 -) (SK.MENU.AND.RETURN.FIELD 62123 . 62788) (SKETCH.SET.BRUSH.SHAPE 62790 . 63375) ( -SKETCH.SET.BRUSH.SIZE 63377 . 63883) (SKETCHW.CLOSEFN 63885 . 65676) (SK.CONFIRM.DESTRUCTION 65678 . -66677) (SKETCHW.OUTFN 66679 . 66943) (SKETCHW.REOPENFN 66945 . 67357) (MAKE.LOCAL.SKETCH 67359 . 68089 -) (MAP.SKETCHSPEC.INTO.VIEWER 68091 . 69301) (SKETCHW.REPAINTFN 69303 . 70131) (SKETCHW.REPAINTFN1 -70133 . 71072) (SK.DRAWFIGURE.IF 71074 . 71596) (SKETCHW.SCROLLFN 71598 . 75791) (SKETCHW.RESHAPEFN -75793 . 78051) (SK.UPDATE.EVENT.SELECTION 78053 . 80108) (LIGHTGRAYWINDOW 80110 . 80273) ( -SK.ADD.SPACES 80275 . 81021) (SK.SKETCH.MENU 81023 . 81345) (SK.CHECK.IMAGEOBJ.WHENDELETEDFN 81347 . -82199) (SK.APPLY.IMAGEOBJ.WHENDELETEDFN 82201 . 83161) (SK.RETURN.TTY 83163 . 83531) (SK.TAKE.TTY -83533 . 83863)) (83919 107334 (SKETCH.COMMANDMENU 83929 . 84353) (SKETCH.COMMANDMENU.ITEMS 84355 . -104438) (CREATE.SKETCHW.COMMANDMENU 104440 . 104860) (SKETCHW.SELECTIONFN 104862 . 105965) ( -SKETCH.MONITORLOCK 105967 . 106438) (SK.EVAL.AS.PROCESS 106440 . 107053) (SK.EVAL.WITH.LOCK 107055 . -107332)) (107335 115139 (SK.FIX.MENU 107345 . 108439) (SK.SET.UP.MENUS 108441 . 110742) ( -SK.INSURE.HAS.MENU 110744 . 111406) (SK.CREATE.STANDARD.MENU 111408 . 111853) (SK.ADD.ITEM.TO.MENU -111855 . 112530) (SK.GET.VIEWER.POPUP.MENU 112532 . 114733) (SK.CLEAR.POPUP.MENU 114735 . 115137)) ( -115195 124017 (SKETCH.CREATE 115205 . 115991) (GETSKETCHPROP 115993 . 119050) (PUTSKETCHPROP 119052 . -122984) (CREATE.DEFAULT.SKETCH.CONTEXT 122986 . 124015)) (124183 147079 (SK.COPY.BUTTONEVENTFN 124193 - . 135421) (SK.BUTTONEVENT.MARK 135423 . 135806) (SK.BUILD.IMAGEOBJ 135808 . 145723) ( -SK.BUTTONEVENT.OVERP 145725 . 146348) (SK.BUTTONEVENT.SAME.KEYS 146350 . 147077)) (147358 173173 ( -SK.SEL.AND.CHANGE 147368 . 147660) (SK.CHECK.WHENCHANGEDFN 147662 . 148368) (SK.CHECK.PRECHANGEFN -148370 . 148971) (SK.CHANGE.ELT 148973 . 149165) (SK.CHANGE.THING 149167 . 150418) ( -SKETCH.CHANGE.ELEMENTS 150420 . 151603) (SK.APPLY.SINGLE.CHANGEFN 151605 . 152178) (SK.DO.CHANGESPECS -152180 . 153839) (SK.VIEWER.FROM.SKETCH.ARG 153841 . 154283) (SK.DO.CHANGESPEC1 154285 . 156160) ( -SK.CHANGEFN 156162 . 156742) (SK.READCHANGEFN 156744 . 157203) (SK.DEFAULT.CHANGEFN 157205 . 159677) ( -CHANGEABLEFIELDITEMS 159679 . 160326) (SK.APPLY.CHANGE.COMMAND 160328 . 160945) ( -SK.DO.AND.RECORD.CHANGES 160947 . 162344) (SK.APPLY.CHANGE.COMMAND1 162346 . 163834) ( -SK.ELEMENTS.CHANGEFN 163836 . 166160) (READ.POINT.TO.ADD 166162 . 167106) (GLOBAL.KNOT.FROM.LOCAL -167108 . 167568) (SK.ADD.KNOT.TO.ELEMENT 167570 . 168514) (SK.GROUP.CHANGEFN 168516 . 169728) ( -SK.GROUP.CHANGEFN1 169730 . 173171)) (173340 187073 (ADD.ELEMENT.TO.SKETCH 173350 . 175056) ( -ADD.SKETCH.VIEWER 175058 . 175726) (REMOVE.SKETCH.VIEWER 175728 . 176341) (ALL.SKETCH.VIEWERS 176343 - . 176583) (SKETCH.ALL.VIEWERS 176585 . 176845) (VIEWER.BUCKET 176847 . 176998) (ELT.INSIDE.REGION? -177000 . 177327) (ELT.INSIDE.SKWP 177329 . 177620) (SCALE.FROM.SKW 177622 . 177872) ( -SK.ADDELT.TO.WINDOW 177874 . 178734) (SK.CALC.REGION.VIEWED 178736 . 179114) (SK.DRAWFIGURE 179116 . -180405) (SK.DRAWFIGURE1 180407 . 180791) (SK.LOCAL.FROM.GLOBAL 180793 . 182028) (SKETCH.REGION.VIEWED -182030 . 184717) (SKETCH.VIEW.FROM.NAME 184719 . 185149) (SK.UPDATE.REGION.VIEWED 185151 . 185543) ( -SKETCH.ADD.AND.DISPLAY 185545 . 185953) (SKETCH.ADD.AND.DISPLAY1 185955 . 186393) (SK.ADD.ITEM 186395 - . 186727) (SKETCHW.ADD.INSTANCE 186729 . 187071)) (187114 200302 (SK.SEL.AND.DELETE 187124 . 187512) -(SK.ERASE.AND.DELETE.ITEM 187514 . 187933) (REMOVE.ELEMENT.FROM.SKETCH 187935 . 189046) ( -SK.DELETE.ELEMENT 189048 . 189606) (SK.DELETE.ELEMENT2 189608 . 190269) (SK.DELETE.KNOT 190271 . -190562) (SK.SEL.AND.DELETE.KNOT 190564 . 191689) (SK.DELETE.ELEMENT.KNOT 191691 . 194898) ( -SK.CHECK.WHENDELETEDFN 194900 . 195680) (SK.CHECK.PREEDITFN 195682 . 196166) ( -SK.CHECK.END.INITIAL.EDIT 196168 . 196702) (SK.CHECK.WHENPOINTDELETEDFN 196704 . 197500) (SK.ERASE.ELT - 197502 . 197838) (SK.DELETE.ELT 197840 . 198215) (SK.DELETE.ITEM 198217 . 198625) (DELFROMTCONC -198627 . 200300)) (200341 214175 (SK.COPY.ELT 200351 . 200721) (SK.SEL.AND.COPY 200723 . 201106) ( -SK.COPY.ELEMENTS 201108 . 206736) (SK.ADD.COPY.OF.ELEMENTS 206738 . 208505) ( -SK.GLOBAL.FROM.LOCAL.ELEMENTS 208507 . 208747) (SK.COPY.ITEM 208749 . 209546) (SK.INSERT.SKETCH 209548 - . 214173)) (214215 244236 (SK.MOVE.ELT 214225 . 214500) (SK.MOVE.ELT.OR.PT 214502 . 214815) ( -SK.APPLY.DEFAULT.MOVE 214817 . 215251) (SK.SEL.AND.MOVE 215253 . 215800) (SK.MOVE.ELEMENTS 215802 . -226674) (SKETCH.MOVE.ELEMENTS 226676 . 228607) (SKETCH.COPY.ELEMENTS 228609 . 230656) ( -\SKETCH.COPY.ELEMENT 230658 . 231383) (SK.TRANSLATE.ELEMENT 231385 . 231868) (SK.COPY.GLOBAL.ELEMENT -231870 . 232081) (SK.MAKE.ELEMENT.MOVE.ARG 232083 . 232703) (SK.MAKE.ELEMENTS.MOVE.ARG 232705 . 233227 -) (SK.MAKE.POINTS.AND.ELEMENTS.MOVE.ARG 233229 . 234298) (SK.SHOW.FIG.FROM.INFO 234300 . 234668) ( -SK.MOVE.THING 234670 . 235576) (UPDATE.ELEMENT.IN.SKETCH 235578 . 237633) (SK.UPDATE.ELEMENT 237635 . -239194) (SK.UPDATE.ELEMENTS 239196 . 239915) (SK.UPDATE.ELEMENT1 239917 . 243817) ( -SK.MOVE.ELEMENT.POINT 243819 . 244234)) (244299 266588 (SK.MOVE.POINTS 244309 . 244596) ( -SK.SEL.AND.MOVE.POINTS 244598 . 244903) (SK.DO.MOVE.ELEMENT.POINTS 244905 . 253562) ( -SK.MOVE.ITEM.POINTS 253564 . 255235) (SK.TRANSLATEPTSFN 255237 . 255621) (SK.TRANSLATE.POINTS 255623 - . 256524) (SK.SELECT.MULTIPLE.POINTS 256526 . 262166) (SK.CONTROL.POINTS.IN.REGION 262168 . 263589) ( -SK.ADD.PT.SELECTION 263591 . 264055) (SK.REMOVE.PT.SELECTION 264057 . 264674) (SK.ADD.POINT 264676 . -265299) (SK.ELTS.CONTAINING.PTS 265301 . 265926) (SK.HOTSPOTS.NOT.ON.LIST 265928 . 266586)) (266746 -269542 (SK.SET.MOVE.MODE 266756 . 267427) (SK.SET.MOVE.MODE.POINTS 267429 . 267768) ( -SK.SET.MOVE.MODE.ELEMENTS 267770 . 268114) (SK.SET.MOVE.MODE.COMBINED 268116 . 268466) (READMOVEMODE -268468 . 269540)) (269543 288298 (SK.ALIGN.POINTS 269553 . 269843) (SK.SEL.AND.ALIGN.POINTS 269845 . -270154) (SK.ALIGN.POINTS.LEFT 270156 . 270459) (SK.ALIGN.POINTS.RIGHT 270461 . 270766) ( -SK.ALIGN.POINTS.TOP 270768 . 271069) (SK.ALIGN.POINTS.BOTTOM 271071 . 271378) ( -SK.EVEN.SPACE.POINTS.IN.X 271380 . 271700) (SK.EVEN.SPACE.POINTS.IN.Y 271702 . 272022) ( -SK.DO.ALIGN.POINTS 272024 . 282646) (SK.NTH.CONTROL.POINT 282648 . 283109) ( -SK.GET.SELECTED.ELEMENT.STRUCTURE 283111 . 283777) (SK.CORRESPONDING.CONTROL.PT 283779 . 284333) ( -SK.CONTROL.POINT.NUMBER 284335 . 284705) (SK.DO.ALIGN.SETVALUE 284707 . 288296)) (288362 301794 ( -SKETCH.CREATE.GROUP 288372 . 288861) (SK.CREATE.GROUP1 288863 . 289410) (SK.UPDATE.GROUP.AFTER.CHANGE -289412 . 290201) (SK.GROUP.ELTS 290203 . 290484) (SK.SEL.AND.GROUP 290486 . 290872) (SK.GROUP.ELEMENTS - 290874 . 292523) (SK.UNGROUP.ELT 292525 . 292809) (SK.SEL.AND.UNGROUP 292811 . 294480) ( -SK.UNGROUP.ELEMENT 294482 . 295418) (SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS 295420 . 296342) ( -SK.LOCAL.REGION.OF.LOCAL.ELEMENTS 296344 . 297355) (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS 297357 . -298697) (SK.UNIONREGIONS 298699 . 301065) (SKETCH.REGION.OF.SKETCH 301067 . 301483) (SK.FLASHREGION -301485 . 301792)) (301795 315266 (INIT.GROUP.ELEMENT 301805 . 302677) (GROUP.DRAWFN 302679 . 303129) ( -GROUP.EXPANDFN 303131 . 304694) (GROUP.INSIDEFN 304696 . 305105) (GROUP.REGIONFN 305107 . 305502) ( -GROUP.GLOBALREGIONFN 305504 . 305822) (GROUP.TRANSLATEFN 305824 . 307856) (GROUP.TRANSFORMFN 307858 . -311338) (GROUP.READCHANGEFN 311340 . 315264)) (315267 316275 (REGION.CENTER 315277 . 315878) ( -REMOVE.LAST 315880 . 316273)) (316328 321435 (SK.MOVE.GROUP.CONTROL.PT 316338 . 316629) ( -SK.SEL.AND.MOVE.CONTROL.PT 316631 . 318035) (SK.MOVE.GROUP.ELEMENT.CONTROL.POINT 318037 . 320110) ( -SK.READ.NEW.GROUP.CONTROL.PT 320112 . 321433)) (321694 326318 (SK.DO.GROUP 321704 . 323156) ( -SK.CHECK.WHENGROUPEDFN 323158 . 323868) (SK.DO.UNGROUP 323870 . 325075) (SK.CHECK.WHENUNGROUPEDFN -325077 . 325664) (SK.GROUP.UNDO 325666 . 325989) (SK.UNGROUP.UNDO 325991 . 326316)) (326559 331481 ( -SK.FREEZE.ELTS 326569 . 326853) (SK.SEL.AND.FREEZE 326855 . 327245) (SK.FREEZE.ELEMENTS 327247 . -327798) (SK.UNFREEZE.ELT 327800 . 328089) (SK.SEL.AND.UNFREEZE 328091 . 329627) (SK.UNFREEZE.ELEMENTS -329629 . 330188) (SK.FREEZE.UNDO 330190 . 330435) (SK.UNFREEZE.UNDO 330437 . 330684) (SK.DO.FREEZE -330686 . 331079) (SK.DO.UNFREEZE 331081 . 331479)) (331711 341521 (SKETCH.ELEMENTS.OF.SKETCH 331721 . -332556) (SKETCH.LIST.OF.ELEMENTS 332558 . 333276) (SKETCH.ADD.ELEMENT 333278 . 334353) ( -SKETCH.DELETE.ELEMENT 334355 . 336087) (DELFROMGROUPELT 336089 . 336889) (SKETCH.ELEMENT.TYPE 336891 - . 337240) (SKETCH.ELEMENT.CHANGED 337242 . 338810) (SK.ELEMENT.CHANGED1 338812 . 339463) ( -SK.UPDATE.GLOBAL.IMAGE.OBJECT.ELEMENT 339465 . 341519)) (341575 346187 (INSURE.SKETCH 341585 . 344200) - (LOCALSPECS.FROM.VIEWER 344202 . 344562) (SK.LOCAL.ELT.FROM.GLOBALPART 344564 . 345032) ( -SKETCH.FROM.VIEWER 345034 . 345268) (INSPECT.SKETCH 345270 . 345595) (ELT.INSIDE.SKETCHWP 345597 . -345870) (SK.INSIDE.REGION 345872 . 346185)) (346188 350518 (MAPSKETCHSPECS 346198 . 346819) ( -MAPCOLLECTSKETCHSPECS 346821 . 347570) (MAPSKETCHSPECSUNTIL 347572 . 348380) (MAPGLOBALSKETCHSPECS -348382 . 349083) (MAPGLOBALSKETCHELEMENTS 349085 . 350516)) (350580 376472 (SK.ADD.SELECTION 350590 . -351330) (SK.COPY.INSERTFN 351332 . 354963) (SCREENELEMENTP 354965 . 355438) (SK.ITEM.REGION 355440 . -355927) (SK.ELEMENT.GLOBAL.REGION 355929 . 356457) (SK.LOCAL.ITEMS.IN.REGION 356459 . 358438) ( -SK.REGIONFN 358440 . 358762) (SK.GLOBAL.REGIONFN 358764 . 359122) (SK.REMOVE.SELECTION 359124 . 359852 -) (SK.SELECT.MULTIPLE.ITEMS 359854 . 370296) (SKETCH.GET.ELEMENTS 370298 . 371721) (SK.PUT.MARKS.UP -371723 . 372062) (SK.TAKE.MARKS.DOWN 372064 . 372403) (SK.TRANSLATE.GLOBALPART 372405 . 374532) ( -SK.TRANSLATE.ITEM 374534 . 375461) (SK.TRANSLATEFN 375463 . 375659) (TRANSLATE.SKETCH 375661 . 376470) -) (376738 379645 (SK.INPUT.SCALE 376748 . 377595) (SK.UPDATE.SKETCHCONTEXT 377597 . 378194) ( -SK.SET.INPUT.SCALE 378196 . 378845) (SK.SET.INPUT.SCALE.CURRENT 378847 . 379138) ( -SK.SET.INPUT.SCALE.VALUE 379140 . 379643)) (379696 381608 (SK.SET.FEEDBACK.MODE 379706 . 381012) ( -SK.SET.FEEDBACK.POINT 381014 . 381182) (SK.SET.FEEDBACK.VERBOSE 381184 . 381353) ( -SK.SET.FEEDBACK.ALWAYS 381355 . 381606)) (381759 383137 (SKETCH.TITLE 381769 . 382133) ( -SK.SHRINK.ICONCREATE 382135 . 383135)) (388827 391641 (READBRUSHSHAPE 388837 . 389296) (READ.FUNCTION -389298 . 389813) (READBRUSHSIZE 389815 . 390273) (READANGLE 390275 . 390767) (READARCDIRECTION 390769 - . 391639)) (391642 402053 (SK.CHANGE.DASHING 391652 . 395600) (READ.AND.SAVE.NEW.DASHING 395602 . -397370) (READ.NEW.DASHING 397372 . 399112) (READ.DASHING.CHANGE 399114 . 400589) (SK.CACHE.DASHING -400591 . 401593) (SK.DASHING.LABEL 401595 . 402051)) (402054 405759 (READ.FILLING.CHANGE 402064 . -404045) (SK.CACHE.FILLING 404047 . 404765) (READ.AND.SAVE.NEW.FILLING 404767 . 405365) ( -SK.FILLING.LABEL 405367 . 405757)) (406143 442396 (SK.GETGLOBALPOSITION 406153 . 406458) ( -SKETCH.TRACK.ELEMENTS 406460 . 409980) (SK.PICKOUT.WHOLE.MOVE.ELEMENTS 409982 . 410541) ( -MAP.SKETCH.ELEMENTS.INTO.VIEWER 410543 . 410935) (MAP.GLOBAL.POSITION.INTO.VIEWER 410937 . 411317) ( -SKETCH.TO.VIEWER.POSITION 411319 . 411678) (SKETCH.TRACK.IMAGE 411680 . 412534) (SK.TRACK.IMAGE1 -412536 . 413948) (MAP.VIEWER.XY.INTO.GLOBAL 413950 . 414944) (SK.SET.POSITION 414946 . 415282) ( -MAP.VIEWER.PT.INTO.GLOBAL 415284 . 416390) (VIEWER.TO.SKETCH.POSITION 416392 . 417027) ( -SK.INSURE.SCALE 417029 . 417289) (SKETCH.TO.VIEWER.REGION 417291 . 418097) (VIEWER.TO.SKETCH.REGION -418099 . 418437) (SK.READ.POINT.WITH.FEEDBACK 418439 . 429442) (SKETCH.GET.POSITION 429444 . 431324) ( -\CLOBBER.POSITION 431326 . 431774) (NEAREST.HOT.SPOT 431776 . 433304) (GETWREGION 433306 . 434067) ( -GET.BITMAP.POSITION 434069 . 434853) (SK.TRACK.BITMAP1 434855 . 442394)) (442965 473851 ( -SK.BRING.UP.POSITION.PAD 442975 . 448835) (SK.PAD.READER.POSITION 448837 . 450486) ( -SK.POSITION.READER.REPAINTFN 450488 . 452272) (SK.POSITION.PAD.FROM.VIEWER 452274 . 453616) ( -SK.INIT.POSITION.NUMBER.PAD.MENU 453618 . 453968) (SK.READ.POSITION.PAD.HANDLER 453970 . 459702) ( -DISPLAY.POSITION.READER.TOTAL 459704 . 462002) (POSITION.PAD.READER.HANDLER 462004 . 470047) ( -POSITIONPAD.HELDFN 470049 . 471533) (\POSITION.PAD.ADD.DIGIT.MENU 471535 . 473114) ( -\POSITION.READER.NUMBERPAD 473116 . 473849)) (475477 478155 (SK.DRAWFN 475487 . 475853) ( -SK.TRANSFORMFN 475855 . 476236) (SK.EXPANDFN 476238 . 476515) (SK.INPUT 476517 . 476898) (SK.INSIDEFN -476900 . 477540) (SK.UPDATEFN 477542 . 478153)) (483320 485476 (UPDATE-SKETCH 483330 . 484443) ( -EDIT-SKETCH 484445 . 485474)) (486077 490022 (SK.CHECK.SKETCH.VERSION 486087 . 487327) ( -SK.INSURE.RECORD.LENGTH 487329 . 488812) (SK.INSURE.HAS.LENGTH 488814 . 489552) (SK.RECORD.LENGTH -489554 . 489728) (SK.SET.RECORD.LENGTHS 489730 . 490020)) (490485 491372 ( -SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER 490495 . 491370))))) + (FILEMAP (NIL (18101 19973 (SKETCH.FLUSH.EXISTING 18111 . 19971)) (20083 31463 (SKETCH.FROM.A.FILE +20093 . 20509) (SK.PUT.ON.FILE 20511 . 22007) (SKETCH.PUT 22009 . 24652) (SK.OUTPUT.FILE.NAME 24654 . +25139) (SK.INCLUDE.FILE 25141 . 28007) (SK.GET.IMAGEOBJ.FROM.FILE 28009 . 30172) (SK.GET.FROM.FILE +30174 . 31156) (SKETCH.GET 31158 . 31461)) (31464 90453 (SKETCH 31474 . 33642) (SKETCHW.CREATE 33644 + . 43169) (SKETCH.RESET 43171 . 44794) (SKETCHW.FIG.CHANGED 44796 . 45120) (SK.WINDOW.TITLE 45122 . +45610) (EDITSLIDE 45612 . 46123) (EDITSKETCH 46125 . 46445) (ADD.SKETCH.TO.VIEWER 46447 . 49037) ( +SK.ADD.ELEMENTS.TO.SKETCH 49039 . 49537) (SKETCH.SET.A.DEFAULT 49539 . 57098) (SK.POPUP.SELECTIONFN +57100 . 57626) (GETSKETCHWREGION 57628 . 57830) (SK.ADD.ELEMENT 57832 . 59395) ( +SK.ADD.PRIORITY.ELEMENT.TO.SKETCH 59397 . 60751) (SK.ELTS.BY.PRIORITY 60753 . 61034) ( +SK.ORDER.ELEMENTS 61036 . 61288) (SK.ADD.PRIORITY.LOCAL.ELEMENT.TO.SKETCH 61290 . 62901) ( +SK.ADD.ELEMENTS 62903 . 63516) (SK.CHECK.WHENADDEDFN 63518 . 64232) (SK.APPLY.MENU.COMMAND 64234 . +65074) (SK.DELETE.ELEMENT1 65076 . 66626) (SK.MARK.DIRTY 66628 . 67382) (SK.MARK.UNDIRTY 67384 . 67802 +) (SK.MENU.AND.RETURN.FIELD 67804 . 68576) (SKETCH.SET.BRUSH.SHAPE 68578 . 69161) ( +SKETCH.SET.BRUSH.SIZE 69163 . 69665) (SKETCHW.CLOSEFN 69667 . 71612) (SK.CONFIRM.DESTRUCTION 71614 . +72596) (SKETCHW.OUTFN 72598 . 72846) (SKETCHW.REOPENFN 72848 . 73426) (MAKE.LOCAL.SKETCH 73428 . 74125 +) (MAP.SKETCHSPEC.INTO.VIEWER 74127 . 75427) (SKETCHW.REPAINTFN 75429 . 76317) (SKETCHW.REPAINTFN1 +76319 . 77241) (SK.DRAWFIGURE.IF 77243 . 77742) (SKETCHW.SCROLLFN 77744 . 82116) (SKETCHW.RESHAPEFN +82118 . 84558) (SK.UPDATE.EVENT.SELECTION 84560 . 86599) (LIGHTGRAYWINDOW 86601 . 86760) ( +SK.ADD.SPACES 86762 . 87504) (SK.SKETCH.MENU 87506 . 87824) (SK.CHECK.IMAGEOBJ.WHENDELETEDFN 87826 . +88663) (SK.APPLY.IMAGEOBJ.WHENDELETEDFN 88665 . 89757) (SK.RETURN.TTY 89759 . 90123) (SK.TAKE.TTY +90125 . 90451)) (90507 114106 (SKETCH.COMMANDMENU 90517 . 90951) (SKETCH.COMMANDMENU.ITEMS 90953 . +111036) (CREATE.SKETCHW.COMMANDMENU 111038 . 111454) (SKETCHW.SELECTIONFN 111456 . 112539) ( +SKETCH.MONITORLOCK 112541 . 113008) (SK.EVAL.AS.PROCESS 113010 . 113724) (SK.EVAL.WITH.LOCK 113726 . +114104)) (114107 122470 (SK.FIX.MENU 114117 . 115312) (SK.SET.UP.MENUS 115314 . 117674) ( +SK.INSURE.HAS.MENU 117676 . 118418) (SK.CREATE.STANDARD.MENU 118420 . 118861) (SK.ADD.ITEM.TO.MENU +118863 . 119759) (SK.GET.VIEWER.POPUP.MENU 119761 . 122080) (SK.CLEAR.POPUP.MENU 122082 . 122468)) ( +122526 131359 (SKETCH.CREATE 122536 . 123320) (GETSKETCHPROP 123322 . 126375) (PUTSKETCHPROP 126377 . +130302) (CREATE.DEFAULT.SKETCH.CONTEXT 130304 . 131357)) (131525 153881 (SK.COPY.BUTTONEVENTFN 131535 + . 143424) (SK.BUTTONEVENT.MARK 143426 . 143910) (SK.BUILD.IMAGEOBJ 143912 . 152471) ( +SK.BUTTONEVENT.OVERP 152473 . 153080) (SK.BUTTONEVENT.SAME.KEYS 153082 . 153879)) (154160 180880 ( +SK.SEL.AND.CHANGE 154170 . 154563) (SK.CHECK.WHENCHANGEDFN 154565 . 155255) (SK.CHECK.PRECHANGEFN +155257 . 155842) (SK.CHANGE.ELT 155844 . 156032) (SK.CHANGE.THING 156034 . 157453) ( +SKETCH.CHANGE.ELEMENTS 157455 . 158617) (SK.APPLY.SINGLE.CHANGEFN 158619 . 159176) (SK.DO.CHANGESPECS +159178 . 160932) (SK.VIEWER.FROM.SKETCH.ARG 160934 . 161360) (SK.DO.CHANGESPEC1 161362 . 163354) ( +SK.CHANGEFN 163356 . 163920) (SK.READCHANGEFN 163922 . 164364) (SK.DEFAULT.CHANGEFN 164366 . 166977) ( +CHANGEABLEFIELDITEMS 166979 . 167606) (SK.APPLY.CHANGE.COMMAND 167608 . 168325) ( +SK.DO.AND.RECORD.CHANGES 168327 . 169696) (SK.APPLY.CHANGE.COMMAND1 169698 . 171158) ( +SK.ELEMENTS.CHANGEFN 171160 . 173535) (READ.POINT.TO.ADD 173537 . 174465) (GLOBAL.KNOT.FROM.LOCAL +174467 . 175028) (SK.ADD.KNOT.TO.ELEMENT 175030 . 176135) (SK.GROUP.CHANGEFN 176137 . 177343) ( +SK.GROUP.CHANGEFN1 177345 . 180878)) (181047 195989 (ADD.ELEMENT.TO.SKETCH 181057 . 182747) ( +ADD.SKETCH.VIEWER 182749 . 183413) (REMOVE.SKETCH.VIEWER 183415 . 184024) (ALL.SKETCH.VIEWERS 184026 + . 184367) (SKETCH.ALL.VIEWERS 184369 . 184629) (VIEWER.BUCKET 184631 . 184778) (ELT.INSIDE.REGION? +184780 . 185208) (ELT.INSIDE.SKWP 185210 . 185602) (SCALE.FROM.SKW 185604 . 185850) ( +SK.ADDELT.TO.WINDOW 185852 . 187019) (SK.CALC.REGION.VIEWED 187021 . 187395) (SK.DRAWFIGURE 187397 . +188668) (SK.DRAWFIGURE1 188670 . 189050) (SK.LOCAL.FROM.GLOBAL 189052 . 190428) (SKETCH.REGION.VIEWED +190430 . 193366) (SKETCH.VIEW.FROM.NAME 193368 . 193899) (SK.UPDATE.REGION.VIEWED 193901 . 194289) ( +SKETCH.ADD.AND.DISPLAY 194291 . 194683) (SKETCH.ADD.AND.DISPLAY1 194685 . 195224) (SK.ADD.ITEM 195226 + . 195542) (SKETCHW.ADD.INSTANCE 195544 . 195987)) (196030 209355 (SK.SEL.AND.DELETE 196040 . 196424) +(SK.ERASE.AND.DELETE.ITEM 196426 . 196841) (REMOVE.ELEMENT.FROM.SKETCH 196843 . 197937) ( +SK.DELETE.ELEMENT 197939 . 198481) (SK.DELETE.ELEMENT2 198483 . 199128) (SK.DELETE.KNOT 199130 . +199522) (SK.SEL.AND.DELETE.KNOT 199524 . 200645) (SK.DELETE.ELEMENT.KNOT 200647 . 203860) ( +SK.CHECK.WHENDELETEDFN 203862 . 204625) (SK.CHECK.PREEDITFN 204627 . 205212) ( +SK.CHECK.END.INITIAL.EDIT 205214 . 205732) (SK.CHECK.WHENPOINTDELETEDFN 205734 . 206514) (SK.ERASE.ELT + 206516 . 206848) (SK.DELETE.ELT 206850 . 207221) (SK.DELETE.ITEM 207223 . 207627) (DELFROMTCONC +207629 . 209353)) (209394 223511 (SK.COPY.ELT 209404 . 209770) (SK.SEL.AND.COPY 209772 . 210151) ( +SK.COPY.ELEMENTS 210153 . 215995) (SK.ADD.COPY.OF.ELEMENTS 215997 . 217811) ( +SK.GLOBAL.FROM.LOCAL.ELEMENTS 217813 . 218138) (SK.COPY.ITEM 218140 . 218904) (SK.INSERT.SKETCH 218906 + . 223509)) (223551 253998 (SK.MOVE.ELT 223561 . 223937) (SK.MOVE.ELT.OR.PT 223939 . 224353) ( +SK.APPLY.DEFAULT.MOVE 224355 . 224956) (SK.SEL.AND.MOVE 224958 . 225489) (SK.MOVE.ELEMENTS 225491 . +236561) (SKETCH.MOVE.ELEMENTS 236563 . 238453) (SKETCH.COPY.ELEMENTS 238455 . 240461) ( +\SKETCH.COPY.ELEMENT 240463 . 241180) (SK.TRANSLATE.ELEMENT 241182 . 241649) (SK.COPY.GLOBAL.ELEMENT +241651 . 241862) (SK.MAKE.ELEMENT.MOVE.ARG 241864 . 242467) (SK.MAKE.ELEMENTS.MOVE.ARG 242469 . 242974 +) (SK.MAKE.POINTS.AND.ELEMENTS.MOVE.ARG 242976 . 244028) (SK.SHOW.FIG.FROM.INFO 244030 . 244394) ( +SK.MOVE.THING 244396 . 245298) (UPDATE.ELEMENT.IN.SKETCH 245300 . 247303) (SK.UPDATE.ELEMENT 247305 . +248822) (SK.UPDATE.ELEMENTS 248824 . 249527) (SK.UPDATE.ELEMENT1 249529 . 253583) ( +SK.MOVE.ELEMENT.POINT 253585 . 253996)) (254061 277032 (SK.MOVE.POINTS 254071 . 254459) ( +SK.SEL.AND.MOVE.POINTS 254461 . 254751) (SK.DO.MOVE.ELEMENT.POINTS 254753 . 263337) ( +SK.MOVE.ITEM.POINTS 263339 . 265094) (SK.TRANSLATEPTSFN 265096 . 265476) (SK.TRANSLATE.POINTS 265478 + . 266375) (SK.SELECT.MULTIPLE.POINTS 266377 . 272279) (SK.CONTROL.POINTS.IN.REGION 272281 . 273754) ( +SK.ADD.PT.SELECTION 273756 . 274216) (SK.REMOVE.PT.SELECTION 274218 . 274820) (SK.ADD.POINT 274822 . +275550) (SK.ELTS.CONTAINING.PTS 275552 . 276385) (SK.HOTSPOTS.NOT.ON.LIST 276387 . 277030)) (277190 +280066 (SK.SET.MOVE.MODE 277200 . 277856) (SK.SET.MOVE.MODE.POINTS 277858 . 278193) ( +SK.SET.MOVE.MODE.ELEMENTS 278195 . 278535) (SK.SET.MOVE.MODE.COMBINED 278537 . 278883) (READMOVEMODE +278885 . 280064)) (280067 299658 (SK.ALIGN.POINTS 280077 . 280468) (SK.SEL.AND.ALIGN.POINTS 280470 . +280764) (SK.ALIGN.POINTS.LEFT 280766 . 281170) (SK.ALIGN.POINTS.RIGHT 281172 . 281578) ( +SK.ALIGN.POINTS.TOP 281580 . 281982) (SK.ALIGN.POINTS.BOTTOM 281984 . 282392) ( +SK.EVEN.SPACE.POINTS.IN.X 282394 . 282815) (SK.EVEN.SPACE.POINTS.IN.Y 282817 . 283238) ( +SK.DO.ALIGN.POINTS 283240 . 293968) (SK.NTH.CONTROL.POINT 293970 . 294431) ( +SK.GET.SELECTED.ELEMENT.STRUCTURE 294433 . 295084) (SK.CORRESPONDING.CONTROL.PT 295086 . 295624) ( +SK.CONTROL.POINT.NUMBER 295626 . 296097) (SK.DO.ALIGN.SETVALUE 296099 . 299656)) (299722 313949 ( +SKETCH.CREATE.GROUP 299732 . 300217) (SK.CREATE.GROUP1 300219 . 300768) (SK.UPDATE.GROUP.AFTER.CHANGE +300770 . 301660) (SK.GROUP.ELTS 301662 . 302044) (SK.SEL.AND.GROUP 302046 . 302428) (SK.GROUP.ELEMENTS + 302430 . 304174) (SK.UNGROUP.ELT 304176 . 304561) (SK.SEL.AND.UNGROUP 304563 . 306228) ( +SK.UNGROUP.ELEMENT 306230 . 307298) (SK.GLOBAL.REGION.OF.LOCAL.ELEMENTS 307300 . 308323) ( +SK.LOCAL.REGION.OF.LOCAL.ELEMENTS 308325 . 309437) (SK.GLOBAL.REGION.OF.GLOBAL.ELEMENTS 309439 . +310868) (SK.UNIONREGIONS 310870 . 313228) (SKETCH.REGION.OF.SKETCH 313230 . 313642) (SK.FLASHREGION +313644 . 313947)) (313950 327728 (INIT.GROUP.ELEMENT 313960 . 314828) (GROUP.DRAWFN 314830 . 315276) ( +GROUP.EXPANDFN 315278 . 316951) (GROUP.INSIDEFN 316953 . 317463) (GROUP.REGIONFN 317465 . 317856) ( +GROUP.GLOBALREGIONFN 317858 . 318277) (GROUP.TRANSLATEFN 318279 . 320294) (GROUP.TRANSFORMFN 320296 . +323798) (GROUP.READCHANGEFN 323800 . 327726)) (327729 328737 (REGION.CENTER 327739 . 328340) ( +REMOVE.LAST 328342 . 328735)) (328790 334311 (SK.MOVE.GROUP.CONTROL.PT 328800 . 329192) ( +SK.SEL.AND.MOVE.CONTROL.PT 329194 . 330699) (SK.MOVE.GROUP.ELEMENT.CONTROL.POINT 330701 . 332885) ( +SK.READ.NEW.GROUP.CONTROL.PT 332887 . 334309)) (334570 339213 (SK.DO.GROUP 334580 . 336071) ( +SK.CHECK.WHENGROUPEDFN 336073 . 336779) (SK.DO.UNGROUP 336781 . 337982) (SK.CHECK.WHENUNGROUPEDFN +337984 . 338567) (SK.GROUP.UNDO 338569 . 338888) (SK.UNGROUP.UNDO 338890 . 339211)) (339454 344546 ( +SK.FREEZE.ELTS 339464 . 339849) (SK.SEL.AND.FREEZE 339851 . 340237) (SK.FREEZE.ELEMENTS 340239 . +340786) (SK.UNFREEZE.ELT 340788 . 341178) (SK.SEL.AND.UNFREEZE 341180 . 342712) (SK.UNFREEZE.ELEMENTS +342714 . 343269) (SK.FREEZE.UNDO 343271 . 343512) (SK.UNFREEZE.UNDO 343514 . 343757) (SK.DO.FREEZE +343759 . 344148) (SK.DO.UNFREEZE 344150 . 344544)) (344776 354859 (SKETCH.ELEMENTS.OF.SKETCH 344786 . +345599) (SKETCH.LIST.OF.ELEMENTS 345601 . 346300) (SKETCH.ADD.ELEMENT 346302 . 347360) ( +SKETCH.DELETE.ELEMENT 347362 . 349074) (DELFROMGROUPELT 349076 . 349977) (SKETCH.ELEMENT.TYPE 349979 + . 350324) (SKETCH.ELEMENT.CHANGED 350326 . 351876) (SK.ELEMENT.CHANGED1 351878 . 352630) ( +SK.UPDATE.GLOBAL.IMAGE.OBJECT.ELEMENT 352632 . 354857)) (354913 360118 (INSURE.SKETCH 354923 . 357848) + (LOCALSPECS.FROM.VIEWER 357850 . 358206) (SK.LOCAL.ELT.FROM.GLOBALPART 358208 . 358660) ( +SKETCH.FROM.VIEWER 358662 . 358896) (INSPECT.SKETCH 358898 . 359324) (ELT.INSIDE.SKETCHWP 359326 . +359700) (SK.INSIDE.REGION 359702 . 360116)) (360119 364368 (MAPSKETCHSPECS 360129 . 360734) ( +MAPCOLLECTSKETCHSPECS 360736 . 361469) (MAPSKETCHSPECSUNTIL 361471 . 362263) (MAPGLOBALSKETCHSPECS +362265 . 362950) (MAPGLOBALSKETCHELEMENTS 362952 . 364366)) (364430 391257 (SK.ADD.SELECTION 364440 . +365163) (SK.COPY.INSERTFN 365165 . 368588) (SCREENELEMENTP 368590 . 369048) (SK.ITEM.REGION 369050 . +369704) (SK.ELEMENT.GLOBAL.REGION 369706 . 370386) (SK.LOCAL.ITEMS.IN.REGION 370388 . 372337) ( +SK.REGIONFN 372339 . 372645) (SK.GLOBAL.REGIONFN 372647 . 372989) (SK.REMOVE.SELECTION 372991 . 373702 +) (SK.SELECT.MULTIPLE.ITEMS 373704 . 384678) (SKETCH.GET.ELEMENTS 384680 . 386204) (SK.PUT.MARKS.UP +386206 . 386646) (SK.TAKE.MARKS.DOWN 386648 . 387088) (SK.TRANSLATE.GLOBALPART 387090 . 389347) ( +SK.TRANSLATE.ITEM 389349 . 390260) (SK.TRANSLATEFN 390262 . 390454) (TRANSLATE.SKETCH 390456 . 391255) +) (391523 394700 (SK.INPUT.SCALE 391533 . 392456) (SK.UPDATE.SKETCHCONTEXT 392458 . 393156) ( +SK.SET.INPUT.SCALE 393158 . 393803) (SK.SET.INPUT.SCALE.CURRENT 393805 . 394197) ( +SK.SET.INPUT.SCALE.VALUE 394199 . 394698)) (394751 396742 (SK.SET.FEEDBACK.MODE 394761 . 396055) ( +SK.SET.FEEDBACK.POINT 396057 . 396225) (SK.SET.FEEDBACK.VERBOSE 396227 . 396487) ( +SK.SET.FEEDBACK.ALWAYS 396489 . 396740)) (396893 398834 (SKETCH.TITLE 396903 . 397267) ( +SK.SHRINK.ICONCREATE 397269 . 398832)) (404524 407501 (READBRUSHSHAPE 404534 . 404995) (READ.FUNCTION +404997 . 405508) (READBRUSHSIZE 405510 . 405964) (READANGLE 405966 . 406454) (READARCDIRECTION 406456 + . 407499)) (407502 418694 (SK.CHANGE.DASHING 407512 . 411993) (READ.AND.SAVE.NEW.DASHING 411995 . +413921) (READ.NEW.DASHING 413923 . 415665) (READ.DASHING.CHANGE 415667 . 417133) (SK.CACHE.DASHING +417135 . 418238) (SK.DASHING.LABEL 418240 . 418692)) (418695 422750 (READ.FILLING.CHANGE 418705 . +420682) (SK.CACHE.FILLING 420684 . 421503) (READ.AND.SAVE.NEW.FILLING 421505 . 422255) ( +SK.FILLING.LABEL 422257 . 422748)) (423134 459191 (SK.GETGLOBALPOSITION 423144 . 423550) ( +SKETCH.TRACK.ELEMENTS 423552 . 427053) (SK.PICKOUT.WHOLE.MOVE.ELEMENTS 427055 . 427598) ( +MAP.SKETCH.ELEMENTS.INTO.VIEWER 427600 . 427988) (MAP.GLOBAL.POSITION.INTO.VIEWER 427990 . 428366) ( +SKETCH.TO.VIEWER.POSITION 428368 . 428711) (SKETCH.TRACK.IMAGE 428713 . 429550) (SK.TRACK.IMAGE1 +429552 . 431051) (MAP.VIEWER.XY.INTO.GLOBAL 431053 . 432018) (SK.SET.POSITION 432020 . 432457) ( +MAP.VIEWER.PT.INTO.GLOBAL 432459 . 433541) (VIEWER.TO.SKETCH.POSITION 433543 . 434162) ( +SK.INSURE.SCALE 434164 . 434420) (SKETCH.TO.VIEWER.REGION 434422 . 435212) (VIEWER.TO.SKETCH.REGION +435214 . 435536) (SK.READ.POINT.WITH.FEEDBACK 435538 . 446164) (SKETCH.GET.POSITION 446166 . 448028) ( +\CLOBBER.POSITION 448030 . 448462) (NEAREST.HOT.SPOT 448464 . 449992) (GETWREGION 449994 . 450694) ( +GET.BITMAP.POSITION 450696 . 451449) (SK.TRACK.BITMAP1 451451 . 459189)) (459760 491951 ( +SK.BRING.UP.POSITION.PAD 459770 . 465795) (SK.PAD.READER.POSITION 465797 . 467426) ( +SK.POSITION.READER.REPAINTFN 467428 . 469415) (SK.POSITION.PAD.FROM.VIEWER 469417 . 470967) ( +SK.INIT.POSITION.NUMBER.PAD.MENU 470969 . 471315) (SK.READ.POSITION.PAD.HANDLER 471317 . 477080) ( +DISPLAY.POSITION.READER.TOTAL 477082 . 479469) (POSITION.PAD.READER.HANDLER 479471 . 487925) ( +POSITIONPAD.HELDFN 487927 . 489410) (\POSITION.PAD.ADD.DIGIT.MENU 489412 . 491092) ( +\POSITION.READER.NUMBERPAD 491094 . 491949)) (493577 496432 (SK.DRAWFN 493587 . 493949) ( +SK.TRANSFORMFN 493951 . 494328) (SK.EXPANDFN 494330 . 494607) (SK.INPUT 494609 . 494986) (SK.INSIDEFN +494988 . 495836) (SK.UPDATEFN 495838 . 496430)) (501597 503753 (UPDATE-SKETCH 501607 . 502720) ( +EDIT-SKETCH 502722 . 503751)) (504354 508314 (SK.CHECK.SKETCH.VERSION 504364 . 505476) ( +SK.INSURE.RECORD.LENGTH 505478 . 506922) (SK.INSURE.HAS.LENGTH 506924 . 507681) (SK.RECORD.LENGTH +507683 . 507853) (SK.SET.RECORD.LENGTHS 507855 . 508312)) (508777 509719 ( +SK.ADD.EDIT.COMMAND.TO.FILE.BROWSER 508787 . 509717))))) STOP diff --git a/library/sketch/SKETCH.LCOM b/library/sketch/SKETCH.LCOM index 0b292838..15cf7aa2 100644 Binary files a/library/sketch/SKETCH.LCOM and b/library/sketch/SKETCH.LCOM differ diff --git a/library/tedit/TEDIT b/library/tedit/TEDIT index 2522759e..5c5ff485 100644 --- a/library/tedit/TEDIT +++ b/library/tedit/TEDIT @@ -1,12 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) -(FILECREATED "24-Dec-2025 22:45:39" {WMEDLEY}TEDIT>TEDIT.;847 145111 +(FILECREATED " 2-Mar-2026 18:32:06" {WMEDLEY}tedit>TEDIT.;853 146506 :EDIT-BY rmk :CHANGES-TO (VARS TEDITCOMS) - :PREVIOUS-DATE "24-Dec-2025 11:23:12" {WMEDLEY}TEDIT>TEDIT.;846) + :PREVIOUS-DATE " 4-Feb-2026 16:02:02" {WMEDLEY}tedit>TEDIT.;852) (PRETTYCOMPRINT TEDITCOMS) @@ -28,9 +28,7 @@ (EXPORT (FILES (FROM LOADUPS) EXPORTS.ALL))) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES TEDIT-EXPORTS.ALL)) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - UNICODE))) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES TEDIT-EXPORTS.ALL))) [DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "Assertions go to comments if not being checked, so we see value-warnings") @@ -47,7 +45,7 @@ (FNS TEDIT TEXTSTREAM TEXTSTREAMP COERCETEXTSTREAM TEDIT.CONCAT TEDITSTRING TEDIT-SEE TEDIT.COPY TEDIT.DELETE TEDIT.INSERT TEDIT.TERPRI TEDIT.KILL TEDIT.QUIT TEDIT.MOVE - TEDIT.STRINGWIDTH TEDIT.CHARWIDTH) + TEDIT.STRINGWIDTH TEDIT.CHARWIDTH TEDIT.PARAGRAPH.BOUNDARIES) (FNS TEXTOBJ COERCETEXTOBJ) (MACROS TEVAL) (FNS TDRIBBLE) @@ -157,11 +155,6 @@ (FILESLOAD TEDIT-EXPORTS.ALL) ) (DECLARE%: EVAL@COMPILE DONTCOPY - -(FILESLOAD (LOADCOMP) - UNICODE) -) -(DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS TEDIT-ASSERT MACRO [ARGS (COND @@ -676,6 +669,26 @@ (CR (IMAX 6 (CHARWIDTH CH FONT))) (TAB 36) (CHARWIDTH CH FONT]) + +(TEDIT.PARAGRAPH.BOUNDARIES + [LAMBDA (TSTREAM SELORCH# PROTECTEDNOTOK) (* ; "Edited 2-Feb-2026 23:05 by rmk") + + (* ;; "Returns a pair (FIRSTCH# LASTCH#) where FIRSTCH# is the character number of the first character of the paragraph that contains the beginning of the selection, and LASTCH# is the last character number of the last character of the paragraph that contains the end of the selection.") + + (* ;; + "If PROTECTIONNOTOK, the scans stop at any protected piece (e.g. doesn't cross menu boiler plate).") + + (LET ((TEXTOBJ (TEXTOBJ TSTREAM))) + (CL:UNLESS SELORCH# + (SETQ SELORCH# (TEXTSEL TEXTOBJ))) + (LIST (CAR (\TEDIT.PARA.FIRST TEXTOBJ (CL:IF (type? SELECTION SELORCH#) + (GETSEL SELORCH# CH#) + SELORCH#) + PROTECTEDNOTOK)) + (CAR (\TEDIT.PARA.LAST TEXTOBJ (CL:IF (type? SELECTION SELORCH#) + (GETSEL SELORCH# CHLAST) + SELORCH#) + PROTECTEDNOTOK]) ) (DEFINEQ @@ -912,7 +925,8 @@ else (TEDIT.PROMPTPRINT TSTREAM "Changed object not found in document" T]) (TEDIT.MAP.OBJECTS - [LAMBDA (TSTREAM FN FNARG COLLECT?) (* ; "Edited 25-Feb-2025 15:06 by rmk") + [LAMBDA (TSTREAM FN FNARG COLLECT?) (* ; "Edited 4-Feb-2026 16:01 by rmk") + (* ; "Edited 25-Feb-2025 15:06 by rmk") (* ; "Edited 23-Apr-2024 09:15 by rmk") (* ; "Edited 16-Mar-2024 10:03 by rmk") (* ; "Edited 4-Mar-2024 16:12 by rmk") @@ -932,8 +946,7 @@ (NIL) (OBJECT (PUSH $$VAL OBJ)) (CH# (PUSH $$VAL CH#)) - (VALUE (PUSH $$VAL CH#) - FNVAL) + (VALUE (PUSH $$VAL FNVAL)) (FIRST (RETURN (LIST CH# OBJ FNVAL))) (PUSH $$VAL (LIST CH# OBJ FNVAL))) (CL:WHEN (EQ FNVAL 'STOP) @@ -1325,7 +1338,9 @@ (CL:WHEN TYPEIN (\TEDIT.SCROLL.CARET TSTREAM)))])]) (\TEDIT.MOVE - [LAMBDA (FROMSEL TOSEL FROMTSTREAM TOTSTREAM) (* ; "Edited 7-May-2025 00:12 by rmk") + [LAMBDA (FROMSEL TOSEL FROMTSTREAM TOTSTREAM) (* ; "Edited 31-Jan-2026 11:48 by rmk") + (* ; "Edited 10-Jan-2026 01:38 by rmk") + (* ; "Edited 7-May-2025 00:12 by rmk") (* ; "Edited 22-Apr-2025 09:21 by rmk") (* ; "Edited 16-Apr-2025 09:01 by rmk") (* ; "Edited 6-Apr-2025 14:14 by rmk") @@ -1385,7 +1400,7 @@ (CL:WHEN (AND (FGETTOBJ TOOBJ BLUEPENDINGDELETE) (IGREATERP TODCH 0)) (FSETTOBJ TOOBJ BLUEPENDINGDELETE NIL) - (CL:UNLESS (\TEDIT.DELETE TOOBJ TOSEL) + (CL:UNLESS (\TEDIT.DELETE TOTSTREAM TOSEL) (RETURN NIL)) (SETQ BPD T) (CL:WHEN (EQ TOOBJ FROMOBJ) (* ; "Same text, pre-adjust the source") @@ -1421,15 +1436,14 @@ (* ;; "Pop to accumulate into a single event (BPD, DELETE, INSERT).") - else (\TEDIT.DELETE FROMOBJ FROMSEL NIL NIL T)) + else (\TEDIT.DELETE FROMTSTREAM FROMSEL NIL NIL T)) (* ;; "Deletion accomplished possibly in separate FROMOBJ with its own history.") (* ;; "") (CL:WHEN (GETTEXTPROP TOOBJ 'COPYBYBKSYSBUF) - (\TEDIT.FOREIGN.COPY (WFROMDS TOTSTREAM) - FROMSEL T) + (\TEDIT.FOREIGN.COPY FROMSEL FROMTSTREAM T) (CL:WHEN BPD (* ; "If no BPD, TO history is good") (\TEDIT.HISTORYADD.COMPOSITE TOOBJ TOOBJ (LIST (\TEDIT.POPEVENT TOOBJ) (\TEDIT.POPEVENT TOOBJ)))) @@ -1448,7 +1462,8 @@ (CL:IF BPD (\TEDIT.POPEVENT TOOBJ])]) (\TEDIT.COPY - [LAMBDA (FROMSEL TOSEL FROMTSTREAM TOTSTREAM) (* ; "Edited 7-May-2025 00:12 by rmk") + [LAMBDA (FROMSEL TOSEL FROMTSTREAM TOTSTREAM) (* ; "Edited 31-Jan-2026 11:48 by rmk") + (* ; "Edited 7-May-2025 00:12 by rmk") (* ; "Edited 22-Apr-2025 09:12 by rmk") (* ; "Edited 6-Apr-2025 14:16 by rmk") (* ; "Edited 5-Apr-2025 13:19 by rmk") @@ -1497,8 +1512,7 @@ (* ;; "") (CL:WHEN (GETTEXTPROP TOOBJ 'COPYBYBKSYSBUF) - (\TEDIT.FOREIGN.COPY (WFROMDS TOTSTREAM) - FROMSEL T) + (\TEDIT.FOREIGN.COPY FROMSEL FROMTSTREAM T) (RETURN)) (* ;; "") @@ -2331,27 +2345,27 @@ (DEFAULT.IMAGETYPE.CONVERSIONS '(TEDIT TEDIT.TO.IMAGEFILE)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4840 7234 (MAKE-TEDIT-EXPORTS.ALL 4850 . 5396) (UPDATE-TEDIT 5398 . 6327) (EDIT-TEDIT -6329 . 7232)) (8664 36442 (TEDIT 8674 . 11288) (TEXTSTREAM 11290 . 13179) (TEXTSTREAMP 13181 . 13565) -(COERCETEXTSTREAM 13567 . 17778) (TEDIT.CONCAT 17780 . 21082) (TEDITSTRING 21084 . 21998) (TEDIT-SEE -22000 . 22684) (TEDIT.COPY 22686 . 24831) (TEDIT.DELETE 24833 . 26194) (TEDIT.INSERT 26196 . 29165) ( -TEDIT.TERPRI 29167 . 30281) (TEDIT.KILL 30283 . 31265) (TEDIT.QUIT 31267 . 32633) (TEDIT.MOVE 32635 . -33523) (TEDIT.STRINGWIDTH 33525 . 34196) (TEDIT.CHARWIDTH 34198 . 36440)) (36443 38384 (TEXTOBJ 36453 - . 36918) (COERCETEXTOBJ 36920 . 38382)) (39784 41434 (TDRIBBLE 39794 . 41432)) (41475 53371 ( -TEDIT.INSERT.OBJECT 41485 . 45192) (TEDIT.EDIT.OBJECT 45194 . 48134) (TEDIT.OBJECT.CHANGED 48136 . -51326) (TEDIT.MAP.OBJECTS 51328 . 52899) (\TEDIT.FIRST.OBJPIECE 52901 . 53134) (\TEDIT.NEXT.OBJPIECE -53136 . 53369)) (53394 60837 (\TEDIT.CONCAT.PAGEFRAMES 53404 . 58471) (\TEDIT.GET.PAGE.HEADINGS 58473 - . 59502) (\TEDIT.CONCAT.INSTALL.HEADINGS 59504 . 60835)) (60838 64445 (\TEDIT.MOVE.MSG 60848 . 62929) - (\TEDIT.READONLY 62931 . 64443)) (64446 70337 (TEDIT.NCHARS 64456 . 64829) (TEDIT.RPLCHARCODE 64831 - . 67821) (TEDIT.NTHCHARCODE 67823 . 69866) (TEDIT.NTHCHAR 69868 . 70335)) (70383 127160 (\TEDIT1 -70393 . 72470) (\TEDIT.INSERT 72472 . 78585) (\TEDIT.MOVE 78587 . 86493) (\TEDIT.COPY 86495 . 91026) ( -\TEDIT.REPLACE.SELPIECES 91028 . 95564) (\TEDIT.INSERT.SELPIECES 95566 . 98563) (\TEDIT.RESTARTFN -98565 . 101070) (\TEDIT.CHARDELETE 101072 . 104001) (\TEDIT.COPYPIECE 104003 . 109165) ( -\TEDIT.APPLY.OBJFN 109167 . 112253) (\TEDIT.DELETE 112255 . 116623) (\TEDIT.DIFFUSE.PARALOOKS 116625 - . 118896) (\TEDIT.WORDDELETE 118898 . 120513) (\TEDIT.WORDDELETE.FORWARD 120515 . 122304) ( -\TEDIT.FINISHEDIT? 122306 . 127158)) (127161 127820 (\TEDIT.THELP 127171 . 127818)) (127854 136985 ( -\TEDIT.PARAPIECES 127864 . 129838) (\TEDIT.PARACHNOS 129840 . 130732) (\TEDIT.PARA.FIRST 130734 . -133835) (\TEDIT.PARA.LAST 133837 . 136983)) (136986 144081 (\TEDIT.WORD.FIRST 136996 . 141000) ( -\TEDIT.WORD.LAST 141002 . 144079)) (144282 144559 (TEDITSYSTEMDATE 144292 . 144557)) (144695 144902 ( -TEDIT.IMAGESOURCEP 144705 . 144900))))) + (FILEMAP (NIL (4738 7132 (MAKE-TEDIT-EXPORTS.ALL 4748 . 5294) (UPDATE-TEDIT 5296 . 6225) (EDIT-TEDIT +6227 . 7130)) (8487 37486 (TEDIT 8497 . 11111) (TEXTSTREAM 11113 . 13002) (TEXTSTREAMP 13004 . 13388) +(COERCETEXTSTREAM 13390 . 17601) (TEDIT.CONCAT 17603 . 20905) (TEDITSTRING 20907 . 21821) (TEDIT-SEE +21823 . 22507) (TEDIT.COPY 22509 . 24654) (TEDIT.DELETE 24656 . 26017) (TEDIT.INSERT 26019 . 28988) ( +TEDIT.TERPRI 28990 . 30104) (TEDIT.KILL 30106 . 31088) (TEDIT.QUIT 31090 . 32456) (TEDIT.MOVE 32458 . +33346) (TEDIT.STRINGWIDTH 33348 . 34019) (TEDIT.CHARWIDTH 34021 . 36263) (TEDIT.PARAGRAPH.BOUNDARIES +36265 . 37484)) (37487 39428 (TEXTOBJ 37497 . 37962) (COERCETEXTOBJ 37964 . 39426)) (40828 42478 ( +TDRIBBLE 40838 . 42476)) (42519 54499 (TEDIT.INSERT.OBJECT 42529 . 46236) (TEDIT.EDIT.OBJECT 46238 . +49178) (TEDIT.OBJECT.CHANGED 49180 . 52370) (TEDIT.MAP.OBJECTS 52372 . 54027) (\TEDIT.FIRST.OBJPIECE +54029 . 54262) (\TEDIT.NEXT.OBJPIECE 54264 . 54497)) (54522 61965 (\TEDIT.CONCAT.PAGEFRAMES 54532 . +59599) (\TEDIT.GET.PAGE.HEADINGS 59601 . 60630) (\TEDIT.CONCAT.INSTALL.HEADINGS 60632 . 61963)) (61966 + 65573 (\TEDIT.MOVE.MSG 61976 . 64057) (\TEDIT.READONLY 64059 . 65571)) (65574 71465 (TEDIT.NCHARS +65584 . 65957) (TEDIT.RPLCHARCODE 65959 . 68949) (TEDIT.NTHCHARCODE 68951 . 70994) (TEDIT.NTHCHAR +70996 . 71463)) (71511 128555 (\TEDIT1 71521 . 73598) (\TEDIT.INSERT 73600 . 79713) (\TEDIT.MOVE 79715 + . 87813) (\TEDIT.COPY 87815 . 92421) (\TEDIT.REPLACE.SELPIECES 92423 . 96959) ( +\TEDIT.INSERT.SELPIECES 96961 . 99958) (\TEDIT.RESTARTFN 99960 . 102465) (\TEDIT.CHARDELETE 102467 . +105396) (\TEDIT.COPYPIECE 105398 . 110560) (\TEDIT.APPLY.OBJFN 110562 . 113648) (\TEDIT.DELETE 113650 + . 118018) (\TEDIT.DIFFUSE.PARALOOKS 118020 . 120291) (\TEDIT.WORDDELETE 120293 . 121908) ( +\TEDIT.WORDDELETE.FORWARD 121910 . 123699) (\TEDIT.FINISHEDIT? 123701 . 128553)) (128556 129215 ( +\TEDIT.THELP 128566 . 129213)) (129249 138380 (\TEDIT.PARAPIECES 129259 . 131233) (\TEDIT.PARACHNOS +131235 . 132127) (\TEDIT.PARA.FIRST 132129 . 135230) (\TEDIT.PARA.LAST 135232 . 138378)) (138381 +145476 (\TEDIT.WORD.FIRST 138391 . 142395) (\TEDIT.WORD.LAST 142397 . 145474)) (145677 145954 ( +TEDITSYSTEMDATE 145687 . 145952)) (146090 146297 (TEDIT.IMAGESOURCEP 146100 . 146295))))) STOP diff --git a/library/tedit/TEDIT-ABBREV b/library/tedit/TEDIT-ABBREV index 5f3a3cc3..6c874eea 100644 --- a/library/tedit/TEDIT-ABBREV +++ b/library/tedit/TEDIT-ABBREV @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "13-Jan-2026 17:51:55" {WMEDLEY}tedit>TEDIT-ABBREV.;55 18063 +(FILECREATED "23-Jan-2026 15:49:26" {WMEDLEY}TEDIT>TEDIT-ABBREV.;58 18256 :EDIT-BY rmk :CHANGES-TO (FNS \TEDIT.ABBREV.EXPAND) - (VARS TEDIT-ABBREVCOMS) - :PREVIOUS-DATE " 8-Jan-2026 09:09:58" {WMEDLEY}tedit>TEDIT-ABBREV.;53) + :PREVIOUS-DATE "13-Jan-2026 17:51:55" {WMEDLEY}tedit>TEDIT-ABBREV.;55) (PRETTYCOMPRINT TEDIT-ABBREVCOMS) @@ -87,7 +86,9 @@ (DEFINEQ (\TEDIT.ABBREV.EXPAND - [LAMBDA (TSTREAM TEXTOBJ SEL) (* ; "Edited 13-Jan-2026 17:51 by rmk") + [LAMBDA (TSTREAM TEXTOBJ SEL) (* ; "Edited 23-Jan-2026 15:49 by rmk") + (* ; "Edited 20-Jan-2026 09:56 by rmk") + (* ; "Edited 13-Jan-2026 17:51 by rmk") (* ; "Edited 8-Jan-2026 09:08 by rmk") (* ; "Edited 3-Jan-2026 13:13 by rmk") (* ; "Edited 20-Apr-2025 23:30 by rmk") @@ -143,11 +144,11 @@ (\TEDIT.REPLACE.SELPIECES (\TEDIT.SELPIECES.FROM.STRING EXPANSION TEXTOBJ NIL (PCHARLOOKS (\TEDIT.CHTOPC FIRSTCHNO TEXTOBJ))) TSTREAM SEL) - (TEDIT.PROMPTPRINT TSTREAM (CONCAT "Replaced " (CL:IF BACKSLASH - (CONCAT (CAR ABBREV) - "\") - (CAR ABBREV)) - " with " EXPANSION) + (TEDIT.PROMPTPRINT TSTREAM (CONCAT "Replaced %"" (CL:IF BACKSLASH + (CONCAT (CAR ABBREV) + "\") + (CAR ABBREV)) + "%" with %"" EXPANSION "%"") T) else (TEDIT.PROMPTPRINT TSTREAM "No abbreviation to expand" T]) @@ -362,7 +363,7 @@ ("DATE" \TEDIT.EXPAND.DATE) (">>DATE<<" \TEDIT.EXPAND.DATE))) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4390 14959 (\TEDIT.ABBREV.EXPAND 4400 . 8930) (\TEDIT.ABBREV.EXPANSION 8932 . 11996) ( -\TEDIT.ABBREV.TREE 11998 . 13129) (\TEDIT.ABBREV.PARSE 13131 . 14283) (\TEDIT.ABBREV.PARSE.CHARCODE -14285 . 14957)) (14960 15605 (\TEDIT.EXPAND.DATE 14970 . 15603))))) + (FILEMAP (NIL (4348 15152 (\TEDIT.ABBREV.EXPAND 4358 . 9123) (\TEDIT.ABBREV.EXPANSION 9125 . 12189) ( +\TEDIT.ABBREV.TREE 12191 . 13322) (\TEDIT.ABBREV.PARSE 13324 . 14476) (\TEDIT.ABBREV.PARSE.CHARCODE +14478 . 15150)) (15153 15798 (\TEDIT.EXPAND.DATE 15163 . 15796))))) STOP diff --git a/library/tedit/TEDIT-ABBREV.LCOM b/library/tedit/TEDIT-ABBREV.LCOM index 5cf09f86..0d3e936e 100644 Binary files a/library/tedit/TEDIT-ABBREV.LCOM and b/library/tedit/TEDIT-ABBREV.LCOM differ diff --git a/library/tedit/TEDIT-BUTTONS b/library/tedit/TEDIT-BUTTONS index f015ff00..bb2ccdbe 100644 --- a/library/tedit/TEDIT-BUTTONS +++ b/library/tedit/TEDIT-BUTTONS @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Oct-2025 10:44:18" {WMEDLEY}TEDIT>TEDIT-BUTTONS.;229 125526 +(FILECREATED "25-Jan-2026 09:14:04" {WMEDLEY}TEDIT>TEDIT-BUTTONS.;230 123301 :EDIT-BY rmk - :CHANGES-TO (FNS MB.ADD) + :CHANGES-TO (VARS TEDIT-BUTTONSCOMS) - :PREVIOUS-DATE "30-Apr-2025 14:09:18" {WMEDLEY}TEDIT>TEDIT-BUTTONS.;228) + :PREVIOUS-DATE "19-Oct-2025 10:44:18" {WMEDLEY}TEDIT>TEDIT-BUTTONS.;229) (PRETTYCOMPRINT TEDIT-BUTTONSCOMS) @@ -36,10 +36,9 @@ (* ;; "Mutually exclusive togggles with a single enclosing object") - (FNS MB.NWAY.CREATE MB.NWAY.DISPLAYFN MB.NWAY.WHENOPERATEDONFN MB.NWAY.SIZEFN - MB.NWAY.SELECT MB.NWAY.BUTTONEVENTINFN MB.NWAY.NEWMENUBUTTON MB.NWAY.COPYFN - MB.NWAY.INIT MB.NWAY.ARRANGEBUTTONS MB.NWAY.ADDITEM MB.NWAY.FINDSUBOBJ - MB.NWAY.SETSTATEFN) + (FNS MB.NWAY.CREATE MB.NWAY.DISPLAYFN MB.NWAY.SIZEFN MB.NWAY.SELECT + MB.NWAY.BUTTONEVENTINFN MB.NWAY.NEWMENUBUTTON MB.NWAY.COPYFN MB.NWAY.INIT + MB.NWAY.ARRANGEBUTTONS MB.NWAY.ADDITEM MB.NWAY.FINDSUBOBJ MB.NWAY.SETSTATEFN) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MB.NWAY.INIT] [COMS (* ; "TOGGLE") (FNS MB.TOGGLE.CREATE MB.TOGGLE.DISPLAYFN MB.TOGGLE.INIT MB.SET.TOGGLE @@ -922,39 +921,6 @@ (APPLY* (IMAGEOBJPROP SOBJ 'DISPLAYFN) SOBJ STREAM]) -(MB.NWAY.WHENOPERATEDONFN - [LAMBDA (OBJ PANE OPERATION SEL) (* ; "Edited 21-Oct-2024 00:26 by rmk") - (* ; "Edited 24-Aug-2024 23:38 by rmk") - (* ; "Edited 13-Aug-2024 23:43 by rmk") - (* ; "Edited 2-Aug-2024 00:36 by rmk") - (* ; "Edited 21-Jul-2024 13:17 by rmk") - (* ; "Edited 17-Jul-2024 21:51 by rmk") - (* ; "Edited 9-Apr-2023 15:57 by rmk") - (* ; "Edited 13-Sep-2022 12:09 by rmk") - (* ; "Edited 30-May-91 22:16 by jds") - - (* ;; "Perhaps the selected subobject should be stored here, as the state?") - - (* ;; "Mouse tracking and highlighting happens in the BUTTONEVENTINFN (MB.NWAYBUTTON.SELFN). The code here applies the STATECHANGEFN on the main object") - - (NOTUSED) - (SELECTQ OPERATION - (SELECTED [AND NIL (\TEDIT.THELP) - (LET [(SELECTED (IMAGEOBJPROP OBJ 'SELECTED] - (if (IMAGEOBJPROP OBJ 'STATECHANGEFN) - then (\TEDIT.THELP) - (APPLY* (IMAGEOBJPROP OBJ 'STATECHANGEFN) - OBJ SELECTED SEL PANE) - elseif (AND NIL SELECTED (IMAGEOBJPROP SELECTED 'STATECHANGEFN)) - then - (* ;; - "This is nuked out: the selected object may be should have done its own thing?") - - (APPLY* (IMAGEOBJPROP SELECTED 'STATECHANGEFN) - OBJ SELECTED SEL PANE]) - ((HIGHLIGHTED UNHIGHLIGHTED DESELECTED)) - NIL]) - (MB.NWAY.SIZEFN [LAMBDA (OBJ STREAM CURX RIGHTMARGIN) (* ; "Edited 20-Aug-2024 15:12 by rmk") (* ; "Edited 22-Jul-2024 11:31 by rmk") @@ -1971,25 +1937,25 @@ (MB.FIELD.INIT) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3221 19357 (MB.ADD 3231 . 9943) (MB.DELETE 9945 . 10319) (MB.GET 10321 . 17091) ( -MB.GET.MBARG 17093 . 18762) (TEDIT.BACKTOMAIN 18764 . 19355)) (19401 39337 (MB.BUTTONEVENTINFN 19411 - . 20979) (MB.DISPLAYFN 20981 . 23040) (MB.SETIMAGE 23042 . 24210) (MB.SIZEFN 24212 . 25760) ( -MB.WHENOPERATEDONFN 25762 . 27711) (MB.COPYFN 27713 . 28171) (MB.GETFN 28173 . 29134) (MB.PUTFN 29136 - . 30236) (MB.SHOWSELFN 30238 . 31747) (MB.CREATE 31749 . 35772) (MB.CHANGENAME 35774 . 36256) ( -MB.INIT 36258 . 37719) (MB.TRACK.UNTIL 37721 . 38416) (MB.DON'T 38418 . 38714) (MB.SPEC.REMAINDER -38716 . 39335)) (39499 49504 (MB.3STATE.CREATE 39509 . 40373) (MB.3STATE.DISPLAYFN 40375 . 41361) ( -MB.3STATE.SHOWSELFN 41363 . 43674) (MB.3STATE.INIT 43676 . 45087) (MB.3STATE.SETSTATEFN 45089 . 45747) - (MB.3STATE.BUTTONEVENTINFN 45749 . 49502)) (49659 80755 (MB.NWAY.CREATE 49669 . 55852) ( -MB.NWAY.DISPLAYFN 55854 . 56717) (MB.NWAY.WHENOPERATEDONFN 56719 . 58909) (MB.NWAY.SIZEFN 58911 . -62847) (MB.NWAY.SELECT 62849 . 66419) (MB.NWAY.BUTTONEVENTINFN 66421 . 69633) (MB.NWAY.NEWMENUBUTTON -69635 . 70347) (MB.NWAY.COPYFN 70349 . 71316) (MB.NWAY.INIT 71318 . 72809) (MB.NWAY.ARRANGEBUTTONS -72811 . 74782) (MB.NWAY.ADDITEM 74784 . 78933) (MB.NWAY.FINDSUBOBJ 78935 . 79449) (MB.NWAY.SETSTATEFN -79451 . 80753)) (80834 92833 (MB.TOGGLE.CREATE 80844 . 81839) (MB.TOGGLE.DISPLAYFN 81841 . 83324) ( -MB.TOGGLE.INIT 83326 . 85125) (MB.SET.TOGGLE 85127 . 86328) (MB.TOGGLE.SETSTATEFN 86330 . 87170) ( -MB.TOGGLE.BUTTONEVENTINFN 87172 . 91488) (MB.TOGGLE.WHENOPERATEDONFN 91490 . 92831)) (92914 125447 ( -MB.FIELD.CREATE 92924 . 98375) (MB.FIELD.DISPLAYFN 98377 . 99168) (MB.FIELD.IMAGEBOXFN 99170 . 100652) - (MB.FIELD.PREFIXCREATE 100654 . 104590) (MB.FIELD.SUFFIXCREATE 104592 . 106252) (MB.FIELD.INIT 106254 - . 108021) (MB.FIELD.WHENOPERATEDONFN 108023 . 109294) (MB.FIELD.GETSTATEFN 109296 . 113230) ( -MB.FIELD.SETSTATEFN 113232 . 118036) (MB.FIELD.BUTTONEVENTINFN 118038 . 120343) (MB.FIELD.SIZEFN -120345 . 120585) (MB.FIELD.INSURETYPE 120587 . 125445))))) + (FILEMAP (NIL (3188 19324 (MB.ADD 3198 . 9910) (MB.DELETE 9912 . 10286) (MB.GET 10288 . 17058) ( +MB.GET.MBARG 17060 . 18729) (TEDIT.BACKTOMAIN 18731 . 19322)) (19368 39304 (MB.BUTTONEVENTINFN 19378 + . 20946) (MB.DISPLAYFN 20948 . 23007) (MB.SETIMAGE 23009 . 24177) (MB.SIZEFN 24179 . 25727) ( +MB.WHENOPERATEDONFN 25729 . 27678) (MB.COPYFN 27680 . 28138) (MB.GETFN 28140 . 29101) (MB.PUTFN 29103 + . 30203) (MB.SHOWSELFN 30205 . 31714) (MB.CREATE 31716 . 35739) (MB.CHANGENAME 35741 . 36223) ( +MB.INIT 36225 . 37686) (MB.TRACK.UNTIL 37688 . 38383) (MB.DON'T 38385 . 38681) (MB.SPEC.REMAINDER +38683 . 39302)) (39466 49471 (MB.3STATE.CREATE 39476 . 40340) (MB.3STATE.DISPLAYFN 40342 . 41328) ( +MB.3STATE.SHOWSELFN 41330 . 43641) (MB.3STATE.INIT 43643 . 45054) (MB.3STATE.SETSTATEFN 45056 . 45714) + (MB.3STATE.BUTTONEVENTINFN 45716 . 49469)) (49626 78530 (MB.NWAY.CREATE 49636 . 55819) ( +MB.NWAY.DISPLAYFN 55821 . 56684) (MB.NWAY.SIZEFN 56686 . 60622) (MB.NWAY.SELECT 60624 . 64194) ( +MB.NWAY.BUTTONEVENTINFN 64196 . 67408) (MB.NWAY.NEWMENUBUTTON 67410 . 68122) (MB.NWAY.COPYFN 68124 . +69091) (MB.NWAY.INIT 69093 . 70584) (MB.NWAY.ARRANGEBUTTONS 70586 . 72557) (MB.NWAY.ADDITEM 72559 . +76708) (MB.NWAY.FINDSUBOBJ 76710 . 77224) (MB.NWAY.SETSTATEFN 77226 . 78528)) (78609 90608 ( +MB.TOGGLE.CREATE 78619 . 79614) (MB.TOGGLE.DISPLAYFN 79616 . 81099) (MB.TOGGLE.INIT 81101 . 82900) ( +MB.SET.TOGGLE 82902 . 84103) (MB.TOGGLE.SETSTATEFN 84105 . 84945) (MB.TOGGLE.BUTTONEVENTINFN 84947 . +89263) (MB.TOGGLE.WHENOPERATEDONFN 89265 . 90606)) (90689 123222 (MB.FIELD.CREATE 90699 . 96150) ( +MB.FIELD.DISPLAYFN 96152 . 96943) (MB.FIELD.IMAGEBOXFN 96945 . 98427) (MB.FIELD.PREFIXCREATE 98429 . +102365) (MB.FIELD.SUFFIXCREATE 102367 . 104027) (MB.FIELD.INIT 104029 . 105796) ( +MB.FIELD.WHENOPERATEDONFN 105798 . 107069) (MB.FIELD.GETSTATEFN 107071 . 111005) (MB.FIELD.SETSTATEFN +111007 . 115811) (MB.FIELD.BUTTONEVENTINFN 115813 . 118118) (MB.FIELD.SIZEFN 118120 . 118360) ( +MB.FIELD.INSURETYPE 118362 . 123220))))) STOP diff --git a/library/tedit/TEDIT-BUTTONS.LCOM b/library/tedit/TEDIT-BUTTONS.LCOM index 5fd32581..ae82ac19 100644 Binary files a/library/tedit/TEDIT-BUTTONS.LCOM and b/library/tedit/TEDIT-BUTTONS.LCOM differ diff --git a/library/tedit/TEDIT-FILE b/library/tedit/TEDIT-FILE index b529ddc8..f0c0f19b 100644 --- a/library/tedit/TEDIT-FILE +++ b/library/tedit/TEDIT-FILE @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "23-Oct-2025 08:49:06" {WMEDLEY}tedit>TEDIT-FILE.;656 173140 +(FILECREATED "15-Feb-2026 23:45:51" {WMEDLEY}tedit>TEDIT-FILE.;666 175062 :EDIT-BY rmk - :CHANGES-TO (FNS \TEDIT.GET.UNFORMATTED.FILE.UTF8) + :CHANGES-TO (FNS \TEDIT.PUT.MCCS.SPLITPIECES \TEDIT.PUT.PCTB.NEXTNEW) + (VARS TEDIT-FILECOMS) - :PREVIOUS-DATE "25-Sep-2025 21:32:46" {WMEDLEY}tedit>TEDIT-FILE.;655) + :PREVIOUS-DATE "14-Feb-2026 10:32:44" {WMEDLEY}tedit>TEDIT-FILE.;659) (PRETTYCOMPRINT TEDIT-FILECOMS) @@ -50,8 +51,9 @@ (* ;; "Putting pageframe functions are on TEDIT-PAGE)") (FNS \TEDIT.PUT.PCTB \TEDIT.PUT.PCTB.PIECEDATA \TEDIT.PUT.TRAILER - \TEDIT.PUT.PCTB.MERGEABLE \TEDIT.PUT.UTF8.SPLITPIECES \TEDIT.PUT.PCTB.NEXTNEW - \TEDIT.INSERT.NEWPIECES \TEDIT.PUTRESET \ARBOUT \ATMOUT \DWOUT \STRINGOUT) + \TEDIT.PUT.PCTB.MERGEABLE \TEDIT.PUT.UTF8.SPLITPIECES \TEDIT.PUT.MCCS.SPLITPIECES + \TEDIT.PUT.PCTB.NEXTNEW \TEDIT.INSERT.NEWPIECES \TEDIT.PUTRESET \ARBOUT \ATMOUT + \DWOUT \STRINGOUT) (FNS \TEDIT.PUT.CHARLOOKS.LIST \TEDIT.PUT.SINGLE.CHARLOOKS \TEDIT.PUT.CHARLOOKS \TEDIT.PUT.CHARLOOKS1 \TEDIT.PUT.OBJECT) (FNS \TEDIT.PUT.PARALOOKS.LIST \TEDIT.PUT.SINGLE.PARALOOKS \TEDIT.PUT.PARALOOKS)) @@ -1830,6 +1832,7 @@ (\TEDIT.PUT.PCTB [LAMBDA (TEXTOBJ CHARSTREAM FORMATSTREAM CONTINUE KEEPSEPARATE) + (* ; "Edited 14-Feb-2026 10:32 by rmk") (* ; "Edited 9-Sep-2025 21:32 by rmk") (* ; "Edited 26-Apr-2025 00:11 by rmk") (* ; "Edited 21-Oct-2024 00:33 by rmk") @@ -1922,10 +1925,10 @@ (* ;; "For MCCS, CHARSET will put out the char-shifting prefix bytes as needed. In format-version 3 all the file bytes belong to a piece, no skipping in the file. TEDIT.GET calls \TEDIT.INTERPRET.XCCS.SHIFTS to shave those bytes. NSHIFTBYTES is used here if the edit will continue.") - (CHARSET CHARSTREAM (CL:IF (MEMB (PTYPE PC) - FAT.PTYPES) - T - 0)) + (CHARSET CHARSTREAM (OR (AND (EQ EXTFORMAT :XCCS) + (MEMB (PTYPE PC) + FAT.PTYPES)) + (PCHARSET PC))) (SETQ NSHIFTBYTES (IDIFFERENCE (\GETFILEPTR CHARSTREAM) OLDBYTE#))) (do (\TEDIT.PUT.PCTB.PIECEDATA PC CHARSTREAM TEXTOBJ FORMATSTREAM OLDBYTE#) @@ -2152,8 +2155,35 @@ (RETURN)))) NIL]) +(\TEDIT.PUT.MCCS.SPLITPIECES + [LAMBDA (TEXTOBJ) (* ; "Edited 15-Feb-2026 23:45 by rmk") + + (* ;; "We are putting to a :MCCS format file, and MCCS doesn't support single-byte runs of non-charset 0 characters. This function splits fat pieces into subpieces with only charset-0 characters or no charset-0 characters. The former will be put out as THINFILE pieces, the latter as FATFILE2.") + + (for PC FIRST0 FIRSTNON0 inpieces (\TEDIT.FIRSTPIECE TEXTOBJ) + when [AND (MEMB (PTYPE PC) + (CONSTANT (LIST FATSTRING.PTYPE FATFILE2.PTYPE UTF8.PTYPE))) + (SETQ FIRST0 (find I from 0 to (PLAST PC) + suchthat (EQ 0 (\CHARSET (\TEDIT.PIECE.NTHCHARCODE PC I] + do (if [SETQ FIRSTNON0 (find I from (ADD1 FIRST0) to (PLAST PC) + suchthat (NEQ 0 (\CHARSET (\TEDIT.PIECE.NTHCHARCODE PC I] + then + (* ;; "xxx000yyy --> xxx 000yyy or 000yyy --> 000 yyy") + + (\TEDIT.SPLITPIECE PC (CL:IF (EQ FIRST0 0) + FIRSTNON0 + FIRST0) + TEXTOBJ) (* ; "Iterate to the residual piece") + (SETQ PC (PREVPIECE PC)) + elseif (NEQ 0 FIRST0) + then + (* ;; "xxx000") + + (\TEDIT.SPLITPIECE PC FIRST0 TEXTOBJ]) + (\TEDIT.PUT.PCTB.NEXTNEW [LAMBDA (NEXTNEW PC OLDBYTE# RUNLEN EXTFORMAT TEXTOBJ EOLC NSHIFTBYTES) + (* ; "Edited 15-Feb-2026 15:09 by rmk") (* ; "Edited 25-Apr-2025 08:48 by rmk") (* ; "Edited 26-Mar-2025 09:27 by rmk") (* ; "Edited 21-Oct-2024 00:26 by rmk") @@ -2202,7 +2232,7 @@  "The file may have LF, but we want to restore EOL internally") (CL:WHEN [AND (EQ THINFILE.PTYPE (PTYPE NEXTNEW)) (EQ (CHARCODE EOL) - (\TEDIT.PIECE.NTHCHARCODE PC (PLEN PC] + (\TEDIT.PIECE.NTHCHARCODE PC (PLAST PC] (if (EQ 1 (PLEN NEXTNEW)) then (FSETPC NEXTNEW PTYPE THINSTRING.PTYPE) (FSETPC NEXTNEW PCONTENTS (ALLOCSTRING 1 (CHARCODE EOL))) @@ -2625,7 +2655,8 @@ (DEFINEQ (TEDITFROMLISPSOURCE - [LAMBDA (SOURCEFILE TSTREAM PROPS USERTEMP START END) (* ; "Edited 7-Apr-2025 23:13 by rmk") + [LAMBDA (SOURCEFILE TSTREAM PROPS USERTEMP START END) (* ; "Edited 7-Feb-2026 17:02 by rmk") + (* ; "Edited 7-Apr-2025 23:13 by rmk") (* ; "Edited 1-Apr-2025 12:54 by rmk") (* ; "Edited 26-Mar-2025 10:02 by rmk") (* ; "Edited 18-Feb-2025 23:34 by rmk") @@ -2658,9 +2689,6 @@ ,(TEDIT.ATOMBOUND.READTABLE (fetch (READER-ENVIRONMENT REREADTABLE) of USERTEMP)) DEFAULTPUTEXTENSION "")) - (TEDIT.PROMPTPRINT TSTREAM (CONCAT "Fetching " (FULLNAME SOURCEFILE) - " ...") - T) (COPY.TEXT.TO.IMAGE SOURCEFILE TSTREAM) TSTREAM]) @@ -2693,28 +2721,29 @@ (RPAQ? *TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (5317 35576 (TEDIT.GET 5327 . 11737) (TEDIT.FORMATTEDFILEP 11739 . 13055) ( -TEDIT.FILEDATE 13057 . 14366) (TEDIT.INCLUDE 14368 . 22397) (TEDIT.RAW.INCLUDE 22399 . 23207) ( -TEDIT.PUT 23209 . 31565) (TEDIT.PUT.STREAM 31567 . 35574)) (35577 56851 (\TEDIT.GET.FOREIGN.FILE 35587 - . 39012) (\TEDIT.GET.UNFORMATTED.FILE 39014 . 43320) (\TEDIT.GET.FORMATTED.FILE 43322 . 46965) ( -\TEDIT.FORMATTEDSTREAMP 46967 . 50098) (\ARBIN 50100 . 50820) (\ATMIN 50822 . 51359) (\DWIN 51361 . -51740) (\STRINGIN 51742 . 52450) (\TEDIT.GET.TRAILER 52452 . 55320) (\TEDIT.CACHEFILE 55322 . 56849)) -(57017 73055 (\TEDIT.GET.PIECES3 57027 . 67990) (\TEDIT.GET.PROPS3 67992 . 71214) ( -\TEDIT.MAKE.STRINGPIECE 71216 . 73053)) (73056 86482 (\TEDIT.GET.UNFORMATTED.FILE.MCCS 73066 . 79299) -(\TEDIT.INTERPRET.MCCS.SHIFTS 79301 . 85546) (\TEDIT.CONVERT.XCCSTOMCCS 85548 . 86480)) (86504 92749 ( -\TEDIT.GET.UNFORMATTED.FILE.UTF8 86514 . 92747)) (92772 104114 (\TEDIT.GET.CHARLOOKS.LIST 92782 . -93513) (\TEDIT.GET.SINGLE.CHARLOOKS 93515 . 100587) (\TEDIT.GET.CHARLOOKS 100589 . 102145) ( -\TEDIT.GET.PARALOOKS.INDEX 102147 . 102691) (\TEDIT.GET.CHARLOOKS.INDEX 102693 . 104112)) (104115 -111772 (\TEDIT.GET.PARALOOKS.LIST 104125 . 104747) (\TEDIT.GET.SINGLE.PARALOOKS 104749 . 111770)) ( -111773 115606 (\TEDIT.GET.OBJECT 111783 . 115604)) (115671 148934 (\TEDIT.PUT.PCTB 115681 . 125588) ( -\TEDIT.PUT.PCTB.PIECEDATA 125590 . 128788) (\TEDIT.PUT.TRAILER 128790 . 130118) ( -\TEDIT.PUT.PCTB.MERGEABLE 130120 . 133893) (\TEDIT.PUT.UTF8.SPLITPIECES 133895 . 138597) ( -\TEDIT.PUT.PCTB.NEXTNEW 138599 . 143095) (\TEDIT.INSERT.NEWPIECES 143097 . 146532) (\TEDIT.PUTRESET -146534 . 146776) (\ARBOUT 146778 . 147502) (\ATMOUT 147504 . 148109) (\DWOUT 148111 . 148390) ( -\STRINGOUT 148392 . 148932)) (148935 161669 (\TEDIT.PUT.CHARLOOKS.LIST 148945 . 150617) ( -\TEDIT.PUT.SINGLE.CHARLOOKS 150619 . 156899) (\TEDIT.PUT.CHARLOOKS 156901 . 158240) ( -\TEDIT.PUT.CHARLOOKS1 158242 . 159293) (\TEDIT.PUT.OBJECT 159295 . 161667)) (161670 169309 ( -\TEDIT.PUT.PARALOOKS.LIST 161680 . 162582) (\TEDIT.PUT.SINGLE.PARALOOKS 162584 . 168168) ( -\TEDIT.PUT.PARALOOKS 168170 . 169307)) (169404 172833 (TEDITFROMLISPSOURCE 169414 . 172082) ( -SHELLSCRIPTP 172084 . 172313) (TEDITFROMSHELLSCRIPT 172315 . 172831))))) + (FILEMAP (NIL (5423 35682 (TEDIT.GET 5433 . 11843) (TEDIT.FORMATTEDFILEP 11845 . 13161) ( +TEDIT.FILEDATE 13163 . 14472) (TEDIT.INCLUDE 14474 . 22503) (TEDIT.RAW.INCLUDE 22505 . 23313) ( +TEDIT.PUT 23315 . 31671) (TEDIT.PUT.STREAM 31673 . 35680)) (35683 56957 (\TEDIT.GET.FOREIGN.FILE 35693 + . 39118) (\TEDIT.GET.UNFORMATTED.FILE 39120 . 43426) (\TEDIT.GET.FORMATTED.FILE 43428 . 47071) ( +\TEDIT.FORMATTEDSTREAMP 47073 . 50204) (\ARBIN 50206 . 50926) (\ATMIN 50928 . 51465) (\DWIN 51467 . +51846) (\STRINGIN 51848 . 52556) (\TEDIT.GET.TRAILER 52558 . 55426) (\TEDIT.CACHEFILE 55428 . 56955)) +(57123 73161 (\TEDIT.GET.PIECES3 57133 . 68096) (\TEDIT.GET.PROPS3 68098 . 71320) ( +\TEDIT.MAKE.STRINGPIECE 71322 . 73159)) (73162 86588 (\TEDIT.GET.UNFORMATTED.FILE.MCCS 73172 . 79405) +(\TEDIT.INTERPRET.MCCS.SHIFTS 79407 . 85652) (\TEDIT.CONVERT.XCCSTOMCCS 85654 . 86586)) (86610 92855 ( +\TEDIT.GET.UNFORMATTED.FILE.UTF8 86620 . 92853)) (92878 104220 (\TEDIT.GET.CHARLOOKS.LIST 92888 . +93619) (\TEDIT.GET.SINGLE.CHARLOOKS 93621 . 100693) (\TEDIT.GET.CHARLOOKS 100695 . 102251) ( +\TEDIT.GET.PARALOOKS.INDEX 102253 . 102797) (\TEDIT.GET.CHARLOOKS.INDEX 102799 . 104218)) (104221 +111878 (\TEDIT.GET.PARALOOKS.LIST 104231 . 104853) (\TEDIT.GET.SINGLE.PARALOOKS 104855 . 111876)) ( +111879 115712 (\TEDIT.GET.OBJECT 111889 . 115710)) (115777 150880 (\TEDIT.PUT.PCTB 115787 . 125844) ( +\TEDIT.PUT.PCTB.PIECEDATA 125846 . 129044) (\TEDIT.PUT.TRAILER 129046 . 130374) ( +\TEDIT.PUT.PCTB.MERGEABLE 130376 . 134149) (\TEDIT.PUT.UTF8.SPLITPIECES 134151 . 138853) ( +\TEDIT.PUT.MCCS.SPLITPIECES 138855 . 140433) (\TEDIT.PUT.PCTB.NEXTNEW 140435 . 145041) ( +\TEDIT.INSERT.NEWPIECES 145043 . 148478) (\TEDIT.PUTRESET 148480 . 148722) (\ARBOUT 148724 . 149448) ( +\ATMOUT 149450 . 150055) (\DWOUT 150057 . 150336) (\STRINGOUT 150338 . 150878)) (150881 163615 ( +\TEDIT.PUT.CHARLOOKS.LIST 150891 . 152563) (\TEDIT.PUT.SINGLE.CHARLOOKS 152565 . 158845) ( +\TEDIT.PUT.CHARLOOKS 158847 . 160186) (\TEDIT.PUT.CHARLOOKS1 160188 . 161239) (\TEDIT.PUT.OBJECT +161241 . 163613)) (163616 171255 (\TEDIT.PUT.PARALOOKS.LIST 163626 . 164528) ( +\TEDIT.PUT.SINGLE.PARALOOKS 164530 . 170114) (\TEDIT.PUT.PARALOOKS 170116 . 171253)) (171350 174755 ( +TEDITFROMLISPSOURCE 171360 . 174004) (SHELLSCRIPTP 174006 . 174235) (TEDITFROMSHELLSCRIPT 174237 . +174753))))) STOP diff --git a/library/tedit/TEDIT-FILE.LCOM b/library/tedit/TEDIT-FILE.LCOM index 6809340d..6e1598c7 100644 Binary files a/library/tedit/TEDIT-FILE.LCOM and b/library/tedit/TEDIT-FILE.LCOM differ diff --git a/library/tedit/TEDIT-FNKEYS b/library/tedit/TEDIT-FNKEYS index 850b43ba..d4a6abf3 100644 --- a/library/tedit/TEDIT-FNKEYS +++ b/library/tedit/TEDIT-FNKEYS @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Nov-2025 08:40:56" {WMEDLEY}TEDIT>TEDIT-FNKEYS.;317 109076 +(FILECREATED " 8-Feb-2026 19:54:41" {WMEDLEY}tedit>TEDIT-FNKEYS.;318 109228 :EDIT-BY rmk - :CHANGES-TO (VARS TEDIT.BASIC.CHARBINDINGS) + :CHANGES-TO (VARS TEDIT.BASIC.CHARBINDINGS ORIG.TEDIT.CHARACTIONS) - :PREVIOUS-DATE "24-Nov-2025 00:38:18" {WMEDLEY}TEDIT>TEDIT-FNKEYS.;316) + :PREVIOUS-DATE "24-Nov-2025 08:40:56" {WMEDLEY}tedit>TEDIT-FNKEYS.;317) (PRETTYCOMPRINT TEDIT-FNKEYSCOMS) @@ -1776,6 +1776,8 @@ (:PRINT.MENU \TEDIT.PRINT.MENU) (:EXPAND \TEDIT.ABBREV.EXPAND) (:GET.OBJECT GET.OBJ.FROM.USER) + (:PAGENUMOBJ (TEDIT.INSERT.OBJECT (TEDIT.PAGENO.CREATE) + TSTREAM)) (:OPENLINE \TEDIT.KEY.OPENLINE) (* ;; "") @@ -1913,6 +1915,7 @@ (:PRINT.MENU "Meta,P" "Meta,p") (:EXPAND "^X") (:GET.OBJECT "^O") + (:PAGENUMOBJ "^P") (* ;; "") @@ -1986,30 +1989,30 @@ (RPAQ TEDIT.WORDBOUND.READTABLE (\TEDIT.WORDBOUND.READTABLE)) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (5031 23296 (TEDIT.INSTALL.CHARBINDINGS 5041 . 7892) (TEDIT.CLEAR.CHARBINDINGS 7894 . -10914) (TEDIT.GET.CHARACTION 10916 . 13697) (TEDIT.GET.CHARBINDING 13699 . 15876) ( -TEDIT.GET.ALL.CHARBINDINGS 15878 . 18377) (TEDIT.CHARBINDINGS.INVERT 18379 . 19658) ( -TEDIT.GET.ALL.CHARACTIONS 19660 . 21982) (TEDIT.CONFLICTING.CHARBINDINGS 21984 . 23294)) (23356 33411 -(\TEDIT.KEY.CHARLOOKS 23366 . 24558) (\TEDIT.KEY.QUAD 24560 . 26653) (\TEDIT.DEFAULTSSEL 26655 . 27266 -) (\TEDIT.SETDEFAULT.FROM.SEL 27268 . 27945) (\TEDIT.KEY.SIZE 27947 . 29143) (\TEDIT.SUBSCRIPTSEL -29145 . 29348) (\TEDIT.SUPERSCRIPTSEL 29350 . 29554) (\TEDIT.KEY.TRANSFORM 29556 . 31553) ( -\TEDIT.KEY.OPENLINE 31555 . 32009) (\TEDIT.KEY.FAMILYN 32011 . 33409)) (33412 33701 (CAP-CASECODE -33422 . 33699)) (33735 37167 (\TEDIT.SHOWCARETLOOKS 33745 . 36260) (\TEDIT.DESCRIBEFONT 36262 . 37165) -) (37198 52171 (\TEDIT.ONECHAR.BACKWARD 37208 . 38355) (\TEDIT.ONECHAR.FORWARD 38357 . 39593) ( -\TEDIT.ONELINE.UP 39595 . 42556) (\TEDIT.ONELINE.DOWN 42558 . 44215) (\TEDIT.ONELINE.MOVE 44217 . -46504) (\TEDIT.ONEWORD.BACKWARD 46506 . 47694) (\TEDIT.ONEWORD.FORWARD 47696 . 48883) ( -\TEDIT.LINE.BEGIN 48885 . 49964) (\TEDIT.LINE.END 49966 . 51203) (\TEDIT.DOCUMENT.BEGIN 51205 . 51564) - (\TEDIT.DOCUMENT.END 51566 . 52169)) (52172 55480 (\TEDIT.LINEDELETE.FORWARD 52182 . 53291) ( -\TEDIT.LINEDELETE.BACKWARD 53293 . 54432) (\TEDIT.LINEDELETE 54434 . 55478)) (55481 58009 ( -\TEDIT.KEY.NEST 55491 . 58007)) (58010 59292 (\TEDIT.KEY.WRAP 58020 . 59290)) (59383 67431 ( -\TEDIT.KEY.FIND 59393 . 64571) (\TEDIT.KEY.FIND.SEARCHSTRING 64573 . 65713) (\TEDIT.GET.TARGET.STRING -65715 . 67429)) (67462 70094 (\TEDIT.KEY.SUBSTITUTE 67472 . 67693) (\TEDIT.MANPAGE 67695 . 68942) ( -\TEDIT.CALL.ED 68944 . 69774) (\TEDIT.SELECT.ALL 69776 . 70092)) (70121 75811 (\TEDIT.CLIPBOARD 70131 - . 71886) (\TEDIT.COPYTOCLIPBOARD 71888 . 72668) (\TEDIT.EXTRACTTOCLIPBOARD 72670 . 72865) ( -\TEDIT.WRITE.SEL 72867 . 75809)) (75977 88484 (\TEDIT.READTABLE 75987 . 76923) ( -\TEDIT.WORDBOUND.READTABLE 76925 . 79973) (TEDIT.GETSYNTAX 79975 . 81204) (TEDIT.SETSYNTAX 81206 . -82520) (TEDIT.GETFUNCTION 82522 . 83995) (TEDIT.SETFUNCTION 83997 . 86153) (TEDIT.WORDGET 86155 . -86416) (TEDIT.WORDSET 86418 . 87158) (TEDIT.ATOMBOUND.READTABLE 87160 . 88482)) (88585 95573 ( -TEDIT.BUTTONS.BUILD 88595 . 93841) (TEDIT.BUTTONBITMAP.FILL 93843 . 95571)) (98038 98626 ( -\TEDIT.TTCCLASS 98048 . 98624))))) + (FILEMAP (NIL (5054 23319 (TEDIT.INSTALL.CHARBINDINGS 5064 . 7915) (TEDIT.CLEAR.CHARBINDINGS 7917 . +10937) (TEDIT.GET.CHARACTION 10939 . 13720) (TEDIT.GET.CHARBINDING 13722 . 15899) ( +TEDIT.GET.ALL.CHARBINDINGS 15901 . 18400) (TEDIT.CHARBINDINGS.INVERT 18402 . 19681) ( +TEDIT.GET.ALL.CHARACTIONS 19683 . 22005) (TEDIT.CONFLICTING.CHARBINDINGS 22007 . 23317)) (23379 33434 +(\TEDIT.KEY.CHARLOOKS 23389 . 24581) (\TEDIT.KEY.QUAD 24583 . 26676) (\TEDIT.DEFAULTSSEL 26678 . 27289 +) (\TEDIT.SETDEFAULT.FROM.SEL 27291 . 27968) (\TEDIT.KEY.SIZE 27970 . 29166) (\TEDIT.SUBSCRIPTSEL +29168 . 29371) (\TEDIT.SUPERSCRIPTSEL 29373 . 29577) (\TEDIT.KEY.TRANSFORM 29579 . 31576) ( +\TEDIT.KEY.OPENLINE 31578 . 32032) (\TEDIT.KEY.FAMILYN 32034 . 33432)) (33435 33724 (CAP-CASECODE +33445 . 33722)) (33758 37190 (\TEDIT.SHOWCARETLOOKS 33768 . 36283) (\TEDIT.DESCRIBEFONT 36285 . 37188) +) (37221 52194 (\TEDIT.ONECHAR.BACKWARD 37231 . 38378) (\TEDIT.ONECHAR.FORWARD 38380 . 39616) ( +\TEDIT.ONELINE.UP 39618 . 42579) (\TEDIT.ONELINE.DOWN 42581 . 44238) (\TEDIT.ONELINE.MOVE 44240 . +46527) (\TEDIT.ONEWORD.BACKWARD 46529 . 47717) (\TEDIT.ONEWORD.FORWARD 47719 . 48906) ( +\TEDIT.LINE.BEGIN 48908 . 49987) (\TEDIT.LINE.END 49989 . 51226) (\TEDIT.DOCUMENT.BEGIN 51228 . 51587) + (\TEDIT.DOCUMENT.END 51589 . 52192)) (52195 55503 (\TEDIT.LINEDELETE.FORWARD 52205 . 53314) ( +\TEDIT.LINEDELETE.BACKWARD 53316 . 54455) (\TEDIT.LINEDELETE 54457 . 55501)) (55504 58032 ( +\TEDIT.KEY.NEST 55514 . 58030)) (58033 59315 (\TEDIT.KEY.WRAP 58043 . 59313)) (59406 67454 ( +\TEDIT.KEY.FIND 59416 . 64594) (\TEDIT.KEY.FIND.SEARCHSTRING 64596 . 65736) (\TEDIT.GET.TARGET.STRING +65738 . 67452)) (67485 70117 (\TEDIT.KEY.SUBSTITUTE 67495 . 67716) (\TEDIT.MANPAGE 67718 . 68965) ( +\TEDIT.CALL.ED 68967 . 69797) (\TEDIT.SELECT.ALL 69799 . 70115)) (70144 75834 (\TEDIT.CLIPBOARD 70154 + . 71909) (\TEDIT.COPYTOCLIPBOARD 71911 . 72691) (\TEDIT.EXTRACTTOCLIPBOARD 72693 . 72888) ( +\TEDIT.WRITE.SEL 72890 . 75832)) (76000 88507 (\TEDIT.READTABLE 76010 . 76946) ( +\TEDIT.WORDBOUND.READTABLE 76948 . 79996) (TEDIT.GETSYNTAX 79998 . 81227) (TEDIT.SETSYNTAX 81229 . +82543) (TEDIT.GETFUNCTION 82545 . 84018) (TEDIT.SETFUNCTION 84020 . 86176) (TEDIT.WORDGET 86178 . +86439) (TEDIT.WORDSET 86441 . 87181) (TEDIT.ATOMBOUND.READTABLE 87183 . 88505)) (88608 95596 ( +TEDIT.BUTTONS.BUILD 88618 . 93864) (TEDIT.BUTTONBITMAP.FILL 93866 . 95594)) (98061 98649 ( +\TEDIT.TTCCLASS 98071 . 98647))))) STOP diff --git a/library/tedit/TEDIT-FNKEYS.LCOM b/library/tedit/TEDIT-FNKEYS.LCOM index 1e667aff..e2989380 100644 Binary files a/library/tedit/TEDIT-FNKEYS.LCOM and b/library/tedit/TEDIT-FNKEYS.LCOM differ diff --git a/library/tedit/TEDIT-LOOKS b/library/tedit/TEDIT-LOOKS index 9c66d9ca..07d6e3b3 100644 --- a/library/tedit/TEDIT-LOOKS +++ b/library/tedit/TEDIT-LOOKS @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 7-Dec-2025 16:32:32" {WMEDLEY}tedit>TEDIT-LOOKS.;460 155196 +(FILECREATED "16-Feb-2026 00:36:00" {WMEDLEY}TEDIT>TEDIT-LOOKS.;467 155443 :EDIT-BY rmk - :CHANGES-TO (VARS TEDIT-LOOKSCOMS) + :CHANGES-TO (FNS \TEDIT.MCCS.TRANSLATE) - :PREVIOUS-DATE " 6-Oct-2025 20:50:59" {WMEDLEY}tedit>TEDIT-LOOKS.;459) + :PREVIOUS-DATE "10-Feb-2026 11:07:12" {WMEDLEY}tedit>TEDIT-LOOKS.;465) (PRETTYCOMPRINT TEDIT-LOOKSCOMS) @@ -924,7 +924,8 @@ (DEFINEQ (\TEDIT.MCCS.TRANSLATE - [LAMBDA (TSTREAM) (* ; "Edited 6-Oct-2025 20:50 by rmk") + [LAMBDA (TSTREAM) (* ; "Edited 16-Feb-2026 00:35 by rmk") + (* ; "Edited 6-Oct-2025 20:50 by rmk") (* ; "Edited 5-Oct-2025 10:57 by rmk") (* ; "Edited 25-Sep-2025 21:30 by rmk") (* ; "Edited 9-Sep-2025 21:48 by rmk") @@ -954,19 +955,17 @@ (SETQ CLOOKS (PCHARLOOKS PC)) CLFONT] - do (for OFFSET OLDCODE STRING FAT from 1 to (PLEN PC) eachtime (SETQ OLDCODE - ( - \TEDIT.PIECE.NTHCHARCODE - PC OFFSET)) + do (for OFFSET OLDCODE STRING FAT from 0 to (PLAST PC) + eachtime (SETQ OLDCODE (\TEDIT.PIECE.NTHCHARCODE PC OFFSET)) unless (EQ OLDCODE (APPLY* TOMCCSFN OLDCODE)) do (* ;; "This piece has recoded character. Start over to convert it to a string piece with necessary code conversions. (The logic to split the original piece at just the changes while still preserving the iteration would be very complicated).") (SETQ STRING (ALLOCSTRING (PLEN PC))) - [for OFFSET from 1 to (PLEN PC) do (RPLCHARCODE STRING OFFSET - (APPLY* TOMCCSFN ( + [for I from 0 to (PLAST PC) do (RPLCHARCODE STRING (ADD1 I) + (APPLY* TOMCCSFN ( \TEDIT.PIECE.NTHCHARCODE - PC OFFSET] + PC I] (SETQ FAT (ffetch (STRINGP FATSTRINGP) of STRING)) (FSETPC PC PTYPE (CL:IF FAT FATSTRING.PTYPE @@ -1377,7 +1376,8 @@ (DEFINEQ (\TEDIT.CHANGE.CHARLOOKS - [LAMBDA (TSTREAM NEWLOOKS TARGETSEL) (* ; "Edited 31-Jul-2025 09:18 by rmk") + [LAMBDA (TSTREAM NEWLOOKS TARGETSEL) (* ; "Edited 10-Feb-2026 11:06 by rmk") + (* ; "Edited 31-Jul-2025 09:18 by rmk") (* ; "Edited 22-Apr-2025 20:17 by rmk") (* ; "Edited 21-Apr-2025 20:17 by rmk") (* ; "Edited 20-Apr-2025 13:27 by rmk") @@ -1403,10 +1403,12 @@ (* ;;; "Internal programmatic interface to changing character looks. DOES NOT CHANGE the current selection (unless it's the TARGETSEL).") (PROG ((TEXTOBJ (TEXTOBJ TSTREAM)) - SELPIECES NEWLOOKSLIST FONT DIRTY) (* ; - "Construct the set of new looks to apply:") + SELPIECES NEWLOOKSLIST FONT DIRTY) (CL:UNLESS TARGETSEL (SETQ TARGETSEL (TEXTSEL TEXTOBJ))) + (CL:WHEN (EQ 0 (GETSEL TARGETSEL DCH)) + (TEDIT.PROMPTPRINT TSTREAM "No characters are selected" T) + (RETURN)) (CL:UNLESS (AND NEWLOOKS (FGETSEL TARGETSEL SET) (NOT (\TEDIT.READONLY TSTREAM NIL (GETSEL TARGETSEL CH#))) (ILEQ (GETSEL TARGETSEL CH#) @@ -2103,7 +2105,8 @@ then (\TEDIT.CHANGE.PARALOOKS TSTREAM NEWLOOKS TARGETSEL)))]) (\TEDIT.CHANGE.PARALOOKS - [LAMBDA (TSTREAM NEWLOOKS TARGETSEL) (* ; "Edited 21-Apr-2025 23:27 by rmk") + [LAMBDA (TSTREAM NEWLOOKS TARGETSEL) (* ; "Edited 10-Feb-2026 11:07 by rmk") + (* ; "Edited 21-Apr-2025 23:27 by rmk") (* ; "Edited 20-Apr-2025 13:27 by rmk") (* ; "Edited 16-Apr-2025 09:05 by rmk") (* ; "Edited 6-Apr-2025 14:29 by rmk") @@ -2126,6 +2129,9 @@ NEWPAGEAFTER HEADINGKEEP KEEP HARDCOPY USERINFO REVISED STYLE CHARSTYLES COLUMN TABS DEFAULTTAB MARGINBAR)) PARAPIECES) + (CL:WHEN (EQ 0 (TEXTLEN TEXTOBJ)) + (TEDIT.PROMPTPRINT TSTREAM "No text to modify" T) + (RETURN)) (CL:UNLESS TARGETSEL (SETQ TARGETSEL (TEXTSEL TEXTOBJ))) (CL:UNLESS (AND NEWLOOKS (FGETSEL TARGETSEL SET) @@ -2458,26 +2464,26 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (22014 23956 (\TEDIT.CHARLOOKS.DEFPRINT 22024 . 23160) (\TEDIT.PARALOOKS.DEFPRINT 23162 - . 23954)) (24060 24446 (\TEDIT.CREATE.FACE.MENU 24070 . 24242) (\TEDIT.CREATE.SIZE.MENU 24244 . 24444 -)) (25450 27339 (\TEDIT.CHARLOOKS.FEATURE.CHECK 25460 . 27337)) (27611 52868 ( -\TEDIT.CHARLOOKS.FROM.FONT 27621 . 29905) (\TEDIT.EQCLOOKS 29907 . 32938) (\TEDIT.SAMECLOOKS 32940 . -36111) (TEDIT.CARETLOOKS 36113 . 37659) (TEDIT.COPY.LOOKS 37661 . 40944) ( -\TEDIT.UNPARSE.CHARLOOKS.LIST 40946 . 44440) (\TEDIT.MODIFYLOOKS 44442 . 46602) (TEDIT.NEW.FONT 46604 - . 47051) (\TEDIT.CARETLOOKS.VERIFY 47053 . 47890) (\TEDIT.CARETPIECE 47892 . 48197) ( -\TEDIT.GET.INSERT.CHARLOOKS 48199 . 51246) (\TEDIT.GET.TERMSA.WIDTHS 51248 . 51664) ( -\TEDIT.PARSE.CHARLOOKS.LIST 51666 . 52866)) (52869 64996 (\TEDIT.MCCS.TRANSLATE 52879 . 58732) ( -\TEDIT.CONVERT.TO.FORMATTED 58734 . 64994)) (65868 73205 (\TEDIT.UNIQUIFY.CHARLOOKS 65878 . 67538) ( -\TEDIT.UNIQUIFY.PARALOOKS 67540 . 68807) (\TEDIT.UNIQUIFY.ALL 68809 . 70897) ( -\TEDIT.FLUSH.UNUSED.LOOKS 70899 . 73203)) (73238 85196 (TEDIT.LOOKS 73248 . 75637) (TEDIT.GET.LOOKS -75639 . 77974) (TEDIT.SUBLOOKS 77976 . 82356) (TEDIT.FINDLOOKS 82358 . 85194)) (85197 114847 ( -\TEDIT.CHANGE.CHARLOOKS 85207 . 93985) (\TEDIT.CHANGE.CHARLOOKS.NEW 93987 . 97802) ( -\TEDIT.CHARLOOKS.CHANGE.FONT 97804 . 106111) (\TEDIT.FONT.NEXTSIZE 106113 . 107734) (\TEDIT.LOOKS -107736 . 111065) (\TEDIT.FONTCOPY 111067 . 112568) (\TEDIT.COERCE.FONTCLASS 112570 . 113721) ( -\TEDIT.FONTCLASS.TO.FONT 113723 . 114845)) (114890 146538 (\TEDIT.EQFMTSPEC 114900 . 118115) ( -TEDIT.GET.PARALOOKS 118117 . 122164) (\TEDIT.PARSE.PARALOOKS.LIST 122166 . 130199) (TEDIT.PARALOOKS -130201 . 131241) (\TEDIT.CHANGE.PARALOOKS 131243 . 138211) (\TEDIT.CHANGE.PARALOOKS.NEW 138213 . -142196) (TEDIT.COPY.PARALOOKS 142198 . 144872) (\TEDIT.PARABOUNDS 144874 . 146536)) (146598 154314 ( -TEDIT.SUBPARALOOKS 146608 . 150710) (SAMEPARALOOKS 150712 . 154312)) (154315 155002 ( -\TEDIT.MARK.REVISION 154325 . 155000))))) + (FILEMAP (NIL (22019 23961 (\TEDIT.CHARLOOKS.DEFPRINT 22029 . 23165) (\TEDIT.PARALOOKS.DEFPRINT 23167 + . 23959)) (24065 24451 (\TEDIT.CREATE.FACE.MENU 24075 . 24247) (\TEDIT.CREATE.SIZE.MENU 24249 . 24449 +)) (25455 27344 (\TEDIT.CHARLOOKS.FEATURE.CHECK 25465 . 27342)) (27616 52873 ( +\TEDIT.CHARLOOKS.FROM.FONT 27626 . 29910) (\TEDIT.EQCLOOKS 29912 . 32943) (\TEDIT.SAMECLOOKS 32945 . +36116) (TEDIT.CARETLOOKS 36118 . 37664) (TEDIT.COPY.LOOKS 37666 . 40949) ( +\TEDIT.UNPARSE.CHARLOOKS.LIST 40951 . 44445) (\TEDIT.MODIFYLOOKS 44447 . 46607) (TEDIT.NEW.FONT 46609 + . 47056) (\TEDIT.CARETLOOKS.VERIFY 47058 . 47895) (\TEDIT.CARETPIECE 47897 . 48202) ( +\TEDIT.GET.INSERT.CHARLOOKS 48204 . 51251) (\TEDIT.GET.TERMSA.WIDTHS 51253 . 51669) ( +\TEDIT.PARSE.CHARLOOKS.LIST 51671 . 52871)) (52874 64879 (\TEDIT.MCCS.TRANSLATE 52884 . 58615) ( +\TEDIT.CONVERT.TO.FORMATTED 58617 . 64877)) (65751 73088 (\TEDIT.UNIQUIFY.CHARLOOKS 65761 . 67421) ( +\TEDIT.UNIQUIFY.PARALOOKS 67423 . 68690) (\TEDIT.UNIQUIFY.ALL 68692 . 70780) ( +\TEDIT.FLUSH.UNUSED.LOOKS 70782 . 73086)) (73121 85079 (TEDIT.LOOKS 73131 . 75520) (TEDIT.GET.LOOKS +75522 . 77857) (TEDIT.SUBLOOKS 77859 . 82239) (TEDIT.FINDLOOKS 82241 . 85077)) (85080 114853 ( +\TEDIT.CHANGE.CHARLOOKS 85090 . 93991) (\TEDIT.CHANGE.CHARLOOKS.NEW 93993 . 97808) ( +\TEDIT.CHARLOOKS.CHANGE.FONT 97810 . 106117) (\TEDIT.FONT.NEXTSIZE 106119 . 107740) (\TEDIT.LOOKS +107742 . 111071) (\TEDIT.FONTCOPY 111073 . 112574) (\TEDIT.COERCE.FONTCLASS 112576 . 113727) ( +\TEDIT.FONTCLASS.TO.FONT 113729 . 114851)) (114896 146785 (\TEDIT.EQFMTSPEC 114906 . 118121) ( +TEDIT.GET.PARALOOKS 118123 . 122170) (\TEDIT.PARSE.PARALOOKS.LIST 122172 . 130205) (TEDIT.PARALOOKS +130207 . 131247) (\TEDIT.CHANGE.PARALOOKS 131249 . 138458) (\TEDIT.CHANGE.PARALOOKS.NEW 138460 . +142443) (TEDIT.COPY.PARALOOKS 142445 . 145119) (\TEDIT.PARABOUNDS 145121 . 146783)) (146845 154561 ( +TEDIT.SUBPARALOOKS 146855 . 150957) (SAMEPARALOOKS 150959 . 154559)) (154562 155249 ( +\TEDIT.MARK.REVISION 154572 . 155247))))) STOP diff --git a/library/tedit/TEDIT-LOOKS.LCOM b/library/tedit/TEDIT-LOOKS.LCOM index 066f0a15..6b163d52 100644 Binary files a/library/tedit/TEDIT-LOOKS.LCOM and b/library/tedit/TEDIT-LOOKS.LCOM differ diff --git a/library/tedit/TEDIT-MENU b/library/tedit/TEDIT-MENU index 6794e9d7..5a14b140 100644 --- a/library/tedit/TEDIT-MENU +++ b/library/tedit/TEDIT-MENU @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "12-Dec-2025 00:01:26" {WMEDLEY}tedit>TEDIT-MENU.;501 183343 +(FILECREATED " 9-Feb-2026 09:10:43" {WMEDLEY}tedit>TEDIT-MENU.;510 183027 :EDIT-BY rmk - :CHANGES-TO (VARS TEDIT-MENUCOMS) + :CHANGES-TO (FNS \TEDIT.PAGEMENU.CREATE) - :PREVIOUS-DATE " 7-Dec-2025 16:34:30" {WMEDLEY}tedit>TEDIT-MENU.;499) + :PREVIOUS-DATE "27-Jan-2026 10:42:09" {WMEDLEY}tedit>TEDIT-MENU.;508) (PRETTYCOMPRINT TEDIT-MENUCOMS) @@ -1381,7 +1381,8 @@ (DEFINEQ (\TEDIT.EXPANDEDMENU.CREATE - [LAMBDA NIL (* ; "Edited 29-May-2025 09:31 by rmk") + [LAMBDA NIL (* ; "Edited 25-Jan-2026 10:52 by rmk") + (* ; "Edited 29-May-2025 09:31 by rmk") (* ; "Edited 8-Mar-2025 12:27 by rmk") (* ; "Edited 7-Jan-2025 16:05 by rmk") (* ; "Edited 8-Nov-2024 08:35 by rmk") @@ -1463,13 +1464,15 @@ TAB (FIELD (IDENTIFIER SERVER) (PRELABEL "server:") - (FIELDTYPE SYMBOL)) + (FIELDTYPE SYMBOL) + (EMPTYVALUE NIL)) (FIELD (IDENTIFIER COPIES) (PRELABEL "copies:") + (EMPTYVALUE 1) (FIELDTYPE POSITIVENUMBER)) - 2 - (NWAY (IDENTIFIER SIDES) - (BUTTONS (One% Side Duplex))) + 3 + (TOGGLE (IDENTIFIER DOUBLE-SIDED) + (LABEL "Double-sided")) EOL TAB TAB (FIELD (IDENTIFIER MESSAGE/PHONE#) (PRELABEL "Message/Phone#:") (FIELDTYPE STRING]) @@ -1546,7 +1549,8 @@ (RETURN 'DON'T]) (\TEDIT.EXPANDEDMENU.ACTIONFN - [LAMBDA (OBJ MENUSEL MENUWINDOW MENUSTREAM MAINSTREAM) (* ; "Edited 29-May-2025 09:29 by rmk") + [LAMBDA (OBJ MENUSEL MENUWINDOW MENUSTREAM MAINSTREAM) (* ; "Edited 25-Jan-2026 11:05 by rmk") + (* ; "Edited 29-May-2025 09:29 by rmk") (* ; "Edited 11-May-2025 15:01 by rmk") (* ; "Edited 6-Apr-2025 14:39 by rmk") (* ; "Edited 18-Mar-2025 23:54 by rmk") @@ -1564,11 +1568,11 @@ (* ;  "MBFN for TEdit default menu item buttons.") (ERSETQ (RESETLST + (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SEL) + (FSETSEL SEL SET NIL] + MENUSEL)) (LET ((MENUTEXTOBJ (FTEXTOBJ MENUSTREAM)) STATES STATE) - [RESETSAVE (PROG1 OBJ - (IMAGEOBJPROP OBJ 'MENUBUTTON.SELECTED T)) - '(AND (IMAGEOBJPROP OLDVALUE 'MENUBUTTON.SELECTED NIL] (SELECTQ (IMAGEOBJPROP OBJ 'IDENTIFIER) (QUIT (* ; "Is it OK to quit the main edit?") (\TEDIT.FINISHEDIT? MAINSTREAM)) @@ -1636,29 +1640,21 @@ ) (EQ 'ON (LISTGET STATES 'CONFIRM)) (EQ 'ON (LISTGET STATES 'USENEWLOOKS])]) - (HARDCOPY (SETQ STATES (MB.GET '(SERVER COPIES SIDES MESSAGE/PHONE#) + (HARDCOPY (SETQ STATES (MB.GET '(SERVER COPIES DOUBLE-SIDED MESSAGE/PHONE#) MENUSTREAM 'STATE MENUSEL)) - (LET ((SERVER (LISTGET STATES 'SERVER)) - (COPIES (LISTGET STATES 'COPIES)) - (SIDES (LISTGET STATES 'SIDES)) + (LET ((COPIES (LISTGET STATES 'COPIES)) (MSG (LISTGET STATES 'MESSAGE/PHONE#)) PRINTOPTIONS) - (CL:UNLESS (AND SERVER (SETQ SERVER (\TEDIT.MAKEFILENAME - SERVER))) - (TEDIT.PROMPTPRINT MAINSTREAM - "Using default print server.")) (CL:WHEN COPIES (SETQ PRINTOPTIONS (LIST '%#COPIES COPIES))) - (CL:WHEN SIDES - (push PRINTOPTIONS '%#SIDES (SELECTQ SIDES - (One% Side 1) - (Duplex 2) - NIL))) + (CL:WHEN (LISTGET STATES 'DOUBLE-SIDED) + (push PRINTOPTIONS '%#SIDES 2)) (CL:WHEN MSG (push PRINTOPTIONS 'MESSAGE (\TEDIT.MAKEFILENAME MSG))) - (TEDIT.HARDCOPY MAINSTREAM NIL NIL NIL SERVER PRINTOPTIONS))) - (ERROR))))]) + (SEND.FILE.TO.PRINTER MAINSTREAM (LISTGET STATES 'SERVER) + PRINTOPTIONS))) + (SHOULDNT))))]) ) @@ -2371,7 +2367,9 @@ (DEFINEQ (\TEDIT.PAGEMENU.CREATE - [LAMBDA (TSTREAM) (* ; "Edited 5-Jun-2025 18:41 by rmk") + [LAMBDA (TSTREAM) (* ; "Edited 9-Feb-2026 09:09 by rmk") + (* ; "Edited 26-Jan-2026 12:03 by rmk") + (* ; "Edited 5-Jun-2025 18:41 by rmk") (* ; "Edited 11-May-2025 14:40 by rmk") (* ; "Edited 27-Jan-2025 08:51 by rmk") (* ; "Edited 7-Jan-2025 15:47 by rmk") @@ -2411,16 +2409,10 @@ EOL "Paper Size: " (NWAY (IDENTIFIER PAPERSIZE) (BUTTONS (Letter Legal A4)) (INITSTATE Letter)) - 8 + 16 (TOGGLE (LABEL "Landscape")) - 7 - (FIELD (IDENTIFIER STARTINGPAGE#) - (PRELABEL "Starting page #:") - (LABELFONT (HELVETICA 10)) - (FIELDTYPE POSITIVENUMBER)) EOL - (TEXT (STRING "For page: ") - (FONT (HELVETICA 10))) + (TEXT (STRING "For page: ")) (NWAY (IDENTIFIER PAGEID) (BUTTONS (|First(&Default)| Other% Left Other% Right))) EOL @@ -2430,8 +2422,7 @@ (* ;; "Page numbers") 5 - (TEXT (STRING "Page numbers: ") - (FONT (HELVETICA 10))) + (TEXT (STRING "Page numbers: ")) (NWAY (IDENTIFIER PAGENOS) (BUTTONS (No Yes Heading)) (INITSTATE Yes)) @@ -2454,14 +2445,18 @@ 3 "Alignment:" 2 (NWAY (IDENTIFIER QUAD) (BUTTONS (Left Centered Right)) (INITSTATE Centered)) + EOL TAB (FIELD (IDENTIFIER FOLIOPRETEXT) + (PRELABEL "Text before number:")) + 5 + (FIELD (IDENTIFIER FOLIOPOSTTEXT) + (PRELABEL "Text after number:")) EOL (* ;; "") (* ;; "Margins") - EOL 5 (TEXT (STRING "Margins: ") - (FONT (HELVETICA 10))) + EOL 5 (TEXT (STRING "Margins: ")) (FIELD (IDENTIFIER LEFTMARGIN) (PRELABEL "Left") (POSTLABEL "picas") @@ -2489,7 +2484,6 @@ EOL 5 (FIELD (IDENTIFIER COLUMNS) (PRELABEL "Columns:") - (LABELFONT (HELVETICA 10)) (INITSTATE 1) (FIELDTYPE POSITIVENUMBER)) 4 @@ -2735,7 +2729,8 @@ (TEDIT.BACKTOMAIN MENUSTREAM]) (\TEDIT.CHANGE.PAGELOOKS - [LAMBDA (MAINTEXTSTREAM PAGELOOKS) (* ; "Edited 11-May-2025 15:04 by rmk") + [LAMBDA (MAINTEXTSTREAM PAGELOOKS) (* ; "Edited 27-Jan-2026 10:41 by rmk") + (* ; "Edited 11-May-2025 15:04 by rmk") (* ; "Edited 24-Dec-2024 21:28 by rmk") (* ; "Edited 20-Oct-2024 17:17 by rmk") (* ; "Edited 30-Aug-2024 23:43 by rmk") @@ -2754,8 +2749,8 @@ ((OFF NEUTRAL) (RPLACA PLTAIL NIL)) NIL)) - (SELECTQ PAGENOS - (Yes (* ; + (SELECTQ (L-CASE PAGENOS T) + ((Yes T) (* ;  "Page number format specfified in pagelooks menu") (CL:UNLESS (AND (LISTGET PAGELOOKS 'PAGENUMBERX) (LISTGET PAGELOOKS 'PAGENUMBERY)) @@ -2776,7 +2771,7 @@ (* ;; "Page numbers formatted/printed by image object in header paragraphs") (push PAGEPROPS 'STARTINGPAGE# (LISTGET PAGELOOKS 'STARTINGPAGE#))) - NIL) + (SHOULDNT)) (CL:UNLESS (LISTGET PAGELOOKS 'COLUMNS) (LISTPUT PAGELOOKS 'COLUMNS 1) (RETURN)) @@ -2786,9 +2781,6 @@ (TEDIT.PROMPTPRINT MAINTEXTOBJ "Please specify the space between columns" T T) (RETURN)) [push PAGEPROPS 'LANDSCAPE? (EQ 'ON (LISTGET PAGELOOKS 'LANDSCAPE] - - (* ;; "**EMPTY** may come from field values in the pagelooks menue") - (TEDIT.PAGEFORMAT MAINTEXTOBJ (TEDIT.SINGLE.PAGEFORMAT PAGENOS (LISTGET PAGELOOKS 'PAGENUMBERX) (LISTGET PAGELOOKS 'PAGENUMBERY) @@ -2907,32 +2899,32 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4929 16567 (TEDIT.ADD.MENUITEM 4939 . 7056) (TEDIT.DEFAULT.MENUFN 7058 . 13779) ( -TEDIT.REMOVE.MENUITEM 13781 . 14778) (\TEDIT.CREATEMENU 14780 . 15345) (\TEDIT.MENU.WHENHELDFN 15347 - . 16252) (\TEDIT.MENU.WHENSELECTEDFN 16254 . 16565)) (17381 65416 (DRAWMARGINSCALE 17391 . 20850) ( -MARGINBAR 20852 . 27977) (MARGINBAR.CREATE 27979 . 32177) (MB.MARGINBAR.BUTTONEVENTINFN 32179 . 39981) - (MB.MARGINBAR.SELFN.TABS 39983 . 45223) (MB.MARGINBAR.SELFN.TABS.KIND 45225 . 46160) ( -MARGINBAR.GETSTATEFN 46162 . 50149) (MARGINBAR.SETSTATEFN 50151 . 50361) (MARGINBAR.NEUTRALIZE 50363 - . 51038) (MARGINBAR.LOOKS 51040 . 54146) (MB.MARGINBAR.SIZEFN 54148 . 54934) (MB.MARGINBAR.DISPLAYFN -54936 . 57997) (MDESCALE 57999 . 58539) (MSCALE 58541 . 58871) (MB.MARGINBAR.SHOWTAB 58873 . 61196) ( -MB.MARGINBAR.TABTRACK 61198 . 62583) (MARGINBAR.INIT 62585 . 63978) (\TEDIT.PARALOOKS.TO.MARBAR 63980 - . 65414)) (66241 73523 (TEDIT.MENUSTREAM 66251 . 67251) (TEDITMENUP 67253 . 68222) (\TEDIT.MENU.START - 68224 . 72571) (\TEDIT.MENU.OPEN? 72573 . 72947) (\TEDIT.MENU.BUTTONEVENTFN 72949 . 73521)) (73842 -81893 (\TEDIT.MENU.CREATE 73852 . 75792) (\TEDIT.MENU.PARSE 75794 . 79483) (\TEDIT.MENU.NEUTRALIZE -79485 . 81556) (\TEDITMENU.RECORD.UNFORMATTED 81558 . 81891)) (81959 101740 ( -\TEDIT.EXPANDEDMENU.CREATE 81969 . 87436) (\TEDIT.EXPANDEDMENU.START 87438 . 89062) ( -\TEDIT.EXPANDEDMENU.FN 89064 . 92319) (\TEDIT.EXPANDEDMENU.ACTIONFN 92321 . 101738)) (101802 121227 ( -\TEDIT.PARAMENU.CREATE 101812 . 110543) (\TEDIT.PARAMENU.START 110545 . 111799) ( -\TEDIT.APPLY.PARALOOKS 111801 . 112853) (\TEDIT.SHOW.PARALOOKS 112855 . 115572) ( -\TEDIT.PARAMENU.FILLIN 115574 . 120323) (\TEDIT.PARAMENU.RESHAPEFN 120325 . 121225)) (121421 148263 ( -\TEDIT.CHARMENU.CREATE 121431 . 124035) (\TEDIT.CHARMENU.START 124037 . 125327) (\TEDIT.CHARMENU.SPEC -125329 . 130012) (\TEDIT.CHARMENU.PARSE 130014 . 133182) (\TEDIT.CHARMENU.FILLIN 133184 . 137814) ( -\TEDIT.SHOW.CHARLOOKS 137816 . 141361) (\TEDIT.APPLY.CHARLOOKS 141363 . 142524) ( -\TEDIT.OFFSETTYPE.STATEFN 142526 . 144489) (\TEDIT.OTHER.STATECHANGEFN 144491 . 146136) ( -\TEDIT.OTHER.SELECTFN 146138 . 148261)) (148325 177383 (\TEDIT.PAGEMENU.CREATE 148335 . 156847) ( -\TEDIT.PAGEMENU.START 156849 . 157200) (\TEDIT.SHOW.PAGELOOKS 157202 . 159088) (\TEDIT.PAGEMENU.FILLIN - 159090 . 160640) (\TEDIT.PAGEREGION.UNPARSE 160642 . 170041) (\TEDIT.APPLY.PAGELOOKS 170043 . 171970) - (\TEDIT.CHANGE.PAGELOOKS 171972 . 176539) (\TEDIT.PAGEMENU.CHARLOOKS.STATEFN 176541 . 177381)) ( -177384 183187 (\TEDIT.PAGEMENU.CREATE.HEADINGS 177394 . 180206) (\TEDIT.PAGEMENU.HEADINGS.SETSTATEFN -180208 . 181633) (\TEDIT.PAGEMENU.HEADINGS.STATEFN 181635 . 183185))))) + (FILEMAP (NIL (4936 16574 (TEDIT.ADD.MENUITEM 4946 . 7063) (TEDIT.DEFAULT.MENUFN 7065 . 13786) ( +TEDIT.REMOVE.MENUITEM 13788 . 14785) (\TEDIT.CREATEMENU 14787 . 15352) (\TEDIT.MENU.WHENHELDFN 15354 + . 16259) (\TEDIT.MENU.WHENSELECTEDFN 16261 . 16572)) (17388 65423 (DRAWMARGINSCALE 17398 . 20857) ( +MARGINBAR 20859 . 27984) (MARGINBAR.CREATE 27986 . 32184) (MB.MARGINBAR.BUTTONEVENTINFN 32186 . 39988) + (MB.MARGINBAR.SELFN.TABS 39990 . 45230) (MB.MARGINBAR.SELFN.TABS.KIND 45232 . 46167) ( +MARGINBAR.GETSTATEFN 46169 . 50156) (MARGINBAR.SETSTATEFN 50158 . 50368) (MARGINBAR.NEUTRALIZE 50370 + . 51045) (MARGINBAR.LOOKS 51047 . 54153) (MB.MARGINBAR.SIZEFN 54155 . 54941) (MB.MARGINBAR.DISPLAYFN +54943 . 58004) (MDESCALE 58006 . 58546) (MSCALE 58548 . 58878) (MB.MARGINBAR.SHOWTAB 58880 . 61203) ( +MB.MARGINBAR.TABTRACK 61205 . 62590) (MARGINBAR.INIT 62592 . 63985) (\TEDIT.PARALOOKS.TO.MARBAR 63987 + . 65421)) (66248 73530 (TEDIT.MENUSTREAM 66258 . 67258) (TEDITMENUP 67260 . 68229) (\TEDIT.MENU.START + 68231 . 72578) (\TEDIT.MENU.OPEN? 72580 . 72954) (\TEDIT.MENU.BUTTONEVENTFN 72956 . 73528)) (73849 +81900 (\TEDIT.MENU.CREATE 73859 . 75799) (\TEDIT.MENU.PARSE 75801 . 79490) (\TEDIT.MENU.NEUTRALIZE +79492 . 81563) (\TEDITMENU.RECORD.UNFORMATTED 81565 . 81898)) (81966 101368 ( +\TEDIT.EXPANDEDMENU.CREATE 81976 . 87654) (\TEDIT.EXPANDEDMENU.START 87656 . 89280) ( +\TEDIT.EXPANDEDMENU.FN 89282 . 92537) (\TEDIT.EXPANDEDMENU.ACTIONFN 92539 . 101366)) (101430 120855 ( +\TEDIT.PARAMENU.CREATE 101440 . 110171) (\TEDIT.PARAMENU.START 110173 . 111427) ( +\TEDIT.APPLY.PARALOOKS 111429 . 112481) (\TEDIT.SHOW.PARALOOKS 112483 . 115200) ( +\TEDIT.PARAMENU.FILLIN 115202 . 119951) (\TEDIT.PARAMENU.RESHAPEFN 119953 . 120853)) (121049 147891 ( +\TEDIT.CHARMENU.CREATE 121059 . 123663) (\TEDIT.CHARMENU.START 123665 . 124955) (\TEDIT.CHARMENU.SPEC +124957 . 129640) (\TEDIT.CHARMENU.PARSE 129642 . 132810) (\TEDIT.CHARMENU.FILLIN 132812 . 137442) ( +\TEDIT.SHOW.CHARLOOKS 137444 . 140989) (\TEDIT.APPLY.CHARLOOKS 140991 . 142152) ( +\TEDIT.OFFSETTYPE.STATEFN 142154 . 144117) (\TEDIT.OTHER.STATECHANGEFN 144119 . 145764) ( +\TEDIT.OTHER.SELECTFN 145766 . 147889)) (147953 177067 (\TEDIT.PAGEMENU.CREATE 147963 . 156484) ( +\TEDIT.PAGEMENU.START 156486 . 156837) (\TEDIT.SHOW.PAGELOOKS 156839 . 158725) (\TEDIT.PAGEMENU.FILLIN + 158727 . 160277) (\TEDIT.PAGEREGION.UNPARSE 160279 . 169678) (\TEDIT.APPLY.PAGELOOKS 169680 . 171607) + (\TEDIT.CHANGE.PAGELOOKS 171609 . 176223) (\TEDIT.PAGEMENU.CHARLOOKS.STATEFN 176225 . 177065)) ( +177068 182871 (\TEDIT.PAGEMENU.CREATE.HEADINGS 177078 . 179890) (\TEDIT.PAGEMENU.HEADINGS.SETSTATEFN +179892 . 181317) (\TEDIT.PAGEMENU.HEADINGS.STATEFN 181319 . 182869))))) STOP diff --git a/library/tedit/TEDIT-MENU.LCOM b/library/tedit/TEDIT-MENU.LCOM index 8c35a52d..4e14a98a 100644 Binary files a/library/tedit/TEDIT-MENU.LCOM and b/library/tedit/TEDIT-MENU.LCOM differ diff --git a/library/tedit/TEDIT-PAGE b/library/tedit/TEDIT-PAGE index 557b9cbe..3ed7ebe6 100644 --- a/library/tedit/TEDIT-PAGE +++ b/library/tedit/TEDIT-PAGE @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "17-Jan-2026 12:00:08" {WMEDLEY}tedit>TEDIT-PAGE.;241 130528 +(FILECREATED "27-Jan-2026 10:30:27" {WMEDLEY}TEDIT>TEDIT-PAGE.;243 130855 :EDIT-BY rmk - :CHANGES-TO (FNS TEDIT.TO.IMAGEFILE) + :CHANGES-TO (FNS TEDIT.SINGLE.PAGEFORMAT) + (VARS TEDIT-PAGECOMS) - :PREVIOUS-DATE "15-Jan-2026 10:48:30" {WMEDLEY}tedit>TEDIT-PAGE.;240) + :PREVIOUS-DATE "17-Jan-2026 12:00:08" {WMEDLEY}TEDIT>TEDIT-PAGE.;241) (PRETTYCOMPRINT TEDIT-PAGECOMS) @@ -51,6 +52,7 @@ (TEDIT.SINGLE.PAGEFORMAT T 540 756 NIL 'RIGHT 72 72 72 72 NIL 1] (FNS TEDIT.TO.IMAGEFILE) + [P (DEFAULT.IMAGETYPE.CONVERSIONS '(TEDIT TEDIT.TO.IMAGEFILE] (COMS (* ;; "Perform page layout, based on a regular expression of typed regions.") @@ -313,7 +315,8 @@ (TEDIT.SINGLE.PAGEFORMAT [LAMBDA (PAGE#S? PX PY PFONT PQUAD LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS UNITS - PAGEPROPS PAPERSIZE) (* ; "Edited 11-May-2025 14:59 by rmk") + PAGEPROPS PAPERSIZE) (* ; "Edited 27-Jan-2026 10:30 by rmk") + (* ; "Edited 11-May-2025 14:59 by rmk") (* ; "Edited 10-Jan-2025 11:41 by rmk") (* ; "Edited 24-Dec-2024 21:20 by rmk") (* ; "Edited 15-Aug-2024 23:01 by rmk") @@ -356,7 +359,8 @@ (AND INTERCOL (SETQ INTERCOL (HCSCALE SCALEFACTOR INTERCOL))) (SETQ PAGEWIDTH (IDIFFERENCE (IDIFFERENCE PAPERWIDTH RIGHT) LEFT)) - (CL:WHEN (EQ PAGE#S? 'Yes) + (CL:WHEN (MEMB (L-CASE PAGE#S? T) + '(T Yes)) (* ;; "This asserts that the page number's region is 4 inches wide. Why? What if the pretext/posttext is longer?") @@ -730,6 +734,8 @@ (RETURN (CLOSEF IMAGESTREAM))))]) ) +(DEFAULT.IMAGETYPE.CONVERSIONS '(TEDIT TEDIT.TO.IMAGEFILE)) + (* ;; "Perform page layout, based on a regular expression of typed regions.") @@ -2056,18 +2062,18 @@ (RETURN (DREMOVE NIL $$VAL]) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (12133 15745 (\TEDIT.PARSE.PAGEFRAMES 12143 . 13922) (\TEDIT.PUT.PAGEFRAMES 13924 . -14748) (\TEDIT.UNPARSE.PAGEFRAMES 14750 . 15743)) (15808 37825 (TEDIT.SINGLE.PAGEFORMAT 15818 . 26811) - (TEDIT.COMPOUND.PAGEFORMAT 26813 . 27792) (TEDIT.PAGEFORMAT 27794 . 35083) (TEDIT.GET.PAGEFORMAT -35085 . 37823)) (38112 44592 (TEDIT.TO.IMAGEFILE 38122 . 44590)) (44679 97931 (\TEDIT.FORMATBOX 44689 - . 58113) (\TEDIT.FORMATHEADING 58115 . 62761) (\TEDIT.FORMATPAGE 62763 . 71952) (\TEDIT.FORMATTEXTBOX - 71954 . 88467) (\TEDIT.FORMATFOLIO 88469 . 93786) (\TEDIT.FORMAT.FOUNDBOX? 93788 . 95827) ( -\TEDIT.SKIP.SPECIALCOND 95829 . 97929)) (98011 103066 (\TEDIT.HARDCOPY.PAGEHEADINGS 98021 . 103064)) ( -103175 111226 (\TEDIT.HARDCOPY-COLUMN-END 103185 . 111224)) (111271 116212 (SCALEPAGEUNITS 111281 . -112422) (SCALEPAGEXUNITS 112424 . 113194) (SCALEPAGEYUNITS 113196 . 113967) (\TEDIT.PAPERHEIGHT 113969 - . 114904) (\TEDIT.PAPERWIDTH 114906 . 116210)) (116628 120196 (ROMANNUMERALS 116638 . 120194)) ( -120235 127501 (TEDIT.PAGENO.CREATE 120245 . 120621) (\TEDIT.PAGENO.OBJINIT 120623 . 121906) ( -\TEDIT.PAGENO.BUTTONEVENTINFN 121908 . 122974) (\TEDIT.PAGENO.IMAGEBOXFN 122976 . 125126) ( -\TEDIT.PAGENO.DISPLAYFN 125128 . 126778) (\TEDIT.PAGENO.GETFN 126780 . 127172) (\TEDIT.PAGENO.PUTFN -127174 . 127499)) (127566 130505 (\TEDIT.FORMAT.FOOTNOTE 127576 . 130503))))) + (FILEMAP (NIL (12248 15860 (\TEDIT.PARSE.PAGEFRAMES 12258 . 14037) (\TEDIT.PUT.PAGEFRAMES 14039 . +14863) (\TEDIT.UNPARSE.PAGEFRAMES 14865 . 15858)) (15923 38091 (TEDIT.SINGLE.PAGEFORMAT 15933 . 27077) + (TEDIT.COMPOUND.PAGEFORMAT 27079 . 28058) (TEDIT.PAGEFORMAT 28060 . 35349) (TEDIT.GET.PAGEFORMAT +35351 . 38089)) (38378 44858 (TEDIT.TO.IMAGEFILE 38388 . 44856)) (45006 98258 (\TEDIT.FORMATBOX 45016 + . 58440) (\TEDIT.FORMATHEADING 58442 . 63088) (\TEDIT.FORMATPAGE 63090 . 72279) (\TEDIT.FORMATTEXTBOX + 72281 . 88794) (\TEDIT.FORMATFOLIO 88796 . 94113) (\TEDIT.FORMAT.FOUNDBOX? 94115 . 96154) ( +\TEDIT.SKIP.SPECIALCOND 96156 . 98256)) (98338 103393 (\TEDIT.HARDCOPY.PAGEHEADINGS 98348 . 103391)) ( +103502 111553 (\TEDIT.HARDCOPY-COLUMN-END 103512 . 111551)) (111598 116539 (SCALEPAGEUNITS 111608 . +112749) (SCALEPAGEXUNITS 112751 . 113521) (SCALEPAGEYUNITS 113523 . 114294) (\TEDIT.PAPERHEIGHT 114296 + . 115231) (\TEDIT.PAPERWIDTH 115233 . 116537)) (116955 120523 (ROMANNUMERALS 116965 . 120521)) ( +120562 127828 (TEDIT.PAGENO.CREATE 120572 . 120948) (\TEDIT.PAGENO.OBJINIT 120950 . 122233) ( +\TEDIT.PAGENO.BUTTONEVENTINFN 122235 . 123301) (\TEDIT.PAGENO.IMAGEBOXFN 123303 . 125453) ( +\TEDIT.PAGENO.DISPLAYFN 125455 . 127105) (\TEDIT.PAGENO.GETFN 127107 . 127499) (\TEDIT.PAGENO.PUTFN +127501 . 127826)) (127893 130832 (\TEDIT.FORMAT.FOOTNOTE 127903 . 130830))))) STOP diff --git a/library/tedit/TEDIT-PAGE.LCOM b/library/tedit/TEDIT-PAGE.LCOM index 79d8c691..e0e57bf5 100644 Binary files a/library/tedit/TEDIT-PAGE.LCOM and b/library/tedit/TEDIT-PAGE.LCOM differ diff --git a/library/tedit/TEDIT-PCTREE b/library/tedit/TEDIT-PCTREE index b1dca4b3..b31bd75c 100644 --- a/library/tedit/TEDIT-PCTREE +++ b/library/tedit/TEDIT-PCTREE @@ -1,14 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "28-Jul-2025 23:25:19"  -{DSK}kaplan>Local>medley3.5>working-medley>library>tedit>TEDIT-PCTREE.;249 69193 +(FILECREATED "14-Feb-2026 13:22:06" {WMEDLEY}TEDIT>TEDIT-PCTREE.;251 68691 :EDIT-BY rmk - :CHANGES-TO (FNS \TEDIT.MAKEPCTB) + :CHANGES-TO (VARS TEDIT-PCTREECOMS) + (FNS \TEDIT.UNLINKPIECE \TEDIT.DELETEPIECES) - :PREVIOUS-DATE " 8-Feb-2025 20:56:54" -{DSK}kaplan>Local>medley3.5>working-medley>library>tedit>TEDIT-PCTREE.;248) + :PREVIOUS-DATE "28-Jul-2025 23:25:19" {WMEDLEY}TEDIT>TEDIT-PCTREE.;249) (PRETTYCOMPRINT TEDIT-PCTREECOMS) @@ -37,8 +36,8 @@ (GLOBALVARS MULTIPLE-PIECE-TABLES) (FNS \TEDIT.MAKEPCTB \TEDIT.UPDATEPCNODES \TEDIT.FIRSTPIECE \TEDIT.DELETETREE \TEDIT.INSERTTREE \TEDIT.LASTPIECE \TEDIT.PCTOCH \TEDIT.CHTOPC \TEDIT.SET-TOTLEN - \TEDIT.MAKE.VACANT.BTREESLOT \TEDIT.LINKNEWPIECE \TEDIT.UNLINKPIECE \TEDIT.SPLITPIECE - \TEDIT.INSERTPIECE \TEDIT.INSERTPIECES \TEDIT.DELETEPIECES \TEDIT.ALIGNEDPIECE) + \TEDIT.MAKE.VACANT.BTREESLOT \TEDIT.LINKNEWPIECE \TEDIT.SPLITPIECE \TEDIT.INSERTPIECE + \TEDIT.INSERTPIECES \TEDIT.DELETEPIECES \TEDIT.ALIGNEDPIECE) (COMS (* ; "Debugging ") (FNS \TEDIT.BTVALIDATE \TEDIT.BTVALIDATE.PRINT \TEDIT.CHECK-BTREE \TEDIT.CHECK-BTREE1 \TEDIT.BTFAIL \TEDIT.MATCHPCS) @@ -658,20 +657,6 @@ (freplace (PIECE PREVPIECE) of NEXT with NEW)) NEW]) -(\TEDIT.UNLINKPIECE - [LAMBDA (PREV PC TEXTOBJ) (* ; "Edited 7-Feb-2025 08:04 by rmk") - (* ; "Edited 21-Oct-2024 00:26 by rmk") - (* ; "Edited 21-Oct-2023 17:24 by rmk") - (* ; "Edited 30-May-2023 00:31 by rmk") - - (* ;; "Takes PC out of the piece chain, linking prev and next around it.") - - (\TEDIT.THELP 'NOTCALLED?) - (CL:WHEN PREV - (freplace (PIECE NEXTPIECE) of PREV with (NEXTPIECE PC))) - (freplace (PIECE PREVPIECE) of (OR (NEXTPIECE PC) - (FGETTOBJ TEXTOBJ SUFFIXPIECE)) with PREV]) - (\TEDIT.SPLITPIECE [LAMBDA (PC CHOFFSET TEXTOBJ) (* ; "Edited 21-Oct-2024 00:33 by rmk") (* ; "Edited 17-Mar-2024 00:11 by rmk") @@ -838,7 +823,8 @@ PIECES]) (\TEDIT.DELETEPIECES - [LAMBDA (SELPIECES TEXTOBJ) (* ; "Edited 7-Feb-2025 08:08 by rmk") + [LAMBDA (SELPIECES TEXTOBJ) (* ; "Edited 14-Feb-2026 13:20 by rmk") + (* ; "Edited 7-Feb-2025 08:08 by rmk") (* ; "Edited 26-Nov-2024 10:50 by rmk") (* ; "Edited 16-Mar-2024 10:00 by rmk") (* ; "Edited 25-Nov-2023 12:12 by rmk") @@ -859,6 +845,11 @@ (* ;; "This may not be entirely safe against an interrupt, which only matters on the call from \INSERTSELPIECES (otherwise the data isn't yet visible). Although the tree is consistent with the remaining pieces after each deletion, the fact that we keep the SELPIECE links intact means that the remaining pieces point to pieces that are no longer in the tree. We could do a little more work to incrementally chain the deleted pieces together, one by one, as they are deleted--in the end they would all be out of the tree, and the deletion chain would have been reconnected. Alternatively, we can make the whole loop be uninterruptable. ") (\TEDIT.BTVALIDATE '\TEDIT.DELETEPIECES 'BEFORE TEXTOBJ) + (CL:WHEN (type? PIECE SELPIECES) + (SETQ SELPIECES (create SELPIECES + SPFIRST _ SELPIECES + SPLAST _ SELPIECES + SPLEN _ (PLEN SELPIECES)))) (for PC PREV NEXT first (FSETTOBJ TEXTOBJ HINTPC NIL) (SETQ PREV (PREVPIECE (GETSPC SELPIECES SPFIRST))) (* ; "For incremental chain-update") @@ -1113,13 +1104,13 @@ (GLOBALVARS BTVALIDATETAGS) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (8767 56719 (\TEDIT.MAKEPCTB 8777 . 10670) (\TEDIT.UPDATEPCNODES 10672 . 12966) ( -\TEDIT.FIRSTPIECE 12968 . 14375) (\TEDIT.DELETETREE 14377 . 17651) (\TEDIT.INSERTTREE 17653 . 20398) ( -\TEDIT.LASTPIECE 20400 . 21207) (\TEDIT.PCTOCH 21209 . 23306) (\TEDIT.CHTOPC 23308 . 29485) ( -\TEDIT.SET-TOTLEN 29487 . 30275) (\TEDIT.MAKE.VACANT.BTREESLOT 30277 . 37007) (\TEDIT.LINKNEWPIECE -37009 . 38598) (\TEDIT.UNLINKPIECE 38600 . 39420) (\TEDIT.SPLITPIECE 39422 . 44078) ( -\TEDIT.INSERTPIECE 44080 . 47352) (\TEDIT.INSERTPIECES 47354 . 50446) (\TEDIT.DELETEPIECES 50448 . -54602) (\TEDIT.ALIGNEDPIECE 54604 . 56717)) (56747 69070 (\TEDIT.BTVALIDATE 56757 . 58298) ( -\TEDIT.BTVALIDATE.PRINT 58300 . 59665) (\TEDIT.CHECK-BTREE 59667 . 61994) (\TEDIT.CHECK-BTREE1 61996 - . 67627) (\TEDIT.BTFAIL 67629 . 68051) (\TEDIT.MATCHPCS 68053 . 69068))))) + (FILEMAP (NIL (8731 56217 (\TEDIT.MAKEPCTB 8741 . 10634) (\TEDIT.UPDATEPCNODES 10636 . 12930) ( +\TEDIT.FIRSTPIECE 12932 . 14339) (\TEDIT.DELETETREE 14341 . 17615) (\TEDIT.INSERTTREE 17617 . 20362) ( +\TEDIT.LASTPIECE 20364 . 21171) (\TEDIT.PCTOCH 21173 . 23270) (\TEDIT.CHTOPC 23272 . 29449) ( +\TEDIT.SET-TOTLEN 29451 . 30239) (\TEDIT.MAKE.VACANT.BTREESLOT 30241 . 36971) (\TEDIT.LINKNEWPIECE +36973 . 38562) (\TEDIT.SPLITPIECE 38564 . 43220) (\TEDIT.INSERTPIECE 43222 . 46494) ( +\TEDIT.INSERTPIECES 46496 . 49588) (\TEDIT.DELETEPIECES 49590 . 54100) (\TEDIT.ALIGNEDPIECE 54102 . +56215)) (56245 68568 (\TEDIT.BTVALIDATE 56255 . 57796) (\TEDIT.BTVALIDATE.PRINT 57798 . 59163) ( +\TEDIT.CHECK-BTREE 59165 . 61492) (\TEDIT.CHECK-BTREE1 61494 . 67125) (\TEDIT.BTFAIL 67127 . 67549) ( +\TEDIT.MATCHPCS 67551 . 68566))))) STOP diff --git a/library/tedit/TEDIT-PCTREE.LCOM b/library/tedit/TEDIT-PCTREE.LCOM index 7f7c0e11..f0cf5a86 100644 Binary files a/library/tedit/TEDIT-PCTREE.LCOM and b/library/tedit/TEDIT-PCTREE.LCOM differ diff --git a/library/tedit/TEDIT-SCREEN b/library/tedit/TEDIT-SCREEN index c5d199f0..4c33bbac 100644 --- a/library/tedit/TEDIT-SCREEN +++ b/library/tedit/TEDIT-SCREEN @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "31-Dec-2025 23:10:18" {WMEDLEY}tedit>TEDIT-SCREEN.;915 186658 +(FILECREATED " 5-Feb-2026 00:39:54" {WMEDLEY}TEDIT>TEDIT-SCREEN.;916 186880 :EDIT-BY rmk - :CHANGES-TO (VARS TEDIT-SCREENCOMS) + :CHANGES-TO (FNS \TEDIT.FORMATLINE) - :PREVIOUS-DATE " 7-Dec-2025 16:28:01" {WMEDLEY}tedit>TEDIT-SCREEN.;914) + :PREVIOUS-DATE "31-Dec-2025 23:10:18" {WMEDLEY}TEDIT>TEDIT-SCREEN.;915) (PRETTYCOMPRINT TEDIT-SCREENCOMS) @@ -654,6 +654,7 @@ (\TEDIT.FORMATLINE [LAMBDA (TSTREAM CH#1 LINE REGION IMAGESTREAM FORMATTINGSTATE) + (* ; "Edited 5-Feb-2026 00:38 by rmk") (* ; "Edited 21-Nov-2025 16:36 by rmk") (* ; "Edited 7-Aug-2025 12:49 by rmk") (* ; "Edited 27-Apr-2025 11:24 by rmk") @@ -706,8 +707,10 @@ (CL:UNLESS LINE (SETQ LINE (create LINEDESCRIPTOR))) (CL:UNLESS IMAGESTREAM - (SETQ IMAGESTREAM (WINDOWPROP (\TEDIT.PRIMARYPANE TSTREAM) - 'DSP))) + (SETQ IMAGESTREAM (CL:IF (\TEDIT.PRIMARYPANE TSTREAM) + (WINDOWPROP (\TEDIT.PRIMARYPANE TSTREAM) + 'DSP) + (DSPCREATE)))) (PROG ((TEXTOBJ (FTEXTOBJ TSTREAM)) (OFFSET 0) (TRUEASCENT -1) @@ -2863,21 +2866,21 @@ (\TEDIT.LINE.TALLP LINE PHEIGHT))))]) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (26200 28416 (\TEDIT.LINEDESCRIPTOR.DEFPRINT 26210 . 28414)) (35870 119502 ( -\TEDIT.FORMATLINE 35880 . 70986) (\TEDIT.FORMATLINE.SETUP.PARA 70988 . 76182) ( -\TEDIT.FORMATLINE.HORIZONTAL 76184 . 81001) (\TEDIT.FORMATLINE.VERTICAL 81003 . 83454) ( -\TEDIT.FORMATLINE.JUSTIFY 83456 . 89477) (\TEDIT.FORMATLINE.TABS 89479 . 97507) (\TEDIT.SCALE.TABS -97509 . 98300) (\TEDIT.FORMATLINE.PURGE.SPACES 98302 . 99729) (\TEDIT.FORMATLINE.FLUSH.SOFTHYPHEN -99731 . 100808) (\TEDIT.FORMATLINE.EMPTY 100810 . 105630) (\TEDIT.FORMATLINE.UPDATELOOKS 105632 . -111813) (\TEDIT.FORMATLINE.LASTLEGAL 111815 . 115265) (\TEDIT.LINES.ABOVE 115267 . 118878) ( -\TEDIT.CHNO.TO.YTOP 118880 . 119500)) (119779 140359 (\TEDIT.DISPLAYLINE 119789 . 132299) ( -\TEDIT.DISPLAYLINE.TABS 132301 . 135105) (\TEDIT.LINECACHE 135107 . 135835) (\TEDIT.CREATE.LINECACHE -135837 . 136673) (\TEDIT.BLTCHAR 136675 . 139302) (\TEDIT.DIACRITIC.SHIFT 139304 . 140357)) (140974 -186635 (\TEDIT.BACKFORMAT 140984 . 143538) (\TEDIT.PREVIOUS.LINEBREAK 143540 . 146343) ( -\TEDIT.UPDATE.LINES 146345 . 152651) (\TEDIT.PANE.CREATELINES 152653 . 154943) ( -\TEDIT.SUFFIXLINE.CREATE 154945 . 156560) (\TEDIT.LINES.BELOW 156562 . 161172) (\TEDIT.MEASURED.LINES -161174 . 163183) (\TEDIT.VALID.LASTCHNOS 163185 . 166961) (\TEDIT.VALID.NEXTCHNOS 166963 . 170437) ( -\TEDIT.LASTVALIDLINE 170439 . 175110) (\TEDIT.NEXTVALIDLINE 175112 . 178082) ( -\TEDIT.CLEARPANE.BELOW.LINE 178084 . 180190) (\TEDIT.INSERTLINE 180192 . 181578) (\TEDIT.LINE.BOTTOM -181580 . 184810) (\TEDIT.SHOW.AT.BOTTOMP 184812 . 185922) (\TEDIT.SHOW.AT.TOPP 185924 . 186633))))) + (FILEMAP (NIL (26200 28416 (\TEDIT.LINEDESCRIPTOR.DEFPRINT 26210 . 28414)) (35870 119724 ( +\TEDIT.FORMATLINE 35880 . 71208) (\TEDIT.FORMATLINE.SETUP.PARA 71210 . 76404) ( +\TEDIT.FORMATLINE.HORIZONTAL 76406 . 81223) (\TEDIT.FORMATLINE.VERTICAL 81225 . 83676) ( +\TEDIT.FORMATLINE.JUSTIFY 83678 . 89699) (\TEDIT.FORMATLINE.TABS 89701 . 97729) (\TEDIT.SCALE.TABS +97731 . 98522) (\TEDIT.FORMATLINE.PURGE.SPACES 98524 . 99951) (\TEDIT.FORMATLINE.FLUSH.SOFTHYPHEN +99953 . 101030) (\TEDIT.FORMATLINE.EMPTY 101032 . 105852) (\TEDIT.FORMATLINE.UPDATELOOKS 105854 . +112035) (\TEDIT.FORMATLINE.LASTLEGAL 112037 . 115487) (\TEDIT.LINES.ABOVE 115489 . 119100) ( +\TEDIT.CHNO.TO.YTOP 119102 . 119722)) (120001 140581 (\TEDIT.DISPLAYLINE 120011 . 132521) ( +\TEDIT.DISPLAYLINE.TABS 132523 . 135327) (\TEDIT.LINECACHE 135329 . 136057) (\TEDIT.CREATE.LINECACHE +136059 . 136895) (\TEDIT.BLTCHAR 136897 . 139524) (\TEDIT.DIACRITIC.SHIFT 139526 . 140579)) (141196 +186857 (\TEDIT.BACKFORMAT 141206 . 143760) (\TEDIT.PREVIOUS.LINEBREAK 143762 . 146565) ( +\TEDIT.UPDATE.LINES 146567 . 152873) (\TEDIT.PANE.CREATELINES 152875 . 155165) ( +\TEDIT.SUFFIXLINE.CREATE 155167 . 156782) (\TEDIT.LINES.BELOW 156784 . 161394) (\TEDIT.MEASURED.LINES +161396 . 163405) (\TEDIT.VALID.LASTCHNOS 163407 . 167183) (\TEDIT.VALID.NEXTCHNOS 167185 . 170659) ( +\TEDIT.LASTVALIDLINE 170661 . 175332) (\TEDIT.NEXTVALIDLINE 175334 . 178304) ( +\TEDIT.CLEARPANE.BELOW.LINE 178306 . 180412) (\TEDIT.INSERTLINE 180414 . 181800) (\TEDIT.LINE.BOTTOM +181802 . 185032) (\TEDIT.SHOW.AT.BOTTOMP 185034 . 186144) (\TEDIT.SHOW.AT.TOPP 186146 . 186855))))) STOP diff --git a/library/tedit/TEDIT-SCREEN.LCOM b/library/tedit/TEDIT-SCREEN.LCOM index 5181485e..93232968 100644 Binary files a/library/tedit/TEDIT-SCREEN.LCOM and b/library/tedit/TEDIT-SCREEN.LCOM differ diff --git a/library/tedit/TEDIT-SELECTION b/library/tedit/TEDIT-SELECTION index c6a90222..6c5bab83 100644 --- a/library/tedit/TEDIT-SELECTION +++ b/library/tedit/TEDIT-SELECTION @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Jul-2025 11:22:10" {WMEDLEY}tedit>TEDIT-SELECTION.;731 161124 +(FILECREATED "16-Feb-2026 00:38:33" {WMEDLEY}TEDIT>TEDIT-SELECTION.;738 162152 :EDIT-BY rmk - :CHANGES-TO (FNS \TEDIT.FIND.PROTECTED.START \TEDIT.FIND.PROTECTED.END) + :CHANGES-TO (FNS \TEDIT.SELPIECES.CHARTRANSFORM) - :PREVIOUS-DATE "28-Jul-2025 23:50:43" {WMEDLEY}tedit>TEDIT-SELECTION.;730) + :PREVIOUS-DATE "14-Jan-2026 14:32:01" {WMEDLEY}tedit>TEDIT-SELECTION.;736) (PRETTYCOMPRINT TEDIT-SELECTIONCOMS) @@ -73,8 +73,7 @@ (* ;; "If DCH=0, this is a caret-only selection, with no highlighting. In that case CHLIM=(ADD1 CH#) and POINT essentially indicates whether the caret blinks before or after CH#.") - NIL (* ; - "Was Y0: Y value of topmost line of selection") + SELOPERATION (* ; "NORMAL, MOVE, COPY... HOW and HOWHEIGHT are derived from the operation. Was Y0: Y value of topmost line of selection") X0 (* ;  "X value of left edge of selection on the first line") SELLINES (* ; "A list of (L1 L2) pairs one for each pane, to replace the separate L1 L2 lists. Was DX: Width of the selection, if it's on one line.") @@ -1214,7 +1213,8 @@ (SETTOBJ TEXTOBJ BLUEPENDINGDELETE NIL]) (\TEDIT.SET.SEL.LOOKS - [LAMBDA (SEL OPERATION) (* ; "Edited 6-May-2025 11:32 by rmk") + [LAMBDA (SEL OPERATION) (* ; "Edited 10-Jan-2026 12:30 by rmk") + (* ; "Edited 6-May-2025 11:32 by rmk") (* ; "Edited 28-Feb-2025 17:45 by rmk") (* ; "Edited 7-Nov-2024 21:50 by rmk") (* ; "Edited 4-Oct-2024 08:40 by rmk") @@ -1260,6 +1260,7 @@ (FSETSEL SEL HASCARET T)) (NIL) (\TEDIT.THELP "UNKNOWN SELECTION OPERATION" OPERATION)) + (FSETSEL SEL SELOPERATION OPERATION) SEL]) ) (DECLARE%: EVAL@COMPILE DONTCOPY @@ -1421,7 +1422,8 @@ 'INVERT) repeatuntil (EQ L LN]) (\TEDIT.UPDATE.SEL - [LAMBDA (TSTREAM/SEL CH# DCH POINT LOOKS CHLIM) (* ; "Edited 6-May-2025 11:36 by rmk") + [LAMBDA (TSTREAM/SEL CH# DCH POINT LOOKS CHLIM) (* ; "Edited 6-Jan-2026 20:18 by rmk") + (* ; "Edited 6-May-2025 11:36 by rmk") (* ; "Edited 21-Apr-2025 22:50 by rmk") (* ; "Edited 6-Apr-2025 11:47 by rmk") (* ; "Edited 10-Jul-2024 17:25 by rmk") @@ -1458,6 +1460,13 @@ (CL:UNLESS POINT (SETQ POINT (GETTH CH# THPOINT CH#))) (SETQ CH# (GETTH CH# THCH#)) + elseif (LISTP CH#) + then (CL:UNLESS DCH + (SETQ DCH (CADR CH#))) + (CL:UNLESS POINT + (SETQ POINT (CADDR CH#))) + (CL:UNLESS CH# + (SETQ POINT (CAR CH#))) else (* ;;  "Get defaults from SEL (either a selection or a textobj whose SEL is indicated)") @@ -1611,7 +1620,8 @@ (DEFINEQ (\TEDIT.COPYSEL - [LAMBDA (FROM TO) (* ; "Edited 3-Sep-2024 22:44 by rmk") + [LAMBDA (FROM TO) (* ; "Edited 11-Jan-2026 00:17 by rmk") + (* ; "Edited 3-Sep-2024 22:44 by rmk") (* ; "Edited 7-Jul-2024 11:21 by rmk") (* ; "Edited 30-Jun-2024 23:21 by rmk") (* ; "Edited 29-Apr-2024 12:35 by rmk") @@ -1644,6 +1654,7 @@ (FSETSEL TO HASCARET (FGETSEL FROM HASCARET)) (FSETSEL TO SELOBJ (FGETSEL FROM SELOBJ)) (FSETSEL TO ONFLG (FGETSEL FROM ONFLG)) + (FSETSEL TO SELOPERATION (FGETSEL FROM SELOPERATION)) else (SETQ TO (create SELECTION using FROM SELTEXTSTREAM _ NIL L1 _ (COPY (FGETSEL FROM L1)) LN _ (COPY (FGETSEL FROM LN)) SELLINES _ (COPY (FGETSEL FROM SELLINES] @@ -2030,7 +2041,8 @@ SPLASTCHAR _ (ffetch (SELPIECES SPLASTCHAR) of SP2]) (\TEDIT.SELPIECES.CHARTRANSFORM - [LAMBDA (SELPIECES CHARFN OBJECTSTOO TSTREAM) (* ; "Edited 24-Apr-2025 16:02 by rmk") + [LAMBDA (SELPIECES CHARFN OBJECTSTOO TSTREAM) (* ; "Edited 16-Feb-2026 00:38 by rmk") + (* ; "Edited 24-Apr-2025 16:02 by rmk") (* ; "Edited 20-Apr-2025 23:23 by rmk") (* ; "Edited 16-Mar-2025 10:03 by rmk") (* ; "Edited 7-Nov-2024 21:50 by rmk") @@ -2055,10 +2067,10 @@ (* ;; "This assumes that no file piece has a PLEN greater than \MaxArrayLen characters. We rely on the piece-table reader and writer to guarantee this. If not, ALLOCSTRING will cause an error.") - [for I from 1 to (PLEN PC) - do (RPLCHARCODE STR I (APPLY* CHARFN (\TEDIT.PIECE.NTHCHARCODE - PC I) - (add INDEX 1] + [for I from 0 to (PLAST PC) + do (RPLCHARCODE STR (ADD1 I) + (APPLY* CHARFN (\TEDIT.PIECE.NTHCHARCODE PC I) + (add INDEX 1] (if (fetch (STRINGP FATSTRINGP) of STR) then (FSETPC PC PTYPE FATSTRING.PTYPE) (FSETPC PC PBYTESPERCHAR 2) @@ -2237,7 +2249,8 @@ (FGETSEL SCRSEL CH#]) (TEDIT.SELPROP - [LAMBDA X (* ; "Edited 28-Feb-2025 17:14 by rmk") + [LAMBDA X (* ; "Edited 11-Jan-2026 00:18 by rmk") + (* ; "Edited 28-Feb-2025 17:14 by rmk") (* ; "Edited 6-Feb-2025 16:48 by rmk") (* ; "Edited 31-Oct-2024 18:00 by rmk") (* ; "Edited 23-Sep-2024 23:11 by rmk") @@ -2277,6 +2290,7 @@ (TEXTSTREAM (FGETSEL SEL SELTEXTSTREAM)) (SHADE (FGETSEL SEL HOW)) (SHADEHEIGHT (FGETSEL SEL HOWHEIGHT)) + (SELOPERATION (FGETSEL SEL SELOPERATION)) (SET (FGETSEL SEL SET)) (\ILLEGAL.ARG PROP)) (CL:WHEN (IGREATERP X 2) @@ -2296,6 +2310,7 @@ (CHLIM (\TEDIT.UPDATE.SEL SEL NIL (IDIFFERENCE NEWVALUE (FGETSEL SEL CH#)))) (SHADE (FSETSEL SEL HOW NEWVALUE)) (SHADEHEIGHT (FSETSEL SEL HOWHEIGHT NEWVALUE)) + (SELOPERATION (\TEDIT.SET.SEL.LOOKS SEL NEWVALUE)) (SET (FSETSEL SEL SET NEWVALUE)) (\ILLEGAL.ARG PROP)) (CL:WHEN (FGETSEL SEL SELTEXTSTREAM) @@ -2556,26 +2571,26 @@ (ADDTOVAR LAMA TEDIT.SELPROP) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (15897 17718 (\TEDIT.SELECTION.DEFPRINT 15907 . 17716)) (17755 19260 ( -\TEDIT.SET.GLOBAL.SELECTIONS 17765 . 19258)) (19261 25482 (\TEDIT.SELECTED.PIECES 19271 . 20910) ( -\TEDIT.FIND.PROTECTED.END 20912 . 22706) (\TEDIT.FIND.PROTECTED.START 22708 . 24691) ( -\TEDIT.WORD.BOUND 24693 . 25480)) (25616 59723 (\TEDIT.EXTEND.SEL 25626 . 32866) (\TEDIT.SCAN.LINE -32868 . 44541) (\TEDIT.SCAN.LINE.WORD 44543 . 49536) (\TEDIT.XYTOSEL 49538 . 56876) (\TEDIT.REGIONTYPE - 56878 . 57897) (\TEDIT.XYTOSEL.INLINEP 57899 . 58354) (\TEDIT.XYTOSEL.LINE 58356 . 59721)) (59724 -73269 (\TEDIT.FIXSEL 59734 . 69111) (\TEDIT.CHTOLINEX 69113 . 73267)) (73270 77324 ( -\TEDIT.RESET.EXTEND.PENDING.DELETE 73280 . 74558) (\TEDIT.SET.SEL.LOOKS 74560 . 77322)) (78261 99027 ( -\TEDIT.SHOWSEL 78271 . 83247) (\TEDIT.NOSEL 83249 . 83550) (\TEDIT.SEL.OFF 83552 . 83963) ( -\TEDIT.SEL.ON 83965 . 84381) (\TEDIT.SHOWSEL.HILIGHT 84383 . 89004) (\TEDIT.UPDATE.SEL 89006 . 93221) -(\TEDIT.CARETLINE 93223 . 93937) (\TEDIT.SEL.L1 93939 . 94622) (\TEDIT.SEL.LN 94624 . 95307) ( -\TEDIT.SEL.DELETEDCHARS 95309 . 99025)) (99028 103734 (\TEDIT.COPYSEL 99038 . 101504) ( -\TEDIT.SEL.CHANGED? 101506 . 103732)) (103765 117424 (\TEDIT.SELECT.OBJECT 103775 . 108728) ( -\TEDIT.SHOWSEL.OBJECT 108730 . 110961) (\TEDIT.CLIP.OBJECT 110963 . 112967) (\TEDIT.OPERATE.OBJECT -112969 . 117422)) (117452 137201 (\TEDIT.SELPIECES 117462 . 121743) (\TEDIT.SELPIECES.COPY 121745 . -124234) (\TEDIT.SELPIECES.CONCAT 124236 . 126115) (\TEDIT.SELPIECES.CHARTRANSFORM 126117 . 129576) ( -\TEDIT.SELPIECES.FROM.STRING 129578 . 134836) (\TEDIT.SELPIECES.TO.STRING 134838 . 137199)) (137254 -160955 (TEDIT.XYTOCH 137264 . 139840) (TEDIT.SELPROP 139842 . 143872) (TEDIT.GETPOINT 143874 . 145794) - (TEDIT.GETSEL 145796 . 146672) (TEDIT.GETSEL.PARA 146674 . 147623) (TEDIT.SCANSEL 147625 . 148573) ( -TEDIT.SET.SEL.LOOKS 148575 . 150060) (TEDIT.SETSEL 150062 . 154980) (TEDIT.SHOWSEL 154982 . 156846) ( -TEDIT.SEL.AS.STRING 156848 . 159333) (TEDIT.SEL.AS.SEXPR 159335 . 160621) (TEDIT.SELECTALL 160623 . -160953))))) + (FILEMAP (NIL (15888 17709 (\TEDIT.SELECTION.DEFPRINT 15898 . 17707)) (17746 19251 ( +\TEDIT.SET.GLOBAL.SELECTIONS 17756 . 19249)) (19252 25473 (\TEDIT.SELECTED.PIECES 19262 . 20901) ( +\TEDIT.FIND.PROTECTED.END 20903 . 22697) (\TEDIT.FIND.PROTECTED.START 22699 . 24682) ( +\TEDIT.WORD.BOUND 24684 . 25471)) (25607 59714 (\TEDIT.EXTEND.SEL 25617 . 32857) (\TEDIT.SCAN.LINE +32859 . 44532) (\TEDIT.SCAN.LINE.WORD 44534 . 49527) (\TEDIT.XYTOSEL 49529 . 56867) (\TEDIT.REGIONTYPE + 56869 . 57888) (\TEDIT.XYTOSEL.INLINEP 57890 . 58345) (\TEDIT.XYTOSEL.LINE 58347 . 59712)) (59715 +73260 (\TEDIT.FIXSEL 59725 . 69102) (\TEDIT.CHTOLINEX 69104 . 73258)) (73261 77465 ( +\TEDIT.RESET.EXTEND.PENDING.DELETE 73271 . 74549) (\TEDIT.SET.SEL.LOOKS 74551 . 77463)) (78402 99555 ( +\TEDIT.SHOWSEL 78412 . 83388) (\TEDIT.NOSEL 83390 . 83691) (\TEDIT.SEL.OFF 83693 . 84104) ( +\TEDIT.SEL.ON 84106 . 84522) (\TEDIT.SHOWSEL.HILIGHT 84524 . 89145) (\TEDIT.UPDATE.SEL 89147 . 93749) +(\TEDIT.CARETLINE 93751 . 94465) (\TEDIT.SEL.L1 94467 . 95150) (\TEDIT.SEL.LN 95152 . 95835) ( +\TEDIT.SEL.DELETEDCHARS 95837 . 99553)) (99556 104438 (\TEDIT.COPYSEL 99566 . 102208) ( +\TEDIT.SEL.CHANGED? 102210 . 104436)) (104469 118128 (\TEDIT.SELECT.OBJECT 104479 . 109432) ( +\TEDIT.SHOWSEL.OBJECT 109434 . 111665) (\TEDIT.CLIP.OBJECT 111667 . 113671) (\TEDIT.OPERATE.OBJECT +113673 . 118126)) (118156 137982 (\TEDIT.SELPIECES 118166 . 122447) (\TEDIT.SELPIECES.COPY 122449 . +124938) (\TEDIT.SELPIECES.CONCAT 124940 . 126819) (\TEDIT.SELPIECES.CHARTRANSFORM 126821 . 130357) ( +\TEDIT.SELPIECES.FROM.STRING 130359 . 135617) (\TEDIT.SELPIECES.TO.STRING 135619 . 137980)) (138035 +161983 (TEDIT.XYTOCH 138045 . 140621) (TEDIT.SELPROP 140623 . 144900) (TEDIT.GETPOINT 144902 . 146822) + (TEDIT.GETSEL 146824 . 147700) (TEDIT.GETSEL.PARA 147702 . 148651) (TEDIT.SCANSEL 148653 . 149601) ( +TEDIT.SET.SEL.LOOKS 149603 . 151088) (TEDIT.SETSEL 151090 . 156008) (TEDIT.SHOWSEL 156010 . 157874) ( +TEDIT.SEL.AS.STRING 157876 . 160361) (TEDIT.SEL.AS.SEXPR 160363 . 161649) (TEDIT.SELECTALL 161651 . +161981))))) STOP diff --git a/library/tedit/TEDIT-SELECTION.LCOM b/library/tedit/TEDIT-SELECTION.LCOM index 466a0b7f..1317c79c 100644 Binary files a/library/tedit/TEDIT-SELECTION.LCOM and b/library/tedit/TEDIT-SELECTION.LCOM differ diff --git a/library/tedit/TEDIT-STREAM b/library/tedit/TEDIT-STREAM index de978046..f88ae2ae 100644 --- a/library/tedit/TEDIT-STREAM +++ b/library/tedit/TEDIT-STREAM @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 2-Dec-2025 17:50:45" {WMEDLEY}tedit>TEDIT-STREAM.;930 194007 +(FILECREATED "16-Feb-2026 12:40:44" {WMEDLEY}tedit>TEDIT-STREAM.;944 193110 :EDIT-BY rmk - :CHANGES-TO (FNS OPENTEXTSTREAM \TEDIT.OPENTEXTFILE) + :CHANGES-TO (FNS \TEDIT.STREAMINIT) - :PREVIOUS-DATE "19-Oct-2025 15:09:09" {WMEDLEY}TEDIT>TEDIT-STREAM.;927) + :PREVIOUS-DATE "16-Feb-2026 09:39:00" {WMEDLEY}tedit>TEDIT-STREAM.;943) (PRETTYCOMPRINT TEDIT-STREAMCOMS) @@ -14,8 +14,8 @@ (RPAQQ TEDIT-STREAMCOMS [(DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS PIECE TEXTOBJ TEXTSTREAM) - (MACROS NEXTPIECE PREVPIECE PLEN PTYPE PCONTENTS PCHARLOOKS PCHARSET PPARALOOKS - PPARALAST PFPOS PBYTELEN PNEW PBINABLE PBYTESPERCHAR POBJ) + (MACROS NEXTPIECE PREVPIECE PLEN PLAST PTYPE PCONTENTS PCHARLOOKS PCHARSET + PPARALOOKS PPARALAST PFPOS PBYTELEN PNEW PBINABLE PBYTESPERCHAR POBJ) (MACROS SETPC FSETPC GETPC FGETPC) (MACROS THINPIECEP) (MACROS VISIBLEPIECEP \NEXT.VISIBLE.PIECE \PREV.VISIBLE.PIECE) @@ -43,7 +43,9 @@ (FNS \TEDIT.REOPENTEXTSTREAM \TEDIT.OPENTEXTSTREAM.PIECES \TEDIT.OPENTEXTSTREAM.PROPS \TEDIT.OPENTEXTSTREAM.SETUP.SEL \TEDIT.OPENTEXTSTREAM.WINDOW \TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS \TEDIT.OPENTEXTFILE \TEDIT.CREATE.TEXTSTREAM - \TEDIT.REOPEN.STREAM \TEDIT.TEXTINIT) + \TEDIT.REOPEN.STREAM) + (FNS \TEDIT.STREAMINIT TEDIT.IMAGESTREAM.OPEN) + (ALISTS (IMAGESTREAMTYPES TEDIT)) (* ;; "Is this being used:") @@ -69,10 +71,7 @@ (MACROS \INSERTCH.EXTENDABLE)) (FNS \TEDIT.DELETE.SELPIECES \TEDIT.INSERTCH \TEDIT.INSERTCH.HISTORY \TEDIT.INSERTEOL \TEDIT.INSERTCH.INSERTION \TEDIT.INSERTCH.EXTEND) - (FNS \TEDIT.NEXTCHANGEABLE.CHNO \TEDIT.LASTCHANGEABLE.CHNO) - (FNS \SETUPGETCH)) - (* ; - "Deprecated, maybe still external callers") + (FNS \TEDIT.NEXTCHANGEABLE.CHNO \TEDIT.LASTCHANGEABLE.CHNO)) (FNS \TEDIT.INSTALL.PIECE) [COMS (* ; "Support for TEXTPROP") (FNS TEXTPROP GETTEXTPROP PUTTEXTPROP GETTEXTPROPS PUTTEXTPROPS TEXTPROP.ADD @@ -83,7 +82,7 @@ (ADDVARS (INSPECTMACROS (TEXTOBJ \TEDIT.TEXTOBJ.PROPNAMES \TEDIT.TEXTOBJ.PROPFETCHFN \TEDIT.TEXTOBJ.PROPSTOREFN] - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEDIT.TEXTINIT))) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEDIT.STREAMINIT))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA TEXTPROP]) @@ -158,8 +157,7 @@  "The current selection within the text") LASTARROWX (* ;  "X for next arrow up or arrow down. Was: Scratch space for the selection code") - NIL (* ; - "Was MOVESEL: Source for the next MOVE of text") + SECONDARYSEL (* ; "Holds secondary selection and operation just before the mouse leaves a window. Was MOVESEL: Source for the next MOVE of text") NIL (* ;  "Was SHIFTEDSEL: Source for the next COPY") NIL (* ; @@ -395,6 +393,9 @@ (PUTPROPS PLEN MACRO ((PC) (ffetch (PIECE PLEN) of PC))) +(PUTPROPS PLAST MACRO ((PC) + (SUB1 (PLEN PC)))) + (PUTPROPS PTYPE MACRO ((PC) (ffetch (PIECE PTYPE) of PC))) @@ -922,7 +923,8 @@ else (STREAMOP 'ENDOFSTREAMOP TSTREAM TSTREAM]) (\TEDIT.TEXTBACKFILEPTR - [LAMBDA (TSTREAM) (* ; "Edited 21-Oct-2024 00:33 by rmk") + [LAMBDA (TSTREAM) (* ; "Edited 16-Feb-2026 08:54 by rmk") + (* ; "Edited 21-Oct-2024 00:33 by rmk") (* ; "Edited 1-Feb-2024 11:25 by rmk") (* ; "Edited 5-Jan-2024 17:57 by rmk") (* ; "Edited 28-Dec-2023 13:34 by rmk") @@ -954,7 +956,7 @@ then (CL:WHEN (SETQ PPC (\PREV.VISIBLE.PIECE PC)) (* ;  "Back up to last char of previous piece, if any.") - (\TEDIT.INSTALL.PIECE TSTREAM PPC (SUB1 (PLEN PPC))) + (\TEDIT.INSTALL.PIECE TSTREAM PPC (PLAST PPC)) (SETQ PC PPC)) elseif (AND (MEMB (PTYPE PC) FILE.PTYPES) @@ -1519,7 +1521,8 @@ (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS TEXTOBJ]) (\TEDIT.OPENTEXTSTREAM.SETUP.SEL - [LAMBDA (TSTREAM) (* ; "Edited 21-Apr-2025 20:14 by rmk") + [LAMBDA (TSTREAM) (* ; "Edited 10-Jan-2026 23:53 by rmk") + (* ; "Edited 21-Apr-2025 20:14 by rmk") (* ; "Edited 6-Apr-2025 14:24 by rmk") (* ; "Edited 17-Feb-2025 08:56 by rmk") (* ; "Edited 25-Nov-2024 14:33 by rmk") @@ -1562,20 +1565,22 @@ (OR (CADR SELPROP) 0) (OR (CADDR SELPROP) - 'LEFT)) + 'LEFT) + 'NORMAL) elseif (FIXP SELPROP) - then (\TEDIT.UPDATE.SEL SEL SELPROP 0 'LEFT) + then (\TEDIT.UPDATE.SEL SEL SELPROP 0 'LEFT 'NORMAL) elseif (FGETTOBJ TEXTOBJ TXTAPPENDONLY) then (* ;; "Default to after the last character") (\TEDIT.UPDATE.SEL SEL (FGETTOBJ TEXTOBJ TEXTLEN) 0 - 'RIGHT) + 'RIGHT + 'NORMAL) else (* ;; "Default to before the first character. UPDATE.SEL screws up the CHLIM=CH#+DCH invariant when DCH=0, it adds 1, But UPDATE.SEL adds 1 when DCH=0. That's wrong for the initial caret, so brute-force fix it here. Maybe it's wrong in general?") - (\TEDIT.UPDATE.SEL SEL 1 0 'LEFT) + (\TEDIT.UPDATE.SEL SEL 1 0 'LEFT 'NORMAL) (FSETSEL SEL CHLIM 1)) [FSETTOBJ TEXTOBJ CARETLOOKS (if (FGETSEL SEL SET) then (* ; @@ -1751,9 +1756,13 @@ (* ;; "Return the new value for the stream:") NEWSTREAM]) +) +(DEFINEQ -(\TEDIT.TEXTINIT - [LAMBDA NIL (* ; "Edited 23-Sep-2025 21:03 by rmk") +(\TEDIT.STREAMINIT + [LAMBDA NIL (* ; "Edited 16-Feb-2026 12:40 by rmk") + (* ; "Edited 26-Jan-2026 16:06 by rmk") + (* ; "Edited 23-Sep-2025 21:03 by rmk") (* ; "Edited 20-Sep-2025 08:48 by rmk") (* ; "Edited 18-Sep-2025 14:52 by rmk") (* ; "Edited 10-Jul-2025 11:28 by rmk") @@ -1807,17 +1816,9 @@ IMSCALE _ [FUNCTION (LAMBDA NIL 1] IMCOLOR _ (FUNCTION \TEDIT.TEXTCOLOR))) - (* ;; "Do we need TEXT here?") - - (FONTPROFILE.ADDDEVICE 'TEXT 'DISPLAY) - (ADDTOVAR IMAGESTREAMTYPES (TEXT (FONTCREATE \CREATEDISPLAYFONT) - (CREATECHARSET \CREATECHARSET.DISPLAY))) - (ADDTOVAR IMAGESTREAMTYPES (TEDIT (FONTCREATE \CREATEDISPLAYFONT) - (CREATECHARSET \CREATECHARSET.DISPLAY))) - (* ;; "Maybe more functions later. The INCODE and BACK functions possibly need to count. If \TEXTBACKFILEPTR takes a count variable, the extra level wouldn't be needed. But INCCODE wants to go through the BIN opcode") - (MAKE-EXTERNALFORMAT :TEXTSTREAM (FUNCTION \TEDIT.TEXTINCCODEFN) + (MAKE-EXTERNALFORMAT :TEDIT (FUNCTION \TEDIT.TEXTINCCODEFN) (FUNCTION \TEDIT.TEXTPEEKBIN) (FUNCTION \TEDIT.TEXTBACKCCODEFN) (FUNCTION \TEDIT.TEXTOUTCHARFN) @@ -1860,8 +1861,7 @@ FDEXTENDABLE _ NIL TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION NILL) - DEFAULTEXTERNALFORMAT _ :TEXTSTREAM)) - (* ; + DEFAULTEXTERNALFORMAT _ :TEDIT)) (* ;  "Only load once, not every time TEDIT-STREAM is loaded e.g. in development") (RPAQ? *TEDIT-OLD-STREAM-ERROR-HANDLER* (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN)) (CL:SETF (CONDITION-HANDLER 'XCL:STREAM-NOT-OPEN) @@ -1881,8 +1881,15 @@ (* ;  "Some other kind of stream, so punt to the old handler (if there is one):") (APPLY* *TEDIT-OLD-STREAM-ERROR-HANDLER* CONDITION]) + +(TEDIT.IMAGESTREAM.OPEN + [LAMBDA (FILE OPTIONS) (* ; "Edited 26-Jan-2026 23:55 by rmk") + (OPENTEXTSTREAM FILE NIL OPTIONS]) ) +(ADDTOVAR IMAGESTREAMTYPES (TEDIT (OPENSTREAM TEDIT.IMAGESTREAM.OPEN) + (CREATECHARSET \CREATECHARSET.DISPLAY))) + (* ;; "Is this being used:") @@ -2249,7 +2256,8 @@ (DEFINEQ (\TEDIT.NTHCHARCODE - [LAMBDA (TSTREAM N) (* ; "Edited 24-Apr-2025 16:03 by rmk") + [LAMBDA (TSTREAM N) (* ; "Edited 15-Feb-2026 14:40 by rmk") + (* ; "Edited 24-Apr-2025 16:03 by rmk") (* ; "Edited 28-Mar-2025 18:31 by rmk") (* ; "Edited 7-Jul-2024 11:09 by rmk") (* ; "Edited 29-Apr-2024 13:06 by rmk") @@ -2266,11 +2274,11 @@ (CL:WHEN (AND (IGEQ N 1) (ILEQ N (FGETTOBJ TEXTOBJ TEXTLEN))) (\TEDIT.PIECE.NTHCHARCODE (\TEDIT.CHTOPC N TEXTOBJ T) - (IDIFFERENCE (ADD1 N) - START-OF-PIECE)))]) + (IDIFFERENCE N START-OF-PIECE)))]) (\TEDIT.PIECE.NTHCHARCODE - [LAMBDA (PC OFFSET) (* ; "Edited 24-Apr-2025 16:04 by rmk") + [LAMBDA (PC OFFSET) (* ; "Edited 15-Feb-2026 14:31 by rmk") + (* ; "Edited 24-Apr-2025 16:04 by rmk") (* ; "Edited 21-Oct-2024 00:26 by rmk") (* ; "Edited 29-Apr-2024 08:46 by rmk") (* ; "Edited 22-Mar-2024 00:02 by rmk") @@ -2282,24 +2290,24 @@ (* ; "Edited 8-Nov-2023 08:43 by rmk") (* ; "Edited 5-Nov-2023 08:17 by rmk") - (* ;; "Returns the OFFSETth charcode of PC, NIL if OFFSET is out of bounds. For file pieces, ensures that the backing stream is restored to its original position, so that it remains comaptible with the values (buffer, offset) in the textstream.") + (* ;; "Returns the OFFSETth charcode of PC, NIL if OFFSET is out of bounds. For file pieces, ensures that the backing stream is restored to its original position, so that it remains comaptible with the values (buffer, offset) in the textstream. OFFSET ranges from 0 to PLEN-1.") - (CL:WHEN (AND (IGEQ OFFSET 1) - (ILEQ OFFSET (PLEN PC))) + (CL:WHEN (AND (IGEQ OFFSET 0) + (ILESSP OFFSET (PLEN PC))) [LET ((PCONTENTS (PCONTENTS PC)) FILEPOS) (SELECTC (PTYPE PC) - (STRING.PTYPES (NTHCHARCODE PCONTENTS OFFSET)) + (STRING.PTYPES (NTHCHARCODE PCONTENTS (ADD1 OFFSET))) (THINFILE.PTYPE (SETQ FILEPOS (\GETFILEPTR PCONTENTS)) (\SETFILEPTR PCONTENTS (IPLUS (PFPOS PC) - (SUB1 OFFSET))) + OFFSET)) (PROG1 (BIN PCONTENTS) (\SETFILEPTR PCONTENTS FILEPOS))) (FATFILE1.PTYPE (SETQ FILEPOS (\GETFILEPTR PCONTENTS)) (\SETFILEPTR PCONTENTS (IPLUS (PFPOS PC) - (SUB1 OFFSET))) + OFFSET)) (PROG1 (create WORD HIBYTE _ (PCHARSET PC) LOBYTE _ (BIN PCONTENTS)) @@ -2307,14 +2315,12 @@ (FATFILE2.PTYPE (SETQ FILEPOS (\GETFILEPTR PCONTENTS)) (\SETFILEPTR PCONTENTS (IPLUS (PFPOS PC) - (UNFOLD (SUB1 OFFSET) - 2))) + (UNFOLD OFFSET 2))) (PROG1 (\WIN PCONTENTS) (\SETFILEPTR PCONTENTS FILEPOS))) (UTF8.PTYPE (SETQ FILEPOS (\GETFILEPTR PCONTENTS)) [\SETFILEPTR PCONTENTS (IPLUS (PFPOS PC) - (ITIMES (SUB1 OFFSET) - (PBYTESPERCHAR PC] + (ITIMES OFFSET (PBYTESPERCHAR PC] (PROG1 (UTF8.INCCODEFN PCONTENTS) (\SETFILEPTR PCONTENTS FILEPOS))) (OBJECT.PTYPE PCONTENTS) @@ -2327,7 +2333,8 @@ (\TEDIT.THELP '\TEDIT.PIECE.NTHCHARCODE])]) (\TEDIT.RPLCHARCODE - [LAMBDA (TSTREAM N NEWCHARCODE NEWCHARLOOKS DONTDISPLAY) (* ; "Edited 24-Apr-2025 17:24 by rmk") + [LAMBDA (TSTREAM N NEWCHARCODE NEWCHARLOOKS DONTDISPLAY) (* ; "Edited 16-Feb-2026 08:37 by rmk") + (* ; "Edited 24-Apr-2025 17:24 by rmk") (* ; "Edited 20-Apr-2025 13:25 by rmk") (* ; "Edited 28-Mar-2025 10:04 by rmk") @@ -2343,16 +2350,17 @@ (DECLARE (SPECVARS START-OF-PIECE)) (replace (STREAM BINABLE) of TSTREAM with NIL) (SETQ OLDCHAR (\TEDIT.PIECE.RPLCHARCODE TEXTOBJ (\TEDIT.CHTOPC N TEXTOBJ T) - (ADD1 (IDIFFERENCE N START-OF-PIECE)) + (IDIFFERENCE N START-OF-PIECE) NEWCHARCODE NEWCHARLOOKS)) - (\TEDIT.HISTORYADD TEXTOBJ (\TEDIT.HISTORY.EVENT TEXTOBJ :ReplaceCode N NIL NIL NIL + (\TEDIT.HISTORYADD TEXTOBJ (\TEDIT.HISTORY.EVENT TEXTOBJ :ReplaceCode N 1 NIL NIL OLDCHAR)) (CL:UNLESS (OR DONTDISPLAY (NOT (\TEDIT.PRIMARYPANE TEXTOBJ))) (\TEDIT.UPDATE.LINES TSTREAM 'CHANGED N 1)) TSTREAM))]) (\TEDIT.PIECE.RPLCHARCODE - [LAMBDA (TEXTOBJ PC OFFSET NEWCHARCODE NEWCHARLOOKS) (* ; "Edited 28-Jul-2025 23:38 by rmk") + [LAMBDA (TEXTOBJ PC OFFSET NEWCHARCODE NEWCHARLOOKS) (* ; "Edited 16-Feb-2026 08:41 by rmk") + (* ; "Edited 28-Jul-2025 23:38 by rmk") (* ; "Edited 24-Apr-2025 16:30 by rmk") (* ; "Edited 20-Apr-2025 13:25 by rmk") (* ; "Edited 28-Mar-2025 10:04 by rmk") @@ -2377,12 +2385,13 @@  "Fast case: Smash a new character code into an existing string piece with same looks. ") (SETQ OLDCHAR (NTHCHARCODE (PCONTENTS PC) - OFFSET)) + (ADD1 OFFSET))) (RPLCHARCODE (PCONTENTS PC) - OFFSET NEWCHARCODE) (* ; + (ADD1 OFFSET) + NEWCHARCODE) (* ;  "May upgrade string from thin to fat") (CL:WHEN (AND (EQ THINSTRING.PTYPE (PTYPE PC)) - (IGREATERP NEWCHARCODE 255)) + (IGREATERP NEWCHARCODE \MAXTHINCHAR)) (FSETPC PC PTYPE FATSTRING.PTYPE) (FSETPC PC PBINABLE NIL) (FSETPC PC PBYTESPERCHAR 2) @@ -2396,24 +2405,25 @@ (FSETPC PC PCONTENTS NEWCHARCODE) else (* ;; - "PC contained character OFFSET now becomes the suffix of characters after offset.") + "The PC that contained character OFFSET now becomes the suffix of characters after offset.") - (CL:UNLESS (IEQP OFFSET (PLEN PC)) (* ; "No suffix for the last character") + (CL:UNLESS (IEQP OFFSET (PLAST PC)) (* ; "No suffix for the last character") (* ;;  "Chop off the suffix (essentially (\TEDIT.ALIGNEDPIECE CHNO ..) but we already have the piece") - (\TEDIT.SPLITPIECE PC OFFSET TEXTOBJ) + (\TEDIT.SPLITPIECE PC (ADD1 OFFSET) + TEXTOBJ) (SETQ PC (PREVPIECE PC))) (* ;  "Original PC holds the suffix, new PC ends with change position.") - (CL:UNLESS (EQ OFFSET 1) + (CL:UNLESS (EQ OFFSET 0) (SETQ PC (\TEDIT.SPLITPIECE PC (SUB1 OFFSET) TEXTOBJ))) (* ;  "Chop off the prefix. PC is now the singleton target ") (* ;; "OFFSET is now isolated into a one-character new piece which we smash. ") - (SETQ OLDCHAR (\TEDIT.PIECE.NTHCHARCODE PC 1)) + (SETQ OLDCHAR (\TEDIT.PIECE.NTHCHARCODE PC 0)) (if (IMAGEOBJP NEWCHARCODE) then (FSETPC PC PBINABLE NIL) (FSETPC PC PCONTENTS NEWCHARCODE) @@ -2423,7 +2433,7 @@ else (FSETPC PC PCONTENTS (MKSTRING (CHARACTER NEWCHARCODE))) (* ;  "Use the extend-string in INSERTCH for repeated calls?") - (if (IGREATERP NEWCHARCODE 255) + (if (IGREATERP NEWCHARCODE \MAXTHINCHAR) then (FSETPC PC PTYPE FATSTRING.PTYPE) (FSETPC PC PBINABLE NIL) (FSETPC PC PBYTESPERCHAR 2) @@ -2810,7 +2820,8 @@ else (SUB1 (\TEDIT.PCTOCH PC TEXTOBJ]) (\TEDIT.LASTCHANGEABLE.CHNO - [LAMBDA (CHNO TEXTOBJ) (* ; "Edited 26-Nov-2024 00:00 by rmk") + [LAMBDA (CHNO TEXTOBJ) (* ; "Edited 16-Feb-2026 08:53 by rmk") + (* ; "Edited 26-Nov-2024 00:00 by rmk") (* ;; "Returns the number of the first visible character at or before CHNO, NIL if the first visible character is protected. Almost always CHNO--PCTOCH is the unusual case.") @@ -2819,46 +2830,11 @@ CLPROTECTED) when (VISIBLEPIECEP PC) do (RETURN (if (EQ PC FIRSTPIECE) then CHNO - else (IPLUS (SUB1 (PLEN PC)) + else (IPLUS (PLAST PC) (\TEDIT.PCTOCH PC TEXTOBJ]) ) (DEFINEQ -(\SETUPGETCH - [LAMBDA (CH# TEXTOBJ) (* ; "Edited 21-Oct-2024 00:26 by rmk") - (* ; "Edited 29-Apr-2024 12:14 by rmk") - (* ; "Edited 17-Mar-2024 00:27 by rmk") - (* ; "Edited 23-Dec-2023 12:14 by rmk") - (* ; "Edited 22-Aug-2022 13:04 by rmk") - (* ; "Edited 10-Aug-2022 17:20 by rmk") - (* ; "Edited 8-Aug-2022 15:07 by rmk") - (* ; "Edited 31-Jul-2022 21:27 by rmk") - (* ; "Edited 14-Apr-93 17:14 by jds") - -(* ;;; "Set up TEXTOBJ so that the next \GETCH will retrieve character # CH#") - - (* ;; "NB that 1st char in the textobj is #1.") - - (* ;; "NOBODY CALLS IT WITH A PIECE. CALLS |INSTALL.PIECE INSTEAD") - - (SETQ TEXTOBJ (TEXTOBJ)) - (LET ((TSTREAM (TEXTSTREAM TEXTOBJ))) - (COND - ((TYPE? PIECE CH#) - (\TEDIT.THELP "\SETUPGETCH CALLED WITH PIECE") - (\TEDIT.INSTALL.PIECE TSTREAM CH# 0)) - (T (LET (START-OF-PIECE PC) - (DECLARE (SPECVARS START-OF-PIECE)) - (SETQ PC (\TEDIT.CHTOPC CH# TEXTOBJ T)) - (\TEDIT.INSTALL.PIECE TSTREAM PC (- CH# START-OF-PIECE]) -) - - - -(* ; "Deprecated, maybe still external callers") - -(DEFINEQ - (\TEDIT.INSTALL.PIECE [LAMBDA (TSTREAM PC CHOFFSET) (* ; "Edited 21-Oct-2024 00:26 by rmk") (* ; "Edited 18-May-2024 22:39 by rmk") @@ -3140,7 +3116,7 @@ ) (DECLARE%: DONTEVAL@LOAD DOCOPY -(\TEDIT.TEXTINIT) +(\TEDIT.STREAMINIT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS @@ -3151,34 +3127,33 @@ (ADDTOVAR LAMA TEXTPROP) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (36705 67564 (\TEDIT.TEXTBIN 36715 . 47508) (\TEDIT.TEXTPEEKBIN 47510 . 53060) ( -\TEDIT.TEXTBACKFILEPTR 53062 . 58735) (\TEDIT.TEXTBOUT 58737 . 63354) (\TEDIT.INSTALL.FILEBUFFER 63356 - . 67562)) (68462 72753 (\TEDIT.TEXTOUTCHARFN 68472 . 70028) (\TEDIT.TEXTINCCODEFN 70030 . 70769) ( -\TEDIT.TEXTBACKCCODEFN 70771 . 71363) (\TEDIT.TEXTFORMATBYTESTREAM 71365 . 72202) ( -\TEDIT.TEXTFORMATBYTESTRING 72204 . 72751)) (72800 84875 (OPENTEXTSTREAM 72810 . 79786) ( -COPYTEXTSTREAM 79788 . 84098) (TEDIT.STREAMCHANGEDP 84100 . 84402) (TXTFILE 84404 . 84873)) (84876 -116145 (\TEDIT.REOPENTEXTSTREAM 84886 . 86238) (\TEDIT.OPENTEXTSTREAM.PIECES 86240 . 91168) ( -\TEDIT.OPENTEXTSTREAM.PROPS 91170 . 92272) (\TEDIT.OPENTEXTSTREAM.SETUP.SEL 92274 . 97515) ( -\TEDIT.OPENTEXTSTREAM.WINDOW 97517 . 100308) (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS 100310 . 102249) ( -\TEDIT.OPENTEXTFILE 102251 . 104383) (\TEDIT.CREATE.TEXTSTREAM 104385 . 105532) (\TEDIT.REOPEN.STREAM -105534 . 107870) (\TEDIT.TEXTINIT 107872 . 116143)) (116183 117371 (\TEDIT.TTYBOUT 116193 . 117369)) ( -117489 139172 (\TEDIT.TEXTCLOSEF 117499 . 118823) (\TEDIT.TEXTDSPFONT 118825 . 120023) ( -\TEDIT.TEXTEOFP 120025 . 121780) (\TEDIT.TEXTGETEOFPTR 121782 . 122105) (\TEDIT.TEXTSETEOFPTR 122107 - . 123394) (\TEDIT.TEXTGETFILEPTR 123396 . 126231) (\TEDIT.TEXTSETFILEINFO 126233 . 126741) ( -\TEDIT.TEXTOPENF 126743 . 127674) (\TEDIT.TEXTSETEOF 127676 . 128292) (\TEDIT.TEXTSETFILEPTR 128294 . -130404) (\TEDIT.TEXTDSPXPOSITION 130406 . 133109) (\TEDIT.TEXTDSPYPOSITION 133111 . 133852) ( -\TEDIT.TEXTLEFTMARGIN 133854 . 134445) (\TEDIT.TEXTCOLOR 134447 . 135030) (\TEDIT.TEXTRIGHTMARGIN -135032 . 138321) (\TEDIT.TEXTDSPCHARWIDTH 138323 . 138627) (\TEDIT.TEXTDSPSTRINGWIDTH 138629 . 138935) - (\TEDIT.TEXTDSPLINEFEED 138937 . 139170)) (139210 151823 (\TEDIT.NTHCHARCODE 139220 . 140671) ( -\TEDIT.PIECE.NTHCHARCODE 140673 . 144583) (\TEDIT.RPLCHARCODE 144585 . 146043) ( -\TEDIT.PIECE.RPLCHARCODE 146045 . 151468) (\TEDIT.NTHCHARLOOKS 151470 . 151821)) (152870 173964 ( -\TEDIT.DELETE.SELPIECES 152880 . 156505) (\TEDIT.INSERTCH 156507 . 164546) (\TEDIT.INSERTCH.HISTORY -164548 . 168012) (\TEDIT.INSERTEOL 168014 . 169839) (\TEDIT.INSERTCH.INSERTION 169841 . 172678) ( -\TEDIT.INSERTCH.EXTEND 172680 . 173962)) (173965 175469 (\TEDIT.NEXTCHANGEABLE.CHNO 173975 . 174690) ( -\TEDIT.LASTCHANGEABLE.CHNO 174692 . 175467)) (175470 177174 (\SETUPGETCH 175480 . 177172)) (177232 -181690 (\TEDIT.INSTALL.PIECE 177242 . 181688)) (181728 191194 (TEXTPROP 181738 . 182085) (GETTEXTPROP -182087 . 182331) (PUTTEXTPROP 182333 . 182590) (GETTEXTPROPS 182592 . 183036) (PUTTEXTPROPS 183038 . -183942) (TEXTPROP.ADD 183944 . 184207) (\TEDIT.TEXTPROP 184209 . 191192)) (191195 193572 ( -\TEDIT.TEXTOBJ.PROPNAMES 191205 . 192464) (\TEDIT.TEXTOBJ.PROPFETCHFN 192466 . 192982) ( -\TEDIT.TEXTOBJ.PROPSTOREFN 192984 . 193570))))) + (FILEMAP (NIL (36667 67629 (\TEDIT.TEXTBIN 36677 . 47470) (\TEDIT.TEXTPEEKBIN 47472 . 53022) ( +\TEDIT.TEXTBACKFILEPTR 53024 . 58800) (\TEDIT.TEXTBOUT 58802 . 63419) (\TEDIT.INSTALL.FILEBUFFER 63421 + . 67627)) (68527 72818 (\TEDIT.TEXTOUTCHARFN 68537 . 70093) (\TEDIT.TEXTINCCODEFN 70095 . 70834) ( +\TEDIT.TEXTBACKCCODEFN 70836 . 71428) (\TEDIT.TEXTFORMATBYTESTREAM 71430 . 72267) ( +\TEDIT.TEXTFORMATBYTESTRING 72269 . 72816)) (72865 84940 (OPENTEXTSTREAM 72875 . 79851) ( +COPYTEXTSTREAM 79853 . 84163) (TEDIT.STREAMCHANGEDP 84165 . 84467) (TXTFILE 84469 . 84938)) (84941 +108146 (\TEDIT.REOPENTEXTSTREAM 84951 . 86303) (\TEDIT.OPENTEXTSTREAM.PIECES 86305 . 91233) ( +\TEDIT.OPENTEXTSTREAM.PROPS 91235 . 92337) (\TEDIT.OPENTEXTSTREAM.SETUP.SEL 92339 . 97789) ( +\TEDIT.OPENTEXTSTREAM.WINDOW 97791 . 100582) (\TEDIT.OPENTEXTSTREAM.DEFAULTLOOKS 100584 . 102523) ( +\TEDIT.OPENTEXTFILE 102525 . 104657) (\TEDIT.CREATE.TEXTSTREAM 104659 . 105806) (\TEDIT.REOPEN.STREAM +105808 . 108144)) (108147 116372 (\TEDIT.STREAMINIT 108157 . 116189) (TEDIT.IMAGESTREAM.OPEN 116191 . +116370)) (116560 117748 (\TEDIT.TTYBOUT 116570 . 117746)) (117866 139549 (\TEDIT.TEXTCLOSEF 117876 . +119200) (\TEDIT.TEXTDSPFONT 119202 . 120400) (\TEDIT.TEXTEOFP 120402 . 122157) (\TEDIT.TEXTGETEOFPTR +122159 . 122482) (\TEDIT.TEXTSETEOFPTR 122484 . 123771) (\TEDIT.TEXTGETFILEPTR 123773 . 126608) ( +\TEDIT.TEXTSETFILEINFO 126610 . 127118) (\TEDIT.TEXTOPENF 127120 . 128051) (\TEDIT.TEXTSETEOF 128053 + . 128669) (\TEDIT.TEXTSETFILEPTR 128671 . 130781) (\TEDIT.TEXTDSPXPOSITION 130783 . 133486) ( +\TEDIT.TEXTDSPYPOSITION 133488 . 134229) (\TEDIT.TEXTLEFTMARGIN 134231 . 134822) (\TEDIT.TEXTCOLOR +134824 . 135407) (\TEDIT.TEXTRIGHTMARGIN 135409 . 138698) (\TEDIT.TEXTDSPCHARWIDTH 138700 . 139004) ( +\TEDIT.TEXTDSPSTRINGWIDTH 139006 . 139312) (\TEDIT.TEXTDSPLINEFEED 139314 . 139547)) (139587 152583 ( +\TEDIT.NTHCHARCODE 139597 . 141123) (\TEDIT.PIECE.NTHCHARCODE 141125 . 145033) (\TEDIT.RPLCHARCODE +145035 . 146593) (\TEDIT.PIECE.RPLCHARCODE 146595 . 152228) (\TEDIT.NTHCHARLOOKS 152230 . 152581)) ( +153630 174724 (\TEDIT.DELETE.SELPIECES 153640 . 157265) (\TEDIT.INSERTCH 157267 . 165306) ( +\TEDIT.INSERTCH.HISTORY 165308 . 168772) (\TEDIT.INSERTEOL 168774 . 170599) (\TEDIT.INSERTCH.INSERTION + 170601 . 173438) (\TEDIT.INSERTCH.EXTEND 173440 . 174722)) (174725 176332 (\TEDIT.NEXTCHANGEABLE.CHNO + 174735 . 175450) (\TEDIT.LASTCHANGEABLE.CHNO 175452 . 176330)) (176333 180791 (\TEDIT.INSTALL.PIECE +176343 . 180789)) (180829 190295 (TEXTPROP 180839 . 181186) (GETTEXTPROP 181188 . 181432) (PUTTEXTPROP + 181434 . 181691) (GETTEXTPROPS 181693 . 182137) (PUTTEXTPROPS 182139 . 183043) (TEXTPROP.ADD 183045 + . 183308) (\TEDIT.TEXTPROP 183310 . 190293)) (190296 192673 (\TEDIT.TEXTOBJ.PROPNAMES 190306 . 191565 +) (\TEDIT.TEXTOBJ.PROPFETCHFN 191567 . 192083) (\TEDIT.TEXTOBJ.PROPSTOREFN 192085 . 192671))))) STOP diff --git a/library/tedit/TEDIT-STREAM.LCOM b/library/tedit/TEDIT-STREAM.LCOM index d9bbf246..f477a5e5 100644 Binary files a/library/tedit/TEDIT-STREAM.LCOM and b/library/tedit/TEDIT-STREAM.LCOM differ diff --git a/library/tedit/TEDIT.LCOM b/library/tedit/TEDIT.LCOM index cfdf23b6..5e803694 100644 Binary files a/library/tedit/TEDIT.LCOM and b/library/tedit/TEDIT.LCOM differ diff --git a/library/tedit/tedit-exports.all b/library/tedit/tedit-exports.all index 8f4f13bb..cb02912f 100644 --- a/library/tedit/tedit-exports.all +++ b/library/tedit/tedit-exports.all @@ -1,11 +1,11 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "20-Oct-2025 11:20:51"  -{DSK}kaplan>Local>medley3.5>working-medley>library>tedit>tedit-exports.all;243 52506 +(FILECREATED "16-Feb-2026 08:56:58"  +{DSK}kaplan>Local>medley3.5>working-medley>library>tedit>tedit-exports.all;249 52790 :EDIT-BY rmk - :PREVIOUS-DATE "20-Sep-2025 11:04:51" {WMEDLEY}TEDIT>tedit-exports.all;242) + :PREVIOUS-DATE "14-Jan-2026 14:50:53" {WMEDLEY}TEDIT>tedit-exports.all;248) (PRETTYCOMPRINT ((E (MAPC (MKLIST FROMFILES) (FUNCTION (LAMBDA (F) (MAPC (IMPORTFILE F FLG) (FUNCTION @@ -17,7 +17,7 @@ PRINT)))))))) (PUTPROPS FTEXTOBJ MACRO ((X) (TEXTOBJ! (CL:IF (type? TEXTOBJ X) X (GETTSTR X TEXTOBJ))))) (GLOBALVARS CHECK-TEDIT-ASSERTIONS) (RPAQ? CHECK-TEDIT-ASSERTIONS T) -(PUTPROP (QUOTE TEDIT) (QUOTE IMPORTDATE) (IDATE "28-Sep-2025 11:35:06")) +(PUTPROP (QUOTE TEDIT) (QUOTE IMPORTDATE) (IDATE " 4-Feb-2026 16:02:02")) (RPAQQ \BTREEWORDSPERSLOT 4) (RPAQQ \BTREEMAXCOUNT 8) (CONSTANTS (\BTREEWORDSPERSLOT 4) (\BTREEMAXCOUNT 8)) @@ -51,13 +51,14 @@ DLEN1 DOWN2 DLEN2 DOWN3 DLEN3 DOWN4 DLEN4 DOWN5 DLEN5 DOWN6 DLEN6 DOWN7 DLEN7 DO (\DTEST (OR (NEXTPIECE I.V.) (GO $$OUT)) (QUOTE PIECE))))) (I.S.OPR (QUOTE backpieces) NIL (QUOTE (first (SETQ I.V. (\DTEST (OR BODY (GO $$OUT)) (QUOTE PIECE))) by (\DTEST (OR (PREVPIECE I.V.) (GO $$OUT)) (QUOTE PIECE))))) -(PUTPROP (QUOTE TEDIT-PCTREE) (QUOTE IMPORTDATE) (IDATE "28-Jul-2025 23:25:19")) +(PUTPROP (QUOTE TEDIT-PCTREE) (QUOTE IMPORTDATE) (IDATE "14-Feb-2026 13:22:06")) (DATATYPE SELECTION ((* ;; "Description of a piece of selected text for TEdit. Text has to be selected before it can be operated on by the user. The caret is to the left of CH# if POINT is LEFT, to the keft of CHLIM if POINT is RIGHT." ) (* ;; "If DCH > 0, highlighting goes from CH# to (SUB1 CHLIM = (SUB1 (IPLUS CH# DCH)).") (* ;; "If DCH=0, this is a caret-only selection, with no highlighting. In that case CHLIM=(ADD1 CH#) and POINT essentially indicates whether the caret blinks before or after CH#." -) NIL (* ; "Was Y0: Y value of topmost line of selection") X0 (* ; -"X value of left edge of selection on the first line") SELLINES (* ; +) SELOPERATION (* ; +"NORMAL, MOVE, COPY... HOW and HOWHEIGHT are derived from the operation. Was Y0: Y value of topmost line of selection" +) X0 (* ; "X value of left edge of selection on the first line") SELLINES (* ; "A list of (L1 L2) pairs one for each pane, to replace the separate L1 L2 lists. Was DX: Width of the selection, if it's on one line." ) CH# (* ; "CH# of the first selected character") XLIM (* ; "X value of right edge of last selected character on the last line") CHLIM (* ; @@ -127,7 +128,7 @@ TSTREAM ONLYPANE DONTFIX))) (PUTPROPS \TEDIT.SEL.OFF MACRO ((TSTREAM SEL ONLYPANE) (* ; "Takes down SEL in TSTREAM, where SEL defaults to the current selection") (\TEDIT.SHOWSEL SEL NIL TSTREAM ONLYPANE))) -(PUTPROP (QUOTE TEDIT-SELECTION) (QUOTE IMPORTDATE) (IDATE "29-Jul-2025 11:22:10")) +(PUTPROP (QUOTE TEDIT-SELECTION) (QUOTE IMPORTDATE) (IDATE "16-Feb-2026 00:38:33")) (RECORD TAB (TABX . TABKIND)) (RECORD TABSPEC (DEFAULTTAB . TABS)) (DATATYPE LINECACHE ((* ;; "Image cache for display lines.") LCBITMAP (* ; @@ -208,8 +209,6 @@ ITEM collect (FIXR (FTIMES SCALE ITEM))) (FIXR (FTIMES SCALE ITEM))))) (PUTPROPS SCALEDOWN MACRO (OPENLAMBDA (SCALE ITEM) (* ; "List = region?") (CL:IF (LISTP ITEM) (for I in ITEM collect (FIXR (FQUOTIENT I SCALE))) (FIXR (FQUOTIENT ITEM SCALE))))) (GLOBALVARS TEDIT.DONT.BREAK.CHARS TEDIT.DONT.LAST.CHARS) -(ADDTOVAR CHARACTERNAMES (SOFT-HYPHEN "357,043") (NONBREAKING-HYPHEN "357,042") (NONBREAKING-SPACE -"357,041")) (PUTPROPS DIACRITICP MACRO (OPENLAMBDA (CHAR) (* ;; "An XCCS diacritic") (AND (SMALLP CHAR) (IGEQ CHAR 192) (ILEQ CHAR 207)))) (PUTPROPS \TEDIT.LINE.TALLP MACRO ((LINE HEIGHT) (OR (IGREATERP (FGETLD LINE LHEIGHT) 50) (IGREATERP ( @@ -260,7 +259,7 @@ NEXTAVAILABLECHARSLOT) of THISLINE))) (T $$STARTSLOT))) (SETQ $$CHARSLOTLIMIT (F ) by (PREVCHARSLOT I.V.) eachtime (SETQ CHAR (fetch (CHARSLOT CHAR) of I.V.)) (SETQ CHARW (fetch ( CHARSLOT CHARW) of I.V.)) (SETQ CHARCL (fetch (CHARSLOT CHARCL) of I.V.)) repeatuntil (EQ I.V. $$CHARSLOTLIMIT))))) T) -(PUTPROP (QUOTE TEDIT-SCREEN) (QUOTE IMPORTDATE) (IDATE "19-Oct-2025 00:07:29")) +(PUTPROP (QUOTE TEDIT-SCREEN) (QUOTE IMPORTDATE) (IDATE " 5-Feb-2026 00:39:54")) (DATATYPE PIECE ((* ; "The piece describes either a string or part of a file. , or a generalized OBJECT.") PCONTENTS (* ; "The background source of data for this piece (stream, string, block, object, depending on the PTYPE)." @@ -299,9 +298,10 @@ HINTPC (* ; "Was: Space left in the type-in piece") HINTPCSTARTCH# (* ; ) DS (* ; "NOTE: THIS IS ONLY USED INCORRECTLY BY TEDIT-CHAT Display stream where this textobj is displayed") SEL (* ; "The current selection within the text") LASTARROWX (* ; -"X for next arrow up or arrow down. Was: Scratch space for the selection code") NIL (* ; -"Was MOVESEL: Source for the next MOVE of text") NIL (* ; "Was SHIFTEDSEL: Source for the next COPY") -NIL (* ; "Was DELETESEL: Text to be deleted imminently") NIL (* ; +"X for next arrow up or arrow down. Was: Scratch space for the selection code") SECONDARYSEL (* ; +"Holds secondary selection and operation just before the mouse leaves a window. Was MOVESEL: Source for the next MOVE of text" +) NIL (* ; "Was SHIFTEDSEL: Source for the next COPY") NIL (* ; +"Was DELETESEL: Text to be deleted imminently") NIL (* ; "Was WRIGHT: Right edge of the window (or subregion) where this is displayed") WTOP (* ; "Top of the window/region") NIL (* ; "Was WBOTTOM: Bottom of the window/region") NIL (* ; "Was WLEFT: Left edge of the window/region") TXTFILE (* ; "The original text file we're editing") ( @@ -372,6 +372,7 @@ IMAGEDATA _ NIL))) (PUTPROPS NEXTPIECE MACRO ((PC) (ffetch (PIECE NEXTPIECE) of PC))) (PUTPROPS PREVPIECE MACRO ((PC) (ffetch (PIECE PREVPIECE) of PC))) (PUTPROPS PLEN MACRO ((PC) (ffetch (PIECE PLEN) of PC))) +(PUTPROPS PLAST MACRO ((PC) (SUB1 (PLEN PC)))) (PUTPROPS PTYPE MACRO ((PC) (ffetch (PIECE PTYPE) of PC))) (PUTPROPS PCONTENTS MACRO ((PC) (ffetch (PIECE PCONTENTS) of PC))) (PUTPROPS PCHARLOOKS MACRO ((PC) (ffetch (PIECE PCHARLOOKS) of PC))) @@ -440,7 +441,7 @@ UTF8.PTYPE UTF16BE.PTYPE UTF16LE.PTYPE)) (STRING.PTYPES (LIST THINSTRING.PTYPE F BINABLE.PTYPES (LIST THINFILE.PTYPE THINSTRING.PTYPE)) (THIN.PTYPES (LIST THINFILE.PTYPE THINSTRING.PTYPE)) (FAT.PTYPES (LIST FATFILE2.PTYPE FATSTRING.PTYPE FATFILE1.PTYPE))) (GLOBALVARS \TEXTIMAGEOPS \TEXTFDEV) -(PUTPROP (QUOTE TEDIT-STREAM) (QUOTE IMPORTDATE) (IDATE "19-Oct-2025 15:09:09")) +(PUTPROP (QUOTE TEDIT-STREAM) (QUOTE IMPORTDATE) (IDATE "16-Feb-2026 08:56:40")) (PUTPROPS \TEDIT.MOUSESTATE MACRO (BUTTON (* ;; "Test to see if only the specified mouse button is down. DOES NOT call GETMOUSESTATE, so the mouse-button info is the same as the last time it was called." ) (SELECTQ (CAR BUTTON) (LEFT (QUOTE (EQ LASTMOUSEBUTTONS 4))) (MIDDLE (QUOTE (EQ LASTMOUSEBUTTONS 1)) @@ -449,12 +450,12 @@ THINSTRING.PTYPE)) (FAT.PTYPES (LIST FATFILE2.PTYPE FATSTRING.PTYPE FATFILE1.PTY I in ARGS as J on ARGS when (NOT (STRINGP I)) collect (LIST (QUOTE OR) I (LIST (QUOTE HELP) "TEdit consistency-check failure [RETURN to continue]: " (COND ((STRINGP (CADR J))) (T (KWOTE I)))))) )) (T (CONS COMMENTFLG ARGS))))) -(PUTPROP (QUOTE TEDIT-COMMAND) (QUOTE IMPORTDATE) (IDATE "17-Jul-2025 00:24:49")) +(PUTPROP (QUOTE TEDIT-COMMAND) (QUOTE IMPORTDATE) (IDATE " 8-Nov-2025 10:03:19")) (PUTPROPS \SMALLPIN MACRO (OPENLAMBDA (STREAM) (SIGNED (create WORD HIBYTE _ (\BIN STREAM) LOBYTE _ ( \BIN STREAM)) BITSPERWORD))) (PUTPROPS \SMALLPOUT MACRO (OPENLAMBDA (STREAM W) (* ; "Signed smallp, unlike \WOUT") (\BOUT STREAM ( LOGAND 255 (LRSH W 8))) (\BOUT STREAM (LOGAND W 255)))) -(PUTPROP (QUOTE TEDIT-FILE) (QUOTE IMPORTDATE) (IDATE "25-Sep-2025 21:32:46")) +(PUTPROP (QUOTE TEDIT-FILE) (QUOTE IMPORTDATE) (IDATE "15-Feb-2026 23:45:51")) (PUTPROP (QUOTE TEDIT-OLDFILE) (QUOTE IMPORTDATE) (IDATE " 8-Sep-2025 22:10:10")) (DATATYPE CHARLOOKS ((* ;; "Describes the appearance (%"Looks%") of characters in a TEdit document.") (* ;; "NOTE: If fields change EQCLOOKS should change too.") CLFONT (* ; @@ -537,7 +538,7 @@ LINELEAD _ 0) (PUTPROPS FSETPLOOKS MACRO ((PLOOKS FIELD NEWVALUE) (freplace (PARALOOKS FIELD) of PLOOKS with NEWVALUE))) (PUTPROPS PARALOOKS! MACRO ((PL) (\DTEST PL (QUOTE PARALOOKS)))) -(PUTPROP (QUOTE TEDIT-LOOKS) (QUOTE IMPORTDATE) (IDATE " 6-Oct-2025 20:50:59")) +(PUTPROP (QUOTE TEDIT-LOOKS) (QUOTE IMPORTDATE) (IDATE "16-Feb-2026 00:36:00")) (PUTPROP (QUOTE TEDIT-STYLES) (QUOTE IMPORTDATE) (IDATE "28-Jul-2025 23:25:43")) (DATATYPE TEDITCARET (TCNOWTIME (* Used to hold the current time, when checking to see if a transition is due) TCTHENTIME (* Time when the next transition is to take place) TCFORCEDDOWN (* TCFORCEDOWN = T @@ -600,17 +601,18 @@ OR (CL:IF (TYPENAMEP $$BODY (QUOTE TEXTOBJ)) (FGETTOBJ $$BODY PRIMARYPANE) $$BOD GETPANEPROP (PANEPROPS P) NEXTPANE))) (GO $$OUT))) by (OR (GETPANEPROP (PANEPROPS I.V.) PREVPANE) (GO $$OUT))))) (PUTPROPS ALLBUTTONSUP MACRO (NIL (ZEROP (LOGAND 7 LASTMOUSEBUTTONS)))) -(PUTPROP (QUOTE TEDIT-WINDOW) (QUOTE IMPORTDATE) (IDATE "19-Oct-2025 15:13:01")) -(PUTPROP (QUOTE TEDIT-BUTTONS) (QUOTE IMPORTDATE) (IDATE "19-Oct-2025 10:44:18")) -(PUTPROP (QUOTE TEDIT-MENU) (QUOTE IMPORTDATE) (IDATE "19-Oct-2025 15:14:00")) +(PUTPROP (QUOTE TEDIT-WINDOW) (QUOTE IMPORTDATE) (IDATE " 7-Feb-2026 18:53:22")) +(PUTPROP (QUOTE TEDIT-BUTTONS) (QUOTE IMPORTDATE) (IDATE "25-Jan-2026 09:14:04")) +(PUTPROP (QUOTE TEDIT-MENU) (QUOTE IMPORTDATE) (IDATE " 9-Feb-2026 09:10:43")) (PUTPROP (QUOTE TEDIT-FIND) (QUOTE IMPORTDATE) (IDATE "21-Apr-2025 22:42:57")) -(RPAQQ \TEDIT.TTCCODES ((NONE 0) (CHARDELETE 1) (WORDDELETE 2) (DELETE 3) (FUNCTIONCALL 4) (REDO 5) ( -UNDO 6) (CMD 7) (NEXT 8) (EXPAND 9) (CHARDELETE.FORWARD 10) (WORDDELETE.FORWARD 11) (PUNCT 20) (TEXT -21) (WHITESPACE 22))) +(RPAQQ \TEDIT.TTCCODES ((NONE . 0) (CHARDELETE . 1) (:CHARDELETE.BACKWARD . 1) (WORDDELETE . 2) ( +:WORDDELETE.BACKWORD . 2) (DELETE . 3) (:DELETE . 3) (FN . 4) (REDO . 5) (:REDO . 5) (UNDO . 6) (:UNDO + . 6) (CMD . 7) (:CMD . 7) (NEXT . 8) (:NEXT . 8) (EXPAND . 9) (:EXPAND . 9) (CHARDELETE.FORWARD . 10) + (:CHARDELETE.FORWARD . 10) (:WORDDELETE.FORWARD . 11) (PUNCT . 20) (TEXT . 21) (WHITESPACE . 22))) (CONSTANTS \TEDIT.TTCCODES) -(PUTPROPS \TEDIT.TTC MACRO ((CLASS) (CONSTANT (CADR (ASSOC (QUOTE CLASS) \TEDIT.TTCCODES))))) -(PUTPROP (QUOTE TEDIT-FNKEYS) (QUOTE IMPORTDATE) (IDATE " 7-Aug-2025 15:00:51")) -(PUTPROP (QUOTE TEDIT-HCPY) (QUOTE IMPORTDATE) (IDATE "19-Sep-2025 17:08:05")) +(PUTPROPS \TEDIT.TTC MACRO ((ACTION) (CONSTANT (GETMULTI \TEDIT.TTCCODES (QUOTE ACTION))))) +(PUTPROP (QUOTE TEDIT-FNKEYS) (QUOTE IMPORTDATE) (IDATE " 8-Feb-2026 19:54:41")) +(PUTPROP (QUOTE TEDIT-HCPY) (QUOTE IMPORTDATE) (IDATE "15-Jan-2026 11:08:15")) (DATATYPE TEDITHISTORYEVENT ((* ;; "Describes one event on the TEdit edit history list.") THACTION (* ; "A keyword specifying what the event was") THPOINT (* ; "Was the selection to the left or right?") THLEN (* ; "The # of chars involved") THCH# (* ; "The starting ch#") THFIRSTPIECE (* ; @@ -659,9 +661,9 @@ REGIONPARENT FULLXPOINTER) (* ; "The parent node for this box, for sub-boxes") R $$VALUES)) (PROG1 (CAR $$VALUES) (\,@ (FOR V IN (CAR ARGS) collect (COND (V (BQUOTE (SETQ (\, V) (POP $$VALUES)))) (T (BQUOTE (SETQ $$VALUES (CDR $$VALUES)))))))))))) (PUTPROPS TEDIT.VALUES MACRO (ARGS (BQUOTE (LIST (\,@ ARGS))))) -(PUTPROP (QUOTE TEDIT-PAGE) (QUOTE IMPORTDATE) (IDATE "27-Sep-2025 16:25:26")) -(PUTPROP (QUOTE TEDIT-ABBREV) (QUOTE IMPORTDATE) (IDATE " 6-Sep-2025 00:10:45")) -(PUTPROP (QUOTE TEDIT-TFBRAVO) (QUOTE IMPORTDATE) (IDATE " 7-Sep-2025 11:11:43")) +(PUTPROP (QUOTE TEDIT-PAGE) (QUOTE IMPORTDATE) (IDATE "27-Jan-2026 10:30:27")) +(PUTPROP (QUOTE TEDIT-ABBREV) (QUOTE IMPORTDATE) (IDATE "23-Jan-2026 15:49:26")) +(PUTPROP (QUOTE TEDIT-TFBRAVO) (QUOTE IMPORTDATE) (IDATE "21-Jan-2026 12:15:57")) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP diff --git a/library/virtualkeyboards/KEYBOARDCONFIGS b/library/virtualkeyboards/KEYBOARDCONFIGS index e572a178..057613e6 100644 --- a/library/virtualkeyboards/KEYBOARDCONFIGS +++ b/library/virtualkeyboards/KEYBOARDCONFIGS @@ -1,10 +1,10 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) -(FILECREATED "13-Oct-2025 13:44:47" {WMEDLEY}virtualkeyboards>KEYBOARDCONFIGS.;5 59521 +(FILECREATED "19-Feb-2026 22:32:05" {WMEDLEY}virtualkeyboards>KEYBOARDCONFIGS.;6 59604 :EDIT-BY rmk - :PREVIOUS-DATE "13-Oct-2025 12:03:23" {WMEDLEY}virtualkeyboards>KEYBOARDCONFIGS.;4) + :PREVIOUS-DATE "13-Oct-2025 13:44:47" {WMEDLEY}virtualkeyboards>KEYBOARDCONFIGS.;5) (PRETTYCOMPRINT KEYBOARDCONFIGSCOMS) @@ -57,11 +57,11 @@ (F3 (F3 ITALIC)) (F4 (F4 UCASE)) (F5 (F5 STRIKE)) - (F6 (F6 "­")) + (F6 (F6 "^")) (F7 (F7 SUBSCR)) (F8 (F8 SMALL)) (F9 (F9 MARGIN)) - (F10 (F10 "¬")) + (F10 (F10 "_")) (F11 (F11 "")) (F12 (F12 "")) (LOCK ("CAPS" "LOCK")) @@ -115,7 +115,7 @@ (THREE (|3| %# NLS)) (FOUR (|4| $ NLS)) (FIVE (|5| %% NLS)) - (SIX (|6| ^ NLS)) + (SIX (|6| ↑ NLS)) (SEVEN (|7| & NLS)) (EIGHT (|8| * NLS)) (NINE (|9| %( NLS)))) @@ -234,7 +234,7 @@ NIL ((%" (%' %" NLS)) (+ (= + NLS)) - (- (- _ NLS)) + (- (- ↠NLS)) (%: (; %: NLS)) (< (%, < NLS)) (> (%. > NLS)) @@ -255,13 +255,13 @@ (NUMERIC/ (/ /)) (NUMERIC0 (INS |0| NLS)) (NUMERIC1 (END |1| NLS)) - (NUMERIC2 (¯ |2| NLS)) + (NUMERIC2 (↓ |2| NLS)) (NUMERIC3 (PGDN |3| NLS)) - (NUMERIC4 (¬ |4| NLS)) + (NUMERIC4 (_ |4| NLS)) (NUMERIC5 (|5| |5|)) - (NUMERIC6 (® |6| NLS)) + (NUMERIC6 (→ |6| NLS)) (NUMERIC7 (HOME |7| NLS)) - (NUMERIC8 (­ |8| NLS)) + (NUMERIC8 (^ |8| NLS)) (NUMERIC9 (PGUP |9| NLS)) (NUMERIC= (= =)) (RETURN (CR CR)) @@ -274,17 +274,17 @@ (F3 (ITALIC NOTITALIC NLS)) (F4 (UCASE LCASE NLS)) (F5 (STRIKEOUT NOTSTRIKEOUT NLS)) - (F6 ("­" "­" NLS)) + (F6 ("^" "^" NLS)) (F7 (SUBSCRIPT SUPERSCRIPT NLS)) (F8 (SMALLER LARGER NLS)) (F9 (MARGINS NOTMARGINS NLS)) - (F10 ("¬" "¬" NLS)) + (F10 ("_" "_" NLS)) (F11 (F11 NOTF11 NLS)) (F12 (F12 NOTF12 NLS))) ((%` 45 B) (~ 45 T) (|6| 2 B) - (^ 2 T) + (↑ 2 T) (%% 0 T) (|5| 0 B) ($ 1 T) @@ -523,7 +523,7 @@ (> (346 46 29 33)) (%: (362 82 29 33)) (<-%| (426 82 63 33)) - (^ (450 118 29 33)) + (↑ (450 118 29 33)) (DEL (498 154 29 33)) (R (162 118 29 33)) (T (194 118 29 33)) @@ -556,7 +556,7 @@ (LF (LF LF)) (LOCK LOCKDOWN . LOCKUP) (\ (\ %| NLS)) - (^ (_ ^ NLS)) + (↑ (↠↑ NLS)) ({ (%[ { NLS)) (} (%] } NLS))) ((BLANK-MIDDLE 30) @@ -643,8 +643,8 @@ (%: 43) (CR 44) (<-%| 44) - (_ 45) - (^ 45) + (↠45) + (↑ 45) (r 48) (R 48) (t 49) @@ -744,7 +744,7 @@ NIL ((%" (%' %" NLS)) (+ (= + NLS)) - (- (- _ NLS)) + (- (- ↠NLS)) (ESC (ESC %| NLS)) (%: (; %: NLS)) (< (%, < NLS)) @@ -757,7 +757,7 @@ (~ (%` ~ NLS))) ((%` 45) (~ 45) - (^ 2) + (↑ 2) (|6| 2) (w 18) (W 18) @@ -951,7 +951,7 @@ NIL ((%" (%' %" NLS)) (+ (= + NLS)) - (- (- _ NLS)) + (- (- ↠NLS)) (%: (; %: NLS)) (< (%, < NLS)) (<-%| (CR CR)) @@ -962,21 +962,21 @@ (KEYBOARD METADOWN . METAUP) (LOCK LOCKDOWN . LOCKUP) (NEXT (2,22 2,62 NLS)) - (NUMERIC* (NUMLK ´ NLS)) + (NUMERIC* (NUMLK × NLS)) (NUMERIC+ (HELP 2,45 NLS)) (NUMERIC, (\ %, NLS)) (NUMERIC- (SCRL - NLS)) (NUMERIC. (%| 21 NLS)) - (NUMERIC/ (BREAK ¸ NLS)) + (NUMERIC/ (BREAK ÷ NLS)) (NUMERIC0 (INS |0| NLS)) (NUMERIC1 (END |1| NLS)) - (NUMERIC2 (¯ |2| NLS)) + (NUMERIC2 (↓ |2| NLS)) (NUMERIC3 (PGDN |3| NLS)) - (NUMERIC4 (¬ |4| NLS)) + (NUMERIC4 (_ |4| NLS)) (NUMERIC5 (% |5| NLS)) - (NUMERIC6 (® |6| NLS)) + (NUMERIC6 (→ |6| NLS)) (NUMERIC7 (HOME |7| NLS)) - (NUMERIC8 (­ |8| NLS)) + (NUMERIC8 (^ |8| NLS)) (NUMERIC9 (PGUP |9| NLS)) (%` (%` ~ NLS)) ({ (%[ { NLS)) @@ -987,7 +987,7 @@ (|4| 1) ($ 1) (|6| 2) - (^ 2) + (↑ 2) (e 3) (E 3) (|7| 4) @@ -1233,7 +1233,7 @@ (%. (%. > NLS)) (/ (/ ? NLS)) (\ (\ %| NLS)) - (- (- _ NLS)) + (- (- ↠NLS)) (%` (%` ~ NLS)) (%[ (%[ { NLS)) (%] (%] } NLS)) @@ -1249,13 +1249,13 @@ (NUMERIC/ (/ /)) (NUMERIC0 (INS |0| NLS)) (NUMERIC1 (END |1| NLS)) - (NUMERIC2 (¯ |2| NLS)) + (NUMERIC2 (↓ |2| NLS)) (NUMERIC3 (PGDN |3| NLS)) - (NUMERIC4 (¬ |4| NLS)) + (NUMERIC4 (_ |4| NLS)) (NUMERIC5 (|5| |5|)) - (NUMERIC6 (® |6| NLS)) + (NUMERIC6 (→ |6| NLS)) (NUMERIC7 (HOME |7| NLS)) - (NUMERIC8 (­ |8| NLS)) + (NUMERIC8 (^ |8| NLS)) (NUMERIC9 (PGUP |9| NLS)) (NUMERICENTER (CR CR)) (RALT METADOWN . METAUP) @@ -1264,11 +1264,11 @@ (F3 (ITALIC NOTITALIC NLS)) (F4 (UCASE LCASE NLS)) (F5 (STRIKEOUT NOTSTRIKEOUT NLS)) - (F6 ("­" "­" NLS)) + (F6 ("^" "^" NLS)) (F7 (SUBSCRIPT SUPERSCRIPT NLS)) (F8 (SMALLER LARGER NLS)) (F9 (MARGINS NOTMARGINS NLS)) - (F10 ("¬" "¬" NLS)) + (F10 ("_" "_" NLS)) (F11 (F11 NOTF11 NLS)) (F12 (F12 NOTF12 NLS))) ((%' 28 B) @@ -1276,7 +1276,7 @@ (%, 27 B) (< 27 T) (- 10 B) - (_ 10 T) + (↠10 T) (> 42 T) (%. 42 B) (/ 12 B) @@ -1286,7 +1286,7 @@ (%# 16 T) ($ 1 T) (%% 0 T) - (^ 4 T) + (↑ 4 T) (* 53 T) (%( 22 T) (%) 8 T) @@ -1494,7 +1494,7 @@ (M (370 42 29 29)) (; (402 42 29 29)) (%: (434 42 29 29)) - (_ (466 42 29 29)) + (↠(466 42 29 29)) (RSHIFT (498 42 53 29)) (LINEFEED (554 42 29 29)) (CONTROL (106 74 53 29)) @@ -1559,7 +1559,7 @@ (ONE (|1| + NLS)) (TWO (|2| %" NLS)) (THREE (|3| * NLS)) - (FOUR (|4| ‡ NLS)) + (FOUR (|4|  NLS)) (SIX (|6| & NLS)) (SEVEN (|7| / NLS)) (EIGHT (|8| %( NLS)) @@ -1567,7 +1567,7 @@ (%: (%. %: NLS)) (; (%, ; NLS)) (? (%' ? NLS)) - (AUMLAUT (… „ NLS)) + (AUMLAUT (î€ î€‚ NLS)) (CAPSLOCK CTRLDOWN . CTRLUP) (CONTROL LOCKDOWN . LOCKUP) (CR (CR CR)) @@ -1591,10 +1591,10 @@ (NUMERIC8 (|8| |8|)) (NUMERIC9 (|9| |9|)) (NUMERIC= (= =)) - (OUMLAUT (‚ ” NLS)) - (UUMLAUT (Š NLS)) + (OUMLAUT (  NLS)) + (UUMLAUT (  NLS)) (%[ (%] %[ NLS)) - (_ (- _ NLS)) + (↠(- ↠NLS)) ({ (< { NLS)) (} (> } NLS))) ((HELP 0) @@ -1658,7 +1658,7 @@ (%. 49) (%: 49) (- 50) - (_ 50) + (↠50) (RSHIFT 51) (LINEFEED 52) (CONTROL 53) diff --git a/library/virtualkeyboards/XKEYBOARDS b/library/virtualkeyboards/XKEYBOARDS index a035c92a..9998bd96 100644 Binary files a/library/virtualkeyboards/XKEYBOARDS and b/library/virtualkeyboards/XKEYBOARDS differ diff --git a/lispusers/BACKGROUNDMENU b/lispusers/BACKGROUNDMENU index 0cb799a0..fab3e487 100644 --- a/lispusers/BACKGROUNDMENU +++ b/lispusers/BACKGROUNDMENU @@ -1,18 +1,17 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED "31-Jan-87 18:09:00" {ERIS}LYRIC>BACKGROUNDMENU.;1 7367 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - previous date%: "31-Jan-86 11:36:13" {ERIS}KOTO>LISPUSERS>BACKGROUNDMENU.;1) +(FILECREATED "18-Feb-2026 16:20:10" {WMEDLEY}BACKGROUNDMENU.;2 7230 + :EDIT-BY rmk + + :PREVIOUS-DATE "31-Jan-87 18:09:00" {WMEDLEY}BACKGROUNDMENU.;1) -(* " -Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT BACKGROUNDMENUCOMS) (RPAQQ BACKGROUNDMENUCOMS ((INITVARS BackgroundMenuFixupMode BackgroundMenuSuperItem BackgroundMenuTopLevelItems) - (FNS BkgMenu.add.item BkgMenu.fixup BkgMenu.move.item BkgMenu.remove.item + (FNS BkgMenu.add.item BkgMenu.fixup BkgMenu.move.item BkgMenu.remove.item BkgMenu.rename.item BkgMenu.reorder.items BkgMenu.subitems \BkgMenu.locate \BkgMenu.locater \BkgMenu.remove.item \BkgMenu.scan.item.list \BkgMenu.unremove.item))) @@ -153,11 +152,10 @@ Copyright (c) 1985, 1986, 1987 by Xerox Corporation. All rights reserved. else (SETQ BackgroundMenuCommands (CONS (CAR item) BackgroundMenuCommands]) ) -(PUTPROPS BACKGROUNDMENU COPYRIGHT ("Xerox Corporation" 1985 1986 1987)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1008 7271 (BkgMenu.add.item 1018 . 1910) (BkgMenu.fixup 1912 . 3131) (BkgMenu.move.item - 3133 . 3557) (BkgMenu.remove.item 3559 . 3834) (BkgMenu.rename.item 3836 . 4128) ( -BkgMenu.reorder.items 4130 . 4505) (BkgMenu.subitems 4507 . 4907) (\BkgMenu.locate 4909 . 5520) ( -\BkgMenu.locater 5522 . 6089) (\BkgMenu.remove.item 6091 . 6378) (\BkgMenu.scan.item.list 6380 . 6877) - (\BkgMenu.unremove.item 6879 . 7269))))) + (FILEMAP (NIL (944 7207 (BkgMenu.add.item 954 . 1846) (BkgMenu.fixup 1848 . 3067) (BkgMenu.move.item +3069 . 3493) (BkgMenu.remove.item 3495 . 3770) (BkgMenu.rename.item 3772 . 4064) ( +BkgMenu.reorder.items 4066 . 4441) (BkgMenu.subitems 4443 . 4843) (\BkgMenu.locate 4845 . 5456) ( +\BkgMenu.locater 5458 . 6025) (\BkgMenu.remove.item 6027 . 6314) (\BkgMenu.scan.item.list 6316 . 6813) + (\BkgMenu.unremove.item 6815 . 7205))))) STOP diff --git a/lispusers/BACKGROUNDMENU.LCOM b/lispusers/BACKGROUNDMENU.LCOM index da4e8186..bc7c8b5f 100644 Binary files a/lispusers/BACKGROUNDMENU.LCOM and b/lispusers/BACKGROUNDMENU.LCOM differ diff --git a/lispusers/CHATSERVER b/lispusers/CHATSERVER index 3f7130bf..8f598a84 100644 --- a/lispusers/CHATSERVER +++ b/lispusers/CHATSERVER @@ -1,14 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 7-Sep-88 17:08:57" {ERINYES}MEDLEY>CHATSERVER.;11 47957 - changes to%: (FNS CHATSERVEROPENFN) +(FILECREATED " 9-Feb-2026 22:25:32" {WMEDLEY}CHATSERVER.;2 45227 - previous date%: "19-May-88 00:37:49" {ERINYES}MEDLEY>CHATSERVER.;10) + :EDIT-BY rmk + :CHANGES-TO (FNS \CREATELINEBUFFER) + + :PREVIOUS-DATE " 7-Sep-88 17:08:57" {WMEDLEY}CHATSERVER.;1) -(* " -Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT CHATSERVERCOMS) @@ -40,8 +39,7 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res (COMMANDS "QUIT" "SAY") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) - (LAMA \REMOTE.BIN - CHATSERVEROPENFN]) + (LAMA CHATSERVEROPENFN]) (DEFINEQ (CHATSERVER @@ -450,34 +448,34 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res (RETURN CHARBUFFER]) (\CREATELINEBUFFER - [LAMBDA (TERMINAL.STREAM) (* ; "Edited 13-Apr-87 22:57 by bvm:") - (* ;; - "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).") + [LAMBDA (TERMINAL.STREAM) (* ; "Edited 9-Feb-2026 22:21 by rmk") + (* ; "Edited 13-Apr-87 22:57 by bvm:") - (LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((CHARSET T] + (* ;; "This is a copy of \CREATELINEBUFFER on ATERM, except for the source of the EOFMETHOD.") + + (* ;; + "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).") + + (LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((:EXTERNAL-FORMAT :THROUGH16] (DEV (fetch (STREAM DEVICE) of STREAM)) EOFMETHOD) (replace LINEBUFSTATE of STREAM with READING.LBS) - (replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM - \KEYBOARD.STREAM)) + (replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM)) (replace USERCLOSEABLE of STREAM with NIL) - (replace USERVISIBLE of STREAM with NIL) - (* ; - "Other linebuffer fields default properly") + (replace USERVISIBLE of STREAM with NIL) (* ; + "Other linebuffer fields default properly") [replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM) - (CL:FUNCALL \RefillBufferFn] - (if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) - of (fetch (STREAM DEVICE) - TERMINAL.STREAM))) - 'NILL)) + (CL:FUNCALL \RefillBufferFn] + (if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of (fetch (STREAM DEVICE) + TERMINAL.STREAM) + )) + 'NILL)) then - (* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.") + (* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.") - (replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE - 'FDEV DEV))) - (* ; - "Copy the basic linebuffer device") - (replace (FDEV EOFP) of DEV with EOFMETHOD)) + (replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE 'FDEV DEV))) + (* ; "Copy the basic linebuffer device") + (replace (FDEV EOFP) of DEV with EOFMETHOD)) STREAM]) (\PROMPTFORWORDBIN @@ -650,7 +648,7 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res (SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG)) (for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL) - (ECHOCHAR I 'IGNORE ASKUSERTTBL)) + (ECHOCHAR I 'IGNORE ASKUSERTTBL)) (ECHOCHAR (CHARCODE CR) 'SIMULATE CHATSERVERTTBL) @@ -715,29 +713,25 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res (DECLARE%: EVAL@COMPILE [PROGN (PUTPROPS \SYNCODE DMACRO [OPENLAMBDA (TABLE CHAR) - (CHECK (type? CHARTABLE TABLE)) + (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]) + "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 \SYNCODE MACRO [OPENLAMBDA (TABLE CHAR) - (CHECK (type? CHARTABLE TABLE)) - (COND - ((IGREATERP CHAR \MAXTHINCHAR) - (OR (AND (fetch (CHARTABLE NSCHARHASH) - of TABLE) - (GETHASH CHAR (fetch (CHARTABLE - NSCHARHASH) - of TABLE))) - 0)) - (T (\GETBASEBYTE TABLE CHAR])] + (CHECK (type? CHARTABLE TABLE)) + (COND + ((IGREATERP CHAR \MAXTHINCHAR) + (OR (AND (fetch (CHARTABLE NSCHARHASH) of TABLE) + (GETHASH CHAR (fetch (CHARTABLE NSCHARHASH) + of TABLE))) + 0)) + (T (\GETBASEBYTE TABLE CHAR])] ) (DECLARE%: DONTEVAL@LOAD DOCOPY @@ -773,10 +767,9 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res (READVISE MENU CHAT RINGBELLS) ) -(DEFCOMMAND "QUIT" () - (RETFROM 'CHATSERVEROPENFN)) +(DEFCOMMAND "QUIT" NIL (RETFROM 'CHATSERVEROPENFN)) -(DEFCOMMAND "SAY" (&REST LINE) +(DEFCOMMAND "SAY" (&REST LINE) [MAPC \PROCESSES (FUNCTION (LAMBDA (PROC) (CL:WHEN (STRPOS "CHAT.SERVER" (PROCESS.NAME PROC)) (MAPRINT LINE (IF (EQ PROC (THIS.PROCESS)) @@ -795,53 +788,13 @@ Copyright (c) 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights res (ADDTOVAR NLAML ) -(ADDTOVAR LAMA \REMOTE.BIN CHATSERVEROPENFN) -) -(PRETTYCOMPRINT CHATSERVERCOMS) - -(RPAQQ CHATSERVERCOMS - [(FNS CHATSERVER CHATSERVERWHENCLOSEDFN CHATSERVEROPENFN DOBE REQUIRED.LOGIN SERVER-EXEC - SWEEP.OFD \CLEARSYSBUF PROMPTFORWORD \CREATELINEBUFFER \PROMPTFORWORDBIN \REMOTE.BIN - \REMOTE.EXEC.OUTCHARFN CHATSERVER.FONT) - (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DISPLAYTERMFLG 'DM)) - (INITVARS (CHATSERVER.PROFILE) - (\SIMPLEIMAGEOPS)) - (P (SETQ CHATSERVERTTBL (COPYTERMTABLE 'ORIG)) - (for I from 1 to 8 do (ECHOCHAR I 'IGNORE CHATSERVERTTBL) - (ECHOCHAR I 'IGNORE ASKUSERTTBL)) - (ECHOCHAR (CHARCODE CR) - 'SIMULATE CHATSERVERTTBL) - (ECHOCHAR (CHARCODE CR) - 'SIMULATE ASKUSERTTBL) - (ECHOCHAR 0 'SIMULATE ASKUSERTTBL) - (ECHOCHAR 0 'SIMULATE CHATSERVERTTBL))) - (ADDVARS (\SWEPT.OFDS)) - (DECLARE%: EVAL@COMPILE DONTCOPY (P (CHECKIMPORTS '(LLCHAR ATERM IMAGEIO FILEIO ATBL AOFD) - T))) - [COMS (FNS SIMPLECHATSERVER) - (INITVARS (CHATSERVERWINDOW) - (CHATSERVERWINDOWREGION '(11 228 392 190] - (MACROS \SYNCODE) - (DECLARE%: DONTEVAL@LOAD DOCOPY (FILES CL-TTYEDIT SIMPLECHAT) - (ADVISE MENU CHAT RINGBELLS)) - (COMMANDS "QUIT" "SAY") - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA CHATSERVEROPENFN]) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - (ADDTOVAR LAMA CHATSERVEROPENFN) ) -(PUTPROPS CHATSERVER COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987 1988)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2216 38509 (CHATSERVER 2226 . 3955) (CHATSERVERWHENCLOSEDFN 3957 . 4304) ( -CHATSERVEROPENFN 4306 . 8433) (DOBE 8435 . 8481) (REQUIRED.LOGIN 8483 . 11220) (SERVER-EXEC 11222 . -11395) (SWEEP.OFD 11397 . 11933) (\CLEARSYSBUF 11935 . 12184) (PROMPTFORWORD 12186 . 26531) ( -\CREATELINEBUFFER 26533 . 28708) (\PROMPTFORWORDBIN 28710 . 31646) (\REMOTE.BIN 31648 . 33890) ( -\REMOTE.EXEC.OUTCHARFN 33892 . 38114) (CHATSERVER.FONT 38116 . 38507)) (39151 41493 (SIMPLECHATSERVER -39161 . 41491))))) + (FILEMAP (NIL (2029 38278 (CHATSERVER 2039 . 3768) (CHATSERVERWHENCLOSEDFN 3770 . 4117) ( +CHATSERVEROPENFN 4119 . 8246) (DOBE 8248 . 8294) (REQUIRED.LOGIN 8296 . 11033) (SERVER-EXEC 11035 . +11208) (SWEEP.OFD 11210 . 11746) (\CLEARSYSBUF 11748 . 11997) (PROMPTFORWORD 11999 . 26344) ( +\CREATELINEBUFFER 26346 . 28477) (\PROMPTFORWORDBIN 28479 . 31415) (\REMOTE.BIN 31417 . 33659) ( +\REMOTE.EXEC.OUTCHARFN 33661 . 37883) (CHATSERVER.FONT 37885 . 38276)) (38905 41247 (SIMPLECHATSERVER +38915 . 41245))))) STOP diff --git a/lispusers/CHATSERVER.LCOM b/lispusers/CHATSERVER.LCOM index c83e8943..0fdda446 100644 Binary files a/lispusers/CHATSERVER.LCOM and b/lispusers/CHATSERVER.LCOM differ diff --git a/lispusers/COMMWINDOW b/lispusers/COMMWINDOW index 4778f182..92cda872 100644 --- a/lispusers/COMMWINDOW +++ b/lispusers/COMMWINDOW @@ -1,95 +1,88 @@ -(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) -(FILECREATED " 2-Apr-87 17:06:05" {ERIS}LYRIC>COMMWINDOW.;3 49786 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (VARS REMOTE-CURSOR COMMWINDOWCOMS) - (COURIERPROGRAMS COMMWINDOW) - (FNS CLOSE-FRAME START-GET-BITS SEND-BITS FRAME-EVENT MAKE-FRAME) - (FUNCTIONS \PILOTBITBLT) +(FILECREATED "18-Feb-2026 16:21:29" {WMEDLEY}COMMWINDOW.;2 48680 - previous date%: " 2-Apr-87 16:54:24" {ERIS}LYRIC>COMMWINDOW.;2) + :EDIT-BY rmk + :PREVIOUS-DATE " 2-Apr-87 17:06:05" {WMEDLEY}COMMWINDOW.;1) -(* " -Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT COMMWINDOWCOMS) -(RPAQQ COMMWINDOWCOMS ( +(RPAQQ COMMWINDOWCOMS + ( (* ;;; "Viewer end") - (FNS CLOSE-FRAME GET-BITS START-GET-BITS) - (FILES COURIERSERVE) - + (FNS CLOSE-FRAME GET-BITS START-GET-BITS) + (FILES COURIERSERVE) + (* ;;; "Sender end") - (FNS SEND-BITS SEND-TILE LISTEN-TO-VIEWER MAPTILES SHUT-DOWN-VIEWER - CHANGE-SENDER-UPDATE-MODE) - (FUNCTIONS INCR \PILOTBITBLT) - - - (* ;; "Controling update schemes") + (FNS SEND-BITS SEND-TILE LISTEN-TO-VIEWER MAPTILES SHUT-DOWN-VIEWER CHANGE-SENDER-UPDATE-MODE + ) + (FUNCTIONS INCR \PILOTBITBLT) + + (* ;; "Controling update schemes") - (INITVARS (COMM.DEFAULT.TRANSMIT.TYPE 'SQUARE) - (COMM.SEND.UNCHANGED.TILES T) - (COMM.UPDATE.MOUSE.POSITION 'Sender)) - (GLOBALVARS COMM.DEFAULT.TRANSMIT.TYPE COMM.UPDATE.MOUSE.POSITION - COMM.SEND.UNCHANGED.TILES) - + (INITVARS (COMM.DEFAULT.TRANSMIT.TYPE 'SQUARE) + (COMM.SEND.UNCHANGED.TILES T) + (COMM.UPDATE.MOUSE.POSITION 'Sender)) + (GLOBALVARS COMM.DEFAULT.TRANSMIT.TYPE COMM.UPDATE.MOUSE.POSITION COMM.SEND.UNCHANGED.TILES) + (* ;;; "Pruning out unchanged screen tiles") - (FNS PACKET-EQUAL GET-CACHED-PACKET PUT-CACHED-PACKET) - + (FNS PACKET-EQUAL GET-CACHED-PACKET PUT-CACHED-PACKET) + (* ;;; "Low level packet exchange code") - (CONSTANTS COMM.BAND.PACKET.TYPE COMM.CURSOR.PACKET.TYPE - COMM.CURSOR.CLOSE.PACKET.TYPE COMM.SHUT.DOWN.PACKET.TYPE) - (VARIABLES MAX-PACKET-BITS) - (RECORDS COMM.XFER.PACKET) - + (CONSTANTS COMM.BAND.PACKET.TYPE COMM.CURSOR.PACKET.TYPE COMM.CURSOR.CLOSE.PACKET.TYPE + COMM.SHUT.DOWN.PACKET.TYPE) + (VARIABLES MAX-PACKET-BITS) + (RECORDS COMM.XFER.PACKET) + (* ;;; "Packing and unpacking bitmaps into etherpackets") - (FNS BMTOPACKET PACKETTOBM) - + (FNS BMTOPACKET PACKETTOBM) + (* ;;; "Displaying the viewing machine's cursor") - (VARS REMOTE-CURSOR) - (INITVARS (CURSORICON NIL)) - + (VARS REMOTE-CURSOR) + (INITVARS (CURSORICON NIL)) + (* ;;; "Manipulating the frame that outlines the region being viewed") - (INITVARS (*FRAME-SHADE* GRAYSHADE)) - (FNS FRAME-EVENT MAKE-FRAME MOVE-FRAME SHAPE-FRAME SET-FRAME-TITLE) - + (INITVARS (*FRAME-SHADE* GRAYSHADE)) + (FNS FRAME-EVENT MAKE-FRAME MOVE-FRAME SHAPE-FRAME SET-FRAME-TITLE) + (* ;;; "Changing the system parameters") - (FNS MAKE-MENUS-WINDOW MODE-MENU) - (VARS COMM-MODES) - + (FNS MAKE-MENUS-WINDOW MODE-MENU) + (VARS COMM-MODES) + (* ;;; "Initialization") - (P (COURIER.START.SERVER)) - + (P (COURIER.START.SERVER)) + (* ;;; "Unused stuff, as far as I can tell") - (FNS FASTBITBLT) - + (FNS FASTBITBLT) + (* ;;; "System file dependencies") - (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (LOADCOMP) - LLDISPLAY LLETHER LLNS)) - (COURIERPROGRAMS COMMWINDOW))) + (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (LOADCOMP) + LLDISPLAY LLETHER LLNS)) + (COURIERPROGRAMS COMMWINDOW))) @@ -236,6 +229,7 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved. (LIST 'RETURN (LIST (NSOCKETNUMBER NS) (USERNAME]) ) + (FILESLOAD COURIERSERVE) @@ -446,19 +440,18 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved. (SETQ COMM.DEFAULT.TRANSMIT.TYPE NEW-MODE))) ) -(DEFMACRO INCR (VAR START HEIGHT REPEATS UNTIL &REST FORMS) +(DEFMACRO INCR (VAR START HEIGHT REPEATS UNTIL &REST FORMS) `(CL:DO ((REPEAT-COUNT 0 (+ REPEAT-COUNT 1))) ((>= REPEAT-COUNT ,REPEATS)) - (CL:DO [(,VAR (+ ,START (CL:* REPEAT-COUNT ,HEIGHT)) - (+ ,VAR (CL:* ,REPEATS ,HEIGHT] - (,UNTIL) - ,@FORMS))) - - -(DEFMACRO \PILOTBITBLT (XCL-USER::TABLE &OPTIONAL (XCL-USER::N 0)) (CL:ASSERT (EQL XCL-USER::N 0)) - `((OPCODES PILOTBITBLT) - ,XCL-USER::TABLE 0)) + (CL:DO [(,VAR (+ ,START (CL:* REPEAT-COUNT ,HEIGHT)) + (+ ,VAR (CL:* ,REPEATS ,HEIGHT] + (,UNTIL) + ,@FORMS))) +(DEFMACRO \PILOTBITBLT (XCL-USER::TABLE &OPTIONAL (XCL-USER::N 0)) + (CL:ASSERT (EQL XCL-USER::N 0)) + `((OPCODES PILOTBITBLT) + ,XCL-USER::TABLE 0)) @@ -525,12 +518,12 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved. (RPAQQ COMM.SHUT.DOWN.PACKET.TYPE 4246) + (CONSTANTS COMM.BAND.PACKET.TYPE COMM.CURSOR.PACKET.TYPE COMM.CURSOR.CLOSE.PACKET.TYPE COMM.SHUT.DOWN.PACKET.TYPE) ) -(CL:DEFCONSTANT MAX-PACKET-BITS (CL:* 400 8) ) - +(CL:DEFCONSTANT MAX-PACKET-BITS (CL:* 400 8)) (DECLARE%: EVAL@COMPILE (ACCESSFNS COMM.XFER.PACKET ((COMMPACKET (fetch (XIP XIPCONTENTS) of DATUM))) @@ -807,6 +800,7 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved. (* ;;; "Initialization") + (COURIER.START.SERVER) @@ -862,6 +856,7 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved. (* ;;; "System file dependencies") (DECLARE%: DONTCOPY DOEVAL@COMPILE + (FILESLOAD (LOADCOMP) LLDISPLAY LLETHER LLNS) ) @@ -885,14 +880,14 @@ Copyright (c) 1986, 1900, 1987 by Xerox Corporation. All rights reserved. ERRORS ((ERROR 1 (STRING)) (USE.COURIER 2 NIL))) -(PUTPROPS COMMWINDOW COPYRIGHT ("Xerox Corporation" 1986 1900 1987)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3203 13134 (CLOSE-FRAME 3213 . 3364) (GET-BITS 3366 . 11655) (START-GET-BITS 11657 . -13132)) (13189 26236 (SEND-BITS 13199 . 16020) (SEND-TILE 16022 . 19145) (LISTEN-TO-VIEWER 19147 . -20450) (MAPTILES 20452 . 25175) (SHUT-DOWN-VIEWER 25177 . 26046) (CHANGE-SENDER-UPDATE-MODE 26048 . -26234)) (27219 29090 (PACKET-EQUAL 27229 . 28632) (GET-CACHED-PACKET 28634 . 28949) (PUT-CACHED-PACKET - 28951 . 29088)) (30529 34252 (BMTOPACKET 30539 . 32500) (PACKETTOBM 32502 . 34250)) (34556 38865 ( -FRAME-EVENT 34566 . 35224) (MAKE-FRAME 35226 . 37008) (MOVE-FRAME 37010 . 37280) (SHAPE-FRAME 37282 . -38672) (SET-FRAME-TITLE 38674 . 38863)) (38915 45792 (MAKE-MENUS-WINDOW 38925 . 41284) (MODE-MENU -41286 . 45790)) (45968 48955 (FASTBITBLT 45978 . 48953))))) + (FILEMAP (NIL (2306 12237 (CLOSE-FRAME 2316 . 2467) (GET-BITS 2469 . 10758) (START-GET-BITS 10760 . +12235)) (12293 25340 (SEND-BITS 12303 . 15124) (SEND-TILE 15126 . 18249) (LISTEN-TO-VIEWER 18251 . +19554) (MAPTILES 19556 . 24279) (SHUT-DOWN-VIEWER 24281 . 25150) (CHANGE-SENDER-UPDATE-MODE 25152 . +25338)) (25342 25656 (INCR 25342 . 25656)) (25658 25816 (\PILOTBITBLT 25658 . 25816)) (26181 28052 ( +PACKET-EQUAL 26191 . 27594) (GET-CACHED-PACKET 27596 . 27911) (PUT-CACHED-PACKET 27913 . 28050)) ( +29490 33213 (BMTOPACKET 29500 . 31461) (PACKETTOBM 31463 . 33211)) (33517 37826 (FRAME-EVENT 33527 . +34185) (MAKE-FRAME 34187 . 35969) (MOVE-FRAME 35971 . 36241) (SHAPE-FRAME 36243 . 37633) ( +SET-FRAME-TITLE 37635 . 37824)) (37876 44753 (MAKE-MENUS-WINDOW 37886 . 40245) (MODE-MENU 40247 . +44751)) (44930 47917 (FASTBITBLT 44940 . 47915))))) STOP diff --git a/lispusers/COMMWINDOW.LCOM b/lispusers/COMMWINDOW.LCOM index 6a102069..88c9531d 100644 Binary files a/lispusers/COMMWINDOW.LCOM and b/lispusers/COMMWINDOW.LCOM differ diff --git a/lispusers/COMPAREDIRECTORIES b/lispusers/COMPAREDIRECTORIES index 2531735b..36bf7841 100644 --- a/lispusers/COMPAREDIRECTORIES +++ b/lispusers/COMPAREDIRECTORIES @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 8-Nov-2025 13:07:39" {WMEDLEY}COMPAREDIRECTORIES.;285 138536 +(FILECREATED "10-Feb-2026 21:28:55" {WMEDLEY}COMPAREDIRECTORIES.;286 138607 :EDIT-BY rmk - :CHANGES-TO (FNS CD-MENUFN CDBROWSER-COPY) + :CHANGES-TO (FNS CD-MENUFN) - :PREVIOUS-DATE "28-Oct-2025 14:52:05" {WMEDLEY}COMPAREDIRECTORIES.;280) + :PREVIOUS-DATE " 8-Nov-2025 13:07:39" {WMEDLEY}COMPAREDIRECTORIES.;285) (PRETTYCOMPRINT COMPAREDIRECTORIESCOMS) @@ -1983,6 +1983,8 @@ (CD-MENUFN [LAMBDA (TBITEM MENUITEM CDBROWSER KEY) + (* ;; "Edited 10-Feb-2026 21:28 by rmk") + (* ;; "Edited 8-Nov-2025 13:06 by rmk") (* ;; "Edited 28-Oct-2025 17:35 by rmk") @@ -2059,11 +2061,11 @@ ELSE (FLASHWINDOW T) (PRIN3 "No file to print" T))) ((See See% both) - (IF (PDFFILEP FILE1) + (IF (AND FILE1 (PDFFILEP FILE1)) then (SEE-PDF FILE1) - (CL:WHEN (PDFFILEP FILE2) + (CL:WHEN (AND FILE2 (PDFFILEP FILE2)) (SEE-PDF FILE2)) - elseif (PDFFILEP FILE2) + elseif (AND FILE2 (PDFFILEP FILE2)) then (SEE-PDF FILE2) else (EXAMINEFILES FILE1 FILE2 LABEL1 LABEL2 (RELCREATEREGION (ITIMES 2 (CL:IF (LISPSOURCEFILEP FILE1) @@ -2321,25 +2323,25 @@ (MOVD? 'NILL 'TEDIT.FILEDATE) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2668 23647 (COMPAREDIRECTORIES 2678 . 8013) (COMPAREDIRECTORIES.INFOS 8015 . 11244) ( -COMPAREDIRECTORIES.CANDIDATES 11246 . 14631) (CDENTRIES.SELECT 14633 . 19535) ( -COMPAREDIRECTORIES.INFOS.TYPE 19537 . 20881) (MATCHNAME 20883 . 21563) (CD.INSURECDVALUE 21565 . 23179 -) (CD.UPDATEWIDTHS 23181 . 23645)) (23648 34353 (CDFILES 23658 . 29755) (CDFILES.MATCH 29757 . 31382) -(CDFILES.PATS 31384 . 34351)) (34354 52372 (CDPRINT 34364 . 36881) (CDPRINT.HEADER 36883 . 37780) ( -CDPRINT.LINE 37782 . 41211) (CDPRINT.MAXWIDTHS 41213 . 45328) (CDPRINT.COLHEADERS 45330 . 46615) ( -CDPRINT.COLUMNS 46617 . 51737) (CDTEDIT 51739 . 52370)) (52373 61494 (CDMAP 52383 . 53815) (CDENTRY -53817 . 54126) (CDSUBSET 54128 . 55567) (CDMERGE 55569 . 59553) (CDMERGE.COMMON 59555 . 60870) ( -CD.SORT 60872 . 61492)) (61495 69033 (BINCOMP 61505 . 65794) (EOLTYPE 65796 . 68358) (EOLTYPE.SHOW -68360 . 69031)) (69561 82088 (FIND-UNCOMPILED-FILES 69571 . 73214) (FIND-UNSOURCED-FILES 73216 . 75600 -) (FIND-SOURCE-FILES 75602 . 77340) (FIND-COMPILED-FILES 77342 . 79219) (FIND-UNLOADED-FILES 79221 . -80074) (FIND-LOADED-FILES 80076 . 80504) (FIND-MULTICOMPILED-FILES 80506 . 82086)) (82089 90520 ( -CREATED-AS 82099 . 86896) (SOURCE-FOR-COMPILED-P 86898 . 89825) (COMPILE-SOURCE-DATE-DIFF 89827 . -90518)) (90521 101284 (FIX-DIRECTORY-DATES 90531 . 93981) (FIX-EQUIV-DATES 93983 . 95508) ( -COPY-COMPARED-FILES 95510 . 97331) (COPY-MISSING-FILES 97333 . 99490) (COMPILED-ON-SAME-SOURCE 99492 - . 101282)) (101478 109356 (CDBROWSER 101488 . 105455) (CDBROWSER.STRINGS 105457 . 109354)) (109518 -111254 (CD.TABLEITEM 109528 . 109748) (CD.TABLEITEM.PRINTFN 109750 . 109949) (CD.TABLEITEM.COPYFN -109951 . 111009) (CDTABLEBROWSER.HEADING.REPAINTFN 111011 . 111252)) (111255 138020 ( -CDTABLEBROWSER.WHENSELECTEDFN 111265 . 111733) (CD.COMMANDSELECTEDFN 111735 . 117908) (CD-MENUFN -117910 . 124301) (CD-COMPARE-FILES 124303 . 127830) (CDBROWSER-COPY 127832 . 132894) ( -CDBROWSER-DELETE-FILE 132896 . 137499) (CD-SWAPDIRS 137501 . 138018))))) + (FILEMAP (NIL (2653 23632 (COMPAREDIRECTORIES 2663 . 7998) (COMPAREDIRECTORIES.INFOS 8000 . 11229) ( +COMPAREDIRECTORIES.CANDIDATES 11231 . 14616) (CDENTRIES.SELECT 14618 . 19520) ( +COMPAREDIRECTORIES.INFOS.TYPE 19522 . 20866) (MATCHNAME 20868 . 21548) (CD.INSURECDVALUE 21550 . 23164 +) (CD.UPDATEWIDTHS 23166 . 23630)) (23633 34338 (CDFILES 23643 . 29740) (CDFILES.MATCH 29742 . 31367) +(CDFILES.PATS 31369 . 34336)) (34339 52357 (CDPRINT 34349 . 36866) (CDPRINT.HEADER 36868 . 37765) ( +CDPRINT.LINE 37767 . 41196) (CDPRINT.MAXWIDTHS 41198 . 45313) (CDPRINT.COLHEADERS 45315 . 46600) ( +CDPRINT.COLUMNS 46602 . 51722) (CDTEDIT 51724 . 52355)) (52358 61479 (CDMAP 52368 . 53800) (CDENTRY +53802 . 54111) (CDSUBSET 54113 . 55552) (CDMERGE 55554 . 59538) (CDMERGE.COMMON 59540 . 60855) ( +CD.SORT 60857 . 61477)) (61480 69018 (BINCOMP 61490 . 65779) (EOLTYPE 65781 . 68343) (EOLTYPE.SHOW +68345 . 69016)) (69546 82073 (FIND-UNCOMPILED-FILES 69556 . 73199) (FIND-UNSOURCED-FILES 73201 . 75585 +) (FIND-SOURCE-FILES 75587 . 77325) (FIND-COMPILED-FILES 77327 . 79204) (FIND-UNLOADED-FILES 79206 . +80059) (FIND-LOADED-FILES 80061 . 80489) (FIND-MULTICOMPILED-FILES 80491 . 82071)) (82074 90505 ( +CREATED-AS 82084 . 86881) (SOURCE-FOR-COMPILED-P 86883 . 89810) (COMPILE-SOURCE-DATE-DIFF 89812 . +90503)) (90506 101269 (FIX-DIRECTORY-DATES 90516 . 93966) (FIX-EQUIV-DATES 93968 . 95493) ( +COPY-COMPARED-FILES 95495 . 97316) (COPY-MISSING-FILES 97318 . 99475) (COMPILED-ON-SAME-SOURCE 99477 + . 101267)) (101463 109341 (CDBROWSER 101473 . 105440) (CDBROWSER.STRINGS 105442 . 109339)) (109503 +111239 (CD.TABLEITEM 109513 . 109733) (CD.TABLEITEM.PRINTFN 109735 . 109934) (CD.TABLEITEM.COPYFN +109936 . 110994) (CDTABLEBROWSER.HEADING.REPAINTFN 110996 . 111237)) (111240 138091 ( +CDTABLEBROWSER.WHENSELECTEDFN 111250 . 111718) (CD.COMMANDSELECTEDFN 111720 . 117893) (CD-MENUFN +117895 . 124372) (CD-COMPARE-FILES 124374 . 127901) (CDBROWSER-COPY 127903 . 132965) ( +CDBROWSER-DELETE-FILE 132967 . 137570) (CD-SWAPDIRS 137572 . 138089))))) STOP diff --git a/lispusers/COMPAREDIRECTORIES.LCOM b/lispusers/COMPAREDIRECTORIES.LCOM index 7569b398..80f806ea 100644 Binary files a/lispusers/COMPAREDIRECTORIES.LCOM and b/lispusers/COMPAREDIRECTORIES.LCOM differ diff --git a/lispusers/COMPILEBANG.LCOM b/lispusers/COMPILEBANG.LCOM index c18e7e1f..0cf3f4c8 100644 Binary files a/lispusers/COMPILEBANG.LCOM and b/lispusers/COMPILEBANG.LCOM differ diff --git a/lispusers/CONVERT-TO-UTF8 b/lispusers/CONVERT-TO-UTF8 new file mode 100644 index 00000000..52342ee1 --- /dev/null +++ b/lispusers/CONVERT-TO-UTF8 @@ -0,0 +1,52 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) + +(FILECREATED "25-Feb-2026 09:09:57" {WMEDLEY}CONVERT-TO-UTF8.;16 2573 + + :EDIT-BY rmk + + :CHANGES-TO (FNS CONVERT-TO-UTF8) + + :PREVIOUS-DATE "24-Feb-2026 22:45:57" {WMEDLEY}CONVERT-TO-UTF8.;14) + + +(PRETTYCOMPRINT CONVERT-TO-UTF8COMS) + +(RPAQQ CONVERT-TO-UTF8COMS ((FNS CONVERT-TO-UTF8))) +(DEFINEQ + +(CONVERT-TO-UTF8 + [LAMBDA (FILENAME FILETYPE) (* ; "Edited 25-Feb-2026 09:09 by rmk") + + (* ;; "This produces a new version of the source FILENAME with :UTF-8 external format.") + + (* ;; "If we had a list of problematic functions (multiple definitions on multiple files, MOVD's), we could check that against the functions in FILENAME, and at least produce a warning.") + + (* ;; "Compiling may be tricky: some files have CL:COMPILE-FILE FILETYPE properties that don't correspond to the fact that they actually have only an LCOM. This tries to revert the filetype back to FAKE-COMPILE-FILE so that we don't get confused when a DFASL mysteriously appears.") + + (SETQ FILENAME (PSEUDOFILENAME FILENAME)) + (SETQ FILENAME (OR (FINDFILE FILENAME T) + (ERROR "FILE NOT FOUND" FILENAME))) + (if [EQ :UTF-8 (CL:WITH-OPEN-FILE (STREAM FILENAME :DIRECTION :INPUT) + (fetch (READER-ENVIRONMENT REFORMAT) of (GET-ENVIRONMENT-AND-FILEMAP STREAM + T] + then (PRINTOUT T FILENAME " is already " .P2 :UTF-8 T) + NIL + else (LOAD? (MEDLEYDIR "loadups" 'EXPORTS.ALL)) (* ; "Maybe this should load SYSEDIT ?") + (LOAD FILENAME 'PROP) + (LOADCOMP FILENAME) + (SETQ FILENAME (PACKFILENAME 'VERSION NIL 'BODY FILENAME)) + (CL:WHEN [AND (EQ 'CL:COMPILE-FILE (GETPROP (ROOTFILENAME FILENAME) + 'FILETYPE)) + (FINDFILE (PACKFILENAME 'EXTENSION 'LCOM 'BODY FILENAME)) + (NOT (FINDFILE (PACKFILENAME 'EXTENSION 'DFASL 'BODY FILENAME] + (CL:UNLESS FILETYPE (SETQ FILETYPE :FAKE-COMPILE-FILE)) + (PRINTOUT T "Changing FILETYPE back to " .P2 FILETYPE T) + (PUTPROP (ROOTFILENAME FILENAME) + 'FILETYPE FILETYPE)) + [SETQ FILENAME (MAKEFILE FILENAME '(NEW :UTF-8] + (MAKEFILE1 FILENAME NIL '(F)) + FILENAME]) +) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (406 2550 (CONVERT-TO-UTF8 416 . 2548))))) +STOP diff --git a/lispusers/CONVERT-TO-UTF8.LCOM b/lispusers/CONVERT-TO-UTF8.LCOM new file mode 100644 index 00000000..413a0c22 Binary files /dev/null and b/lispusers/CONVERT-TO-UTF8.LCOM differ diff --git a/lispusers/CONVERT-TO-UTF8.TEDIT b/lispusers/CONVERT-TO-UTF8.TEDIT new file mode 100644 index 00000000..06488f9c Binary files /dev/null and b/lispusers/CONVERT-TO-UTF8.TEDIT differ diff --git a/lispusers/CROCK b/lispusers/CROCK index ca1390de..a5199b01 100644 --- a/lispusers/CROCK +++ b/lispusers/CROCK @@ -1,43 +1,43 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED " 2-Apr-87 00:37:46" {ERIS}LYRIC>CROCK.;2 17791 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - previous date%: "11-Jan-86 19:46:27" {PHYLUM}LYRIC>CROCK.;1) +(FILECREATED "18-Feb-2026 16:26:31" {WMEDLEY}CROCK.;2 17189 + :EDIT-BY rmk + + :PREVIOUS-DATE " 2-Apr-87 00:37:46" {WMEDLEY}CROCK.;1) -(* " -Copyright (c) 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT CROCKCOMS) -(RPAQQ CROCKCOMS ((* CROCK -- By Kelly Roach *) - (FNS CROCK CROCK.BUTTONEVENTFN CROCK.CHANGE.STYLE CROCK.CLOSEFN CROCK.PROCESS - CROCK.RESHAPEFN CROCK.ALARM CROCK.RING.ALARM CROCK.INIT) - (INITVARS (CROCK.DEFAULT.STYLE '(HANDS T TIMES NIL RINGS NIL NUMBERS T)) - (CROCK.STYLE.MENU) - (CROCK.ALARMS) - (CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS)) - [CROCK.TUNE '((1000 . 1000) - (800 . 1000) - (600 . 1000) - (500 . 1000) - (400 . 1000) - (NIL . 500) - (440 . 1000) - (484 . 1000) - (540 . 1000) - (600 . 1000) - (2000 . 1000) - (1600 . 1000) - (1200 . 1000) - (1000 . 1000) - (800 . 1000) - (NIL . 500) - (880 . 1000) - (968 . 1000) - (1080 . 1000) - (1188 . 1000] - (CROCKWINDOW)))) +(RPAQQ CROCKCOMS + ((* CROCK -- By Kelly Roach *) + (FNS CROCK CROCK.BUTTONEVENTFN CROCK.CHANGE.STYLE CROCK.CLOSEFN CROCK.PROCESS CROCK.RESHAPEFN + CROCK.ALARM CROCK.RING.ALARM CROCK.INIT) + (INITVARS (CROCK.DEFAULT.STYLE '(HANDS T TIMES NIL RINGS NIL NUMBERS T)) + (CROCK.STYLE.MENU) + (CROCK.ALARMS) + (CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS)) + [CROCK.TUNE '((1000 . 1000) + (800 . 1000) + (600 . 1000) + (500 . 1000) + (400 . 1000) + (NIL . 500) + (440 . 1000) + (484 . 1000) + (540 . 1000) + (600 . 1000) + (2000 . 1000) + (1600 . 1000) + (1200 . 1000) + (1000 . 1000) + (800 . 1000) + (NIL . 500) + (880 . 1000) + (968 . 1000) + (1080 . 1000) + (1188 . 1000] + (CROCKWINDOW)))) @@ -334,31 +334,31 @@ Copyright (c) 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved. (RPAQ? CROCK.DATEFORMAT '(DATEFORMAT NO.SECONDS)) -(RPAQ? CROCK.TUNE '((1000 . 1000) - (800 . 1000) - (600 . 1000) - (500 . 1000) - (400 . 1000) - (NIL . 500) - (440 . 1000) - (484 . 1000) - (540 . 1000) - (600 . 1000) - (2000 . 1000) - (1600 . 1000) - (1200 . 1000) - (1000 . 1000) - (800 . 1000) - (NIL . 500) - (880 . 1000) - (968 . 1000) - (1080 . 1000) - (1188 . 1000))) +(RPAQ? CROCK.TUNE + '((1000 . 1000) + (800 . 1000) + (600 . 1000) + (500 . 1000) + (400 . 1000) + (NIL . 500) + (440 . 1000) + (484 . 1000) + (540 . 1000) + (600 . 1000) + (2000 . 1000) + (1600 . 1000) + (1200 . 1000) + (1000 . 1000) + (800 . 1000) + (NIL . 500) + (880 . 1000) + (968 . 1000) + (1080 . 1000) + (1188 . 1000))) (RPAQ? CROCKWINDOW ) -(PUTPROPS CROCK COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1987)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1940 16814 (CROCK 1950 . 2520) (CROCK.BUTTONEVENTFN 2522 . 2811) (CROCK.CHANGE.STYLE -2813 . 5626) (CROCK.CLOSEFN 5628 . 5790) (CROCK.PROCESS 5792 . 14290) (CROCK.RESHAPEFN 14292 . 14451) -(CROCK.ALARM 14453 . 15681) (CROCK.RING.ALARM 15683 . 16424) (CROCK.INIT 16426 . 16812))))) + (FILEMAP (NIL (1609 16483 (CROCK 1619 . 2189) (CROCK.BUTTONEVENTFN 2191 . 2480) (CROCK.CHANGE.STYLE +2482 . 5295) (CROCK.CLOSEFN 5297 . 5459) (CROCK.PROCESS 5461 . 13959) (CROCK.RESHAPEFN 13961 . 14120) +(CROCK.ALARM 14122 . 15350) (CROCK.RING.ALARM 15352 . 16093) (CROCK.INIT 16095 . 16481))))) STOP diff --git a/lispusers/CROCK.LCOM b/lispusers/CROCK.LCOM index f488bb50..4bce6dbe 100644 Binary files a/lispusers/CROCK.LCOM and b/lispusers/CROCK.LCOM differ diff --git a/lispusers/DEFAULTICON b/lispusers/DEFAULTICON index 604d8de6..922406f7 100644 --- a/lispusers/DEFAULTICON +++ b/lispusers/DEFAULTICON @@ -1,14 +1,11 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED "13-Jan-87 01:23:25" {ERIS}LISPCORE>DEFAULTICON.;1 4586 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS \MAKEICONWINDOW) +(FILECREATED "18-Feb-2026 16:26:48" {WMEDLEY}DEFAULTICON.;2 4702 - previous date%: "19-Dec-85 01:24:06" {ERIS}KOTO>LISPUSERS>DEFAULTICON.;1) + :EDIT-BY rmk + :PREVIOUS-DATE "13-Jan-87 01:23:25" {WMEDLEY}DEFAULTICON.;1) -(* " -Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT DEFAULTICONCOMS) @@ -16,137 +13,140 @@ Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. (UGLYVARS \DEFAULTICON) (INITVARS (DEFAULTICON \DEFAULTICON)) (FNS \MAKEICONWINDOW))) + (FILESLOAD ICONW) -(READVARS \DEFAULTICON) -(({(READBITMAP)(64 64 -"@@@@@@@@@@@@@@@@" -"@@@@@@@@@@@@@@@@" -"@@@@@@@@@@@@@@@@" -"@@@@@@@@@@@@@@@@" -"@@@@@@@@@@@@@@@@" -"@@AOOOOOOOOOOH@@" -"@@N@@@@@@@@@@G@@" -"@C@@@@@@@@@@@@L@" -"@D@@@@@@@@@@@@B@" -"@H@@@@@@@@@@@@A@" -"A@@@@@@@@@@@@@@H" -"B@@@@@@@@@@@CO@D" -"B@@@@@@@@@@@BDHD" -"D@@@@@@@@@@@ABDB" -"D@@@@@@@@@@@AODB" -"D@@@@@@@@@@@ABLB" -"D@@@@@@@@@@@ABDA" -"H@@@@@@@@@@@ABDA" -"H@@@@@@@@@@@AOHA" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"H@@@@@@@@@@@@@@A" -"D@@@@@@@@@@@@@@B" -"D@@@@@@@@@@@@@@B" -"D@@@@@@@@@@@@@@B" -"B@@@@@@@@@@@@@@D" -"B@@@@@@@@@@@@@@D" -"A@@@@@@@@@@@@@@H" -"@H@@@@@@@@@@@@A@" -"@D@@@@@@@@@@@@B@" -"@C@@@@@@@@@@@@L@" -"@@N@@@@@@@@@@G@@" -"@@AOOOOOOOOOOH@@")} {(READBITMAP)(64 64 -"@@@@@@@@@@@@@@@@" -"@@@@@@@@@@@@@@@@" -"@@@@@@@@@@@@@@@@" -"@@@@@@@@@@@@@@@@" -"@@@@@@@@@@@@@@@@" -"@@AOOOOOOOOOOH@@" -"@@OOOOOOOOOOOO@@" -"@COOOOOOOOOOOOL@" -"@GOOOOOOOOOOOON@" -"@OOOOOOOOOOOOOO@" -"AOOOOOOOOOOOOOOH" -"COOOOOOOOOOOOOOL" -"COOOOOOOOOOONDOL" -"GOOOOOOOOOOOOBGN" -"GOOOOOOOOOOOOOGN" -"GOOOOOOOOOOOOBON" -"GOOOOOOOOOOOOBGO" -"OOOOOOOOOOOOOBGO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"OOOOOOOOOOOOOOOO" -"GOOOOOOOOOOOOOON" -"GOOOOOOOOOOOOOON" -"GOOOOOOOOOOOOOON" -"COOOOOOOOOOOOOOL" -"COOOOOOOOOOOOOOL" -"AOOOOOOOOOOOOOOH" -"@OOOOOOOOOOOOOO@" -"@GOOOOOOOOOOOON@" -"@COOOOOOOOOOOOL@" -"@@OOOOOOOOOOOO@@" -"@@AOOOOOOOOOOH@@")} (5 6 52 46))) + +(READVARS-FROM-STRINGS '(\DEFAULTICON) + "(({(READBITMAP)(64 64 +%"@@@@@@@@@@@@@@@@%" +%"@@@@@@@@@@@@@@@@%" +%"@@@@@@@@@@@@@@@@%" +%"@@@@@@@@@@@@@@@@%" +%"@@@@@@@@@@@@@@@@%" +%"@@AOOOOOOOOOOH@@%" +%"@@N@@@@@@@@@@G@@%" +%"@C@@@@@@@@@@@@L@%" +%"@D@@@@@@@@@@@@B@%" +%"@H@@@@@@@@@@@@A@%" +%"A@@@@@@@@@@@@@@H%" +%"B@@@@@@@@@@@CO@D%" +%"B@@@@@@@@@@@BDHD%" +%"D@@@@@@@@@@@ABDB%" +%"D@@@@@@@@@@@AODB%" +%"D@@@@@@@@@@@ABLB%" +%"D@@@@@@@@@@@ABDA%" +%"H@@@@@@@@@@@ABDA%" +%"H@@@@@@@@@@@AOHA%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"H@@@@@@@@@@@@@@A%" +%"D@@@@@@@@@@@@@@B%" +%"D@@@@@@@@@@@@@@B%" +%"D@@@@@@@@@@@@@@B%" +%"B@@@@@@@@@@@@@@D%" +%"B@@@@@@@@@@@@@@D%" +%"A@@@@@@@@@@@@@@H%" +%"@H@@@@@@@@@@@@A@%" +%"@D@@@@@@@@@@@@B@%" +%"@C@@@@@@@@@@@@L@%" +%"@@N@@@@@@@@@@G@@%" +%"@@AOOOOOOOOOOH@@%")} {(READBITMAP)(64 64 +%"@@@@@@@@@@@@@@@@%" +%"@@@@@@@@@@@@@@@@%" +%"@@@@@@@@@@@@@@@@%" +%"@@@@@@@@@@@@@@@@%" +%"@@@@@@@@@@@@@@@@%" +%"@@AOOOOOOOOOOH@@%" +%"@@OOOOOOOOOOOO@@%" +%"@COOOOOOOOOOOOL@%" +%"@GOOOOOOOOOOOON@%" +%"@OOOOOOOOOOOOOO@%" +%"AOOOOOOOOOOOOOOH%" +%"COOOOOOOOOOOOOOL%" +%"COOOOOOOOOOONDOL%" +%"GOOOOOOOOOOOOBGN%" +%"GOOOOOOOOOOOOOGN%" +%"GOOOOOOOOOOOOBON%" +%"GOOOOOOOOOOOOBGO%" +%"OOOOOOOOOOOOOBGO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"OOOOOOOOOOOOOOOO%" +%"GOOOOOOOOOOOOOON%" +%"GOOOOOOOOOOOOOON%" +%"GOOOOOOOOOOOOOON%" +%"COOOOOOOOOOOOOOL%" +%"COOOOOOOOOOOOOOL%" +%"AOOOOOOOOOOOOOOH%" +%"@OOOOOOOOOOOOOO@%" +%"@GOOOOOOOOOOOON@%" +%"@COOOOOOOOOOOOL@%" +%"@@OOOOOOOOOOOO@@%" +%"@@AOOOOOOOOOOH@@%")} (5 6 52 46))) +") (RPAQ? DEFAULTICON \DEFAULTICON) (DEFINEQ @@ -175,7 +175,6 @@ Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. (WINDOWPROP icon 'HEIGHT] icon]) ) -(PUTPROPS DEFAULTICON COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3170 4498 (\MAKEICONWINDOW 3180 . 4496))))) + (FILEMAP (NIL (3351 4679 (\MAKEICONWINDOW 3361 . 4677))))) STOP diff --git a/lispusers/DEFAULTSUBITEMFN b/lispusers/DEFAULTSUBITEMFN index 9ea07293..671dd038 100644 --- a/lispusers/DEFAULTSUBITEMFN +++ b/lispusers/DEFAULTSUBITEMFN @@ -1,17 +1,17 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED " 4-Mar-87 15:59:01" {PHYLUM}LYRIC>DEFAULTSUBITEMFN.;1 1299 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - previous date%: "31-Jan-86 17:45:55" {PHYLUM}KOTO>LISPUSERS>DEFAULTSUBITEMFN.;1) +(FILECREATED "18-Feb-2026 16:28:38" {WMEDLEY}DEFAULTSUBITEMFN.;2 1229 + :EDIT-BY rmk + + :PREVIOUS-DATE " 4-Mar-87 15:59:01" {WMEDLEY}DEFAULTSUBITEMFN.;1) -(* " -Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT DEFAULTSUBITEMFNCOMS) -(RPAQQ DEFAULTSUBITEMFNCOMS ((* * redefine the DEFAULTSUBITEMFN to add the EVAL keyword to the subitem menu field) (FNS DEFAULTSUBITEMFN)) -) +(RPAQQ DEFAULTSUBITEMFNCOMS ((* * redefine the DEFAULTSUBITEMFN to add the EVAL keyword to the + subitem menu field) + (FNS DEFAULTSUBITEMFN))) (* * redefine the DEFAULTSUBITEMFN to add the EVAL keyword to the subitem menu field) (DEFINEQ @@ -20,7 +20,6 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (LAMBDA (MENU ITEM) (* edited%: "31-Dec-85 16:41") (* rrb "17-Aug-84 17:24") (* default subitemfn for menus. Checks the fourth element of the item for an expression of the form (SUBITEMS a b c) or if the fourth element is (EVAL form) will return the value of form. MENU and ITEM will be available during the evaluation) (PROG (TEMP) (RETURN (if (AND (LISTP ITEM) (LISTP (SETQ TEMP (CDR ITEM))) (LISTP (SETQ TEMP (CDR TEMP))) (LISTP (SETQ TEMP (CDR TEMP)))) then (SELECTQ (CAR (SETQ TEMP (LISTP (CAR TEMP)))) (SUBITEMS (CDR TEMP)) (EVAL (EVAL (CADR TEMP))) NIL))))) ) ) -(PUTPROPS DEFAULTSUBITEMFN COPYRIGHT ("Xerox Corporation" 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (606 1206 (DEFAULTSUBITEMFN 616 . 1204))))) STOP diff --git a/lispusers/DEFAULTSUBITEMFN.LCOM b/lispusers/DEFAULTSUBITEMFN.LCOM index 98190d4c..8152410b 100644 Binary files a/lispusers/DEFAULTSUBITEMFN.LCOM and b/lispusers/DEFAULTSUBITEMFN.LCOM differ diff --git a/lispusers/GITFNS b/lispusers/GITFNS index 4b5cbe62..7b9e5ad3 100644 --- a/lispusers/GITFNS +++ b/lispusers/GITFNS @@ -1,12 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8) -(FILECREATED "28-Oct-2025 14:10:06" {WMEDLEY}GITFNS.;569 131593 +(FILECREATED " 2-Mar-2026 14:00:13" {WMEDLEY}GITFNS.;576 133513 :EDIT-BY rmk - :CHANGES-TO (FNS GIT-WORKING-COMPARE-DIRECTORIES GIT-BRANCHES-COMPARE-DIRECTORIES) + :CHANGES-TO (FNS GIT-MY-NEXT-BRANCH) - :PREVIOUS-DATE "28-Oct-2025 13:32:16" {WMEDLEY}GITFNS.;568) + :PREVIOUS-DATE "26-Feb-2026 00:39:22" {WMEDLEY}GITFNS.;575) (PRETTYCOMPRINT GITFNSCOMS) @@ -74,7 +74,7 @@ (* ;; "Differences") - (FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS) + (FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS GIT-MODIFIED) (* ;; "") @@ -169,6 +169,7 @@ (GIT-MAKE-PROJECT [LAMBDA (PROJECTNAME CLONEPATH WORKINGPATH EXCLUSIONS DEFAULTSUBDIRS) + (* ; "Edited 25-Feb-2026 23:25 by rmk") (* ; "Edited 25-Oct-2025 16:53 by rmk") (* ; "Edited 22-Oct-2025 12:45 by rmk") (* ; "Edited 20-Oct-2025 18:10 by rmk") @@ -234,9 +235,8 @@ (CL:WHEN (SETQ GITIGNORE (INFILEP (PACKFILENAME.STRING 'NAME ".gitignore" 'BODY CLONEPATH))) (SETQ GITIGNORE (CL:WITH-OPEN-FILE (STREAM GITIGNORE :EXTERNAL-FORMAT :UTF-8) - (bind L until (EOFP STREAM) - while (SETQ L (CL:READ-LINE STREAM :EOF-ERROR-P NIL - :EOF-VALUE NIL)) + (bind L until (EOFP STREAM) while (SETQ L (CL:READ-LINE + STREAM NIL)) unless (OR (EQ 0 (NCHARS L)) (STRPOS "#" L)) collect L)))) (SETQ EXCLUSIONS (CL:REMOVE-DUPLICATES (APPEND (for E inside EXCLUSIONS @@ -274,16 +274,16 @@ "") "for " PROJECTNAME] (SETQ PROJECT (create GIT-PROJECT - PROJECTNAME _ PROJECTNAME - GITHOST _ (PACK* "{" (PSEUDOHOST PROJECTNAME CLONEPATH) + PROJECTNAME ↠PROJECTNAME + GITHOST ↠(PACK* "{" (PSEUDOHOST PROJECTNAME CLONEPATH) "}") - WHOST _ (AND WORKINGPATH (PACK* "{" (PSEUDOHOST (CONCAT "W" + WHOST ↠(AND WORKINGPATH (PACK* "{" (PSEUDOHOST (CONCAT "W" PROJECTNAME) WORKINGPATH) "}")) - EXCLUSIONS _ EXCLUSIONS - DEFAULTSUBDIRS _ (MKLIST DEFAULTSUBDIRS) - CLONEPATH _ CLONEPATH)) + EXCLUSIONS ↠EXCLUSIONS + DEFAULTSUBDIRS ↠(MKLIST DEFAULTSUBDIRS) + CLONEPATH ↠CLONEPATH)) (/RPLACD [OR (ASSOC PROJECTNAME GIT-PROJECTS) (CAR (push GIT-PROJECTS (CONS PROJECTNAME] PROJECT) @@ -358,7 +358,7 @@ (FIND-ANCESTOR-DIRECTORY [LAMBDA (STARTDIR PREDFN) (* ; "Edited 8-May-2022 12:17 by rmk") - (BIND POS (A _ STARTDIR) WHILE (SETQ POS (STRPOS "/" A -2 NIL NIL NIL FILEDIRCASEARRAY T)) + (BIND POS (A ↠STARTDIR) WHILE (SETQ POS (STRPOS "/" A -2 NIL NIL NIL FILEDIRCASEARRAY T)) DO (SETQ A (SUBSTRING A 1 POS)) (CL:WHEN (APPLY* PREDFN A) (RETURN A]) @@ -372,7 +372,7 @@ (GIT-CLONEP (GIT-PROJECT-PATH PROJECTNAME PROJECTPATH) T T) [FIND-ANCESTOR-DIRECTORY PROJECTPATH (FUNCTION (LAMBDA (A) - (BIND D (GEN _ (\GENERATEFILES A NIL NIL 1)) + (BIND D (GEN ↠(\GENERATEFILES A NIL NIL 1)) WHILE (SETQ D (\GENERATENEXTFILE GEN)) WHEN (GIT-CLONEP D T) DO (RETFROM (FUNCTION @@ -684,7 +684,7 @@ (GIT-MAINBRANCH? (GIT-WHICH-BRANCH PROJECT) PROJECT) - (FOR MF GF DEST (MEDLEYSUBDIRS _ (MEDLEYSUBDIRS PROJECT)) INSIDE MFILES + (FOR MF GF DEST (MEDLEYSUBDIRS ↠(MEDLEYSUBDIRS PROJECT)) INSIDE MFILES COLLECT (SETQ MF (OR (FINDFILE MF NIL MEDLEYSUBDIRS) (ERROR "FILE NOT FOUND" MF))) (CL:UNLESS (STRING.EQUAL MF (INFILEP (PACKFILENAME 'VERSION NIL 'BODY MF)) @@ -709,7 +709,7 @@ (* ;; "Does anybody call this?") (SETQ PROJECT (GIT-GET-PROJECT PROJECT)) - (FOR GF MF DEST (GITSUBDIRS _ (GITSUBDIRS PROJECT)) INSIDE GFILES + (FOR GF MF DEST (GITSUBDIRS ↠(GITSUBDIRS PROJECT)) INSIDE GFILES COLLECT (SETQ GF (OR (FINDFILE GF NIL GITSUBDIRS) (ERROR "FILE NOT FOUND" GF))) (SETQ MF (MFILE4GFILE GF)) @@ -742,8 +742,8 @@ "")]) (STRIPDIR - [LAMBDA (FILE DIRECTORY) (* ; "Edited 18-Jan-2022 16:09 by rmk") - (* ; "Edited 8-Nov-2021 11:50 by rmk:") + [LAMBDA (FILE DIRECTORY) (* ; "Edited 18-Jan-2022 16:09 by rmk") + (* ; "Edited 8-Nov-2021 11:50 by rmk:") (IF (STRPOS DIRECTORY FILE 1 NIL T NIL FILEDIRCASEARRAY) THEN (SUBSTRING FILE (ADD1 (NCHARS DIRECTORY))) ELSE FILE]) @@ -1023,7 +1023,7 @@ ": ") (IF (EQ (CAR X) 'Comments) - THEN (FOR CC (POS _ (POSITION T)) IN (CDR X) + THEN (FOR CC (POS ↠(POSITION T)) IN (CDR X) DO (IF (EQ CC T) THEN (TERPRI T) ELSE (PRINTOUT T .TAB0 POS CC))) @@ -1163,7 +1163,7 @@ (* ;; "Returns the identifiers for commits in BRANCH1 but not in BUTNOTBRANCH2") - (GIT-COMMAND (CONCAT "git log --format=%"%%h%" %"" BRANCH1 "%" %"­" BUTNOTBRANCH2 "%"") + (GIT-COMMAND (CONCAT "git log --format=%"%%h%" %"" BRANCH1 "%" %"^" BUTNOTBRANCH2 "%"") NIL NIL PROJECT]) (GIT-BRANCH-RELATIONS @@ -1227,6 +1227,16 @@ then (CONS MAIN (DREMOVE MAIN (SORT DATUM))) else (SORT DATUM] (RETURN (LIST SUPERSETS EQUALS]) + +(GIT-MODIFIED + [LAMBDA (PROJECT) (* ; "Edited 25-Dec-2025 13:39 by rmk") + + (* ;; + "A list of files that have been modified M or introduced but not committed ??. see git help status") + + (for X POS in (GIT-COMMAND "git status --porcelain") + when (SETQ POS (OR (STRPOS " M " X NIL NIL NIL T) + (STRPOS "?? " X NIL NIL NIL T))) collect (SUBSTRING X POS]) ) @@ -1353,7 +1363,7 @@ (CL:WHEN (thereis B in BRANCHES suchthat (STRPOS "HEAD detached" B)) (PRINTOUT T "Execute %"git gc%" to eliminate a branch with a detached HEAD" T)) (CL:WHEN EXCLUDEMERGED - (SETQ BRANCHES (for B (MAINBRANCH _ (GIT-MAINBRANCH PROJECT 'LOCAL)) in BRANCHES + (SETQ BRANCHES (for B (MAINBRANCH ↠(GIT-MAINBRANCH PROJECT 'LOCAL)) in BRANCHES when (EQUAL (GIT-COMMAND (CONCAT "git merge-base %"" B "%" %"" MAINBRANCH "%"")) (GIT-COMMAND (CONCAT "git rev-parse %"" B "%""))) @@ -1392,11 +1402,11 @@ (CL:WHEN PIN? [SETQ BRANCHES (APPEND BRANCHES '((" Pin menu" 'PinMenu]) (create MENU - TITLE _ (OR TITLE (CONCAT (LENGTH BRANCHES) + TITLE ↠(OR TITLE (CONCAT (LENGTH BRANCHES) " branches")) - ITEMS _ BRANCHES - MENUFONT _ DEFAULTFONT - WHENSELECTEDFN _ (FUNCTION GIT-BRANCH-WHENSELECTEDFN)))]) + ITEMS ↠BRANCHES + MENUFONT ↠DEFAULTFONT + WHENSELECTEDFN ↠(FUNCTION GIT-BRANCH-WHENSELECTEDFN)))]) (GIT-BRANCH-WHENSELECTEDFN [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 2-Oct-2025 23:08 by rmk") @@ -1446,20 +1456,20 @@ eachtime [SETQ DRAFT (EQ 'true (JSON-GET JSOBJ 'isDraft] when (OR INCLUDEDRAFTS (NOT DRAFT)) collect [SETQ PR (create PULLREQUEST - PRNUMBER _ (JSON-GET JSOBJ 'number) - PRNAME _ (JSON-GET JSOBJ 'headRefName) - PRDESCRIPTION _ (JSON-GET JSOBJ 'title) - PRSTATUS _ (CL:IF DRAFT + PRNUMBER ↠(JSON-GET JSOBJ 'number) + PRNAME ↠(JSON-GET JSOBJ 'headRefName) + PRDESCRIPTION ↠(JSON-GET JSOBJ 'title) + PRSTATUS ↠(CL:IF DRAFT 'D (SELECTQ (MKATOM (JSON-GET JSOBJ 'reviewDecision)) - (CHANGES¬REQUESTED + (CHANGES_REQUESTED 'C) - (REVIEW¬REQUIRED + (REVIEW_REQUIRED " ") 'A)) - PRPROJECT _ PROJECT - PRURL _ (JSON-GET JSOBJ 'url) - PRLOGIN _ (JSON-GET JSOBJ '(headRepositoryOwner login] + PRPROJECT ↠PROJECT + PRURL ↠(JSON-GET JSOBJ 'url) + PRLOGIN ↠(JSON-GET JSOBJ '(headRepositoryOwner login] (CL:WHEN (STRPOS ":" (fetch (PULLREQUEST PRNAME) of PR)) (* ;; "From Nick: Git commands to bring install and deal with the remotes:") @@ -1510,8 +1520,8 @@ (LET ((RELATIONS (GIT-BRANCH-RELATIONS (for PR in PRS collect (GITORIGIN (fetch PRNAME of PR))) NIL T PROJECT))) - (SORT (for PR REL LABEL PRNAME STATUS (SUPERSETS _ (CAR RELATIONS)) - (EQUALS _ (CADR RELATIONS)) in PRS + (SORT (for PR REL LABEL PRNAME STATUS (SUPERSETS ↠(CAR RELATIONS)) + (EQUALS ↠(CADR RELATIONS)) in PRS eachtime (SETQ PRNAME (fetch PRNAME of PR)) (SETQ LABEL (CONCAT "#" (fetch (PULLREQUEST PRNUMBER) of PR) " " @@ -1558,15 +1568,33 @@ (GIT-BRANCH-NUM (OR BRANCH (GIT-WHICH-BRANCH PROJECT T]) (GIT-MY-NEXT-BRANCH - [LAMBDA (PROJECT) (* ; "Edited 19-May-2022 14:08 by rmk") + [LAMBDA (PROJECT) (* ; "Edited 2-Mar-2026 14:00 by rmk") + (* ; "Edited 19-May-2022 14:08 by rmk") (* ; "Edited 8-Jan-2022 09:43 by rmk") (* ;; "Figures out the number of my next incremental branch would be. ") (PACK* (GIT-INITIALS) - (ADD1 (OR (GIT-MY-BRANCHP (GIT-MY-CURRENT-BRANCH PROJECT) - PROJECT) - 0]) + (LET (PROJECTLIST PROJECTENTRY NEXTNUM) + (CL:WITH-OPEN-FILE (STRM "{LI}GIT-MY-CURRENT-BRANCH-NUMS;1" :DIRECTION :IO + :IF-DOES-NOT-EXIST :CREATE :IF-EXISTS :OVERWRITE) + (SETQ PROJECTLIST (CL:UNLESS (EQ 0 (GETEOFPTR STRM)) + (READ STRM))) + (SETQ PROJECTENTRY (ASSOC (GIT-GET-PROJECT PROJECT 'PROJECTNAME) + PROJECTLIST)) + (CL:UNLESS PROJECTENTRY + (SETQ PROJECTENTRY (LIST (GIT-GET-PROJECT PROJECT 'PROJECTNAME) + (OR (GIT-MY-BRANCHP (GIT-MY-CURRENT-BRANCH + PROJECT) + PROJECT) + 0))) + (push PROJECTLIST PROJECTENTRY)) + (SETQ NEXTNUM (ADD1 (CADR PROJECTENTRY))) + (RPLACA (CDR PROJECTENTRY) + NEXTNUM) + (SETFILEPTR STRM 0) + (PRINT PROJECTLIST STRM) + NEXTNUM]) (GIT-MY-BRANCHES [LAMBDA (PROJECT EXCLUDEMERGED INITS) (* ; "Edited 19-May-2022 19:10 by rmk") @@ -1647,14 +1675,14 @@ (CL:WHEN (STRPOS "fatal: " (CAR LINES) 1 NIL T) (ERROR "Could not remove worktree for " BRANCH)) - (* (DELFILE (CONCAT PATH "/.DS_Store")) + (* (DELFILE (CONCAT PATH "/.DSâ†Store"))  (GIT-COMMAND (CONCAT "rmdir " DIR) NIL  NIL PROJECT)) BRANCH]) (GIT-LIST-WORKTREES - [LAMBDA NIL (* ; "Edited 12-Dec-2021 12:13 by rmk") - (* ; "Edited 19-Nov-2021 18:53 by rmk:") + [LAMBDA NIL (* ; "Edited 12-Dec-2021 12:13 by rmk") + (* ; "Edited 19-Nov-2021 18:53 by rmk:") (* ;; "The git command tells us what the clone thinks about it, but then we look to see what is actually in our worktrees directory, to make sure that the subdirectory wasn't deleted in a wy that the clone didn't know about.") @@ -1880,14 +1908,14 @@ (replace (CDENTRY INFO2) of CDE with (create CDINFO - FULLNAME _ (CADR MAP) - DATE _ (CL:IF (EQ 'R (CADDR MAP)) + FULLNAME ↠(CADR MAP) + DATE ↠(CL:IF (EQ 'R (CADDR MAP)) " <-" " ==") - LENGTH _ "" - AUTHOR _ "" - TYPE _ "" - EOL _ "")) + LENGTH ↠"" + AUTHOR ↠"" + TYPE ↠"" + EOL ↠"")) (replace (CDENTRY DATEREL) of CDE with (CADDR MAP] (TERPRI T) @@ -1957,10 +1985,10 @@ then (SETQ SUBDIRS (ALLSUBDIRS PROJECT)) "ALL subdirectories" else SUBDIRS))) - (for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT) + (for SUBDIR TITLE CDVAL (WPROJ ↠(CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT) T))) - (NENTRIES _ 0) - (BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T)) + (NENTRIES ↠0) + (BRANCH2 ↠(GIT-WHICH-BRANCH PROJECT T)) first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T) (BKSYSBUF " ") inside SUBDIRS collect (TERPRI T) @@ -2132,12 +2160,12 @@ NIL] (CL:WHEN (OR COPYITEM COMPAREITEMS) (SELECTQ (MENU (CREATE MENU - TITLE _ (CONCAT (WINDOWPROP WINDOW 'SUBDIR) + TITLE ↠(CONCAT (WINDOWPROP WINDOW 'SUBDIR) "/" (FETCH MATCHNAME OF CDENTRY)) - ITEMS _ (APPEND COPYITEM COMPAREITEMS) - MENUFONT _ FONT - MENUTITLEFONT _ FONT)) + ITEMS ↠(APPEND COPYITEM COMPAREITEMS) + MENUFONT ↠FONT + MENUTITLEFONT ↠FONT)) (TOGIT (CL:WHEN (TOGIT (FETCH (CDINFO FULLNAME) OF INFO1) WINDOW) (IMAGEOBJPROP OBJ 'COPIED T) @@ -2162,18 +2190,18 @@ NIL)))]) (GIT-CD-LABELFN - [LAMBDA (FILE1 FILE2 USERDATA) (* ; "Edited 5-Jan-2022 15:10 by rmk") - (* ; "Edited 16-Dec-2021 12:25 by rmk") + [LAMBDA (FILE1 FILE2 USERDATA) (* ; "Edited 5-Jan-2022 15:10 by rmk") + (* ; "Edited 16-Dec-2021 12:25 by rmk") (* ; "Edited 13-Dec-2021 22:13 by rmk") (DECLARE (USEDFREE CDVALUE)) (LET (NC B LABEL1 LABEL2) (CL:WHEN (SETQ NC (FETCH NCDIR OF (FETCH CDMAXNC1 OF CDVALUE))) - (SETQ LABEL1 (SLASHIT (SUBSTRING FILE1 (ADD1 NC)) + (SETQ LABEL1 (SLASHIT (SUBSTRING FILE1 (ADD1 NC)) T)) (CL:WHEN (SETQ B (LISTGET USERDATA 'BRANCH1)) (SETQ LABEL1 (CONCAT B "/" LABEL1)))) (CL:WHEN (SETQ NC (FETCH NCDIR OF (FETCH CDMAXNC2 OF CDVALUE))) - (SETQ LABEL2 (SLASHIT (SUBSTRING FILE2 (ADD1 NC)) + (SETQ LABEL2 (SLASHIT (SUBSTRING FILE2 (ADD1 NC)) T)) (CL:WHEN (SETQ B (LISTGET USERDATA 'BRANCH2)) (SETQ LABEL2 (CONCAT B "/" LABEL2)))) @@ -2367,15 +2395,15 @@ NIL]) (GIT-RESULT-TO-LINES - [LAMBDA (FILE ALL) (* ; "Edited 31-Mar-2025 15:19 by rmk") + [LAMBDA (FILE ALL) (* ; "Edited 25-Feb-2026 23:24 by rmk") + (* ; "Edited 31-Mar-2025 15:19 by rmk") (* ; "Edited 16-Jul-2022 22:21 by rmk") (* ;; "Suppress .git lines unless ALL SYSTEM-EXTERNALFORMAT may make the wrong guess, but at least we ensure here that lines get broken.") (CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT (LIST (SYSTEM-EXTERNALFORMAT) 'ANY)) - (bind LINE until (EOFP STREAM) when [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P - NIL :EOF-VALUE NIL)) + (bind LINE until (EOFP STREAM) when [PROGN (SETQ LINE (CL:READ-LINE STREAM NIL)) (OR ALL (NOT (STRPOS ".git" LINE 1] collect LINE]) @@ -2394,32 +2422,33 @@ (PUTPROPS GITFNS FILETYPE :TCOMPL) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4196 21002 (GIT-CLONEP 4206 . 5637) (GIT-INIT 5639 . 6269) (GIT-MAKE-PROJECT 6271 . -14060) (GIT-GET-PROJECT 14062 . 15987) (GIT-PUT-PROJECT-FIELD 15989 . 17630) (GIT-PROJECT-PATH 17632 - . 18676) (FIND-ANCESTOR-DIRECTORY 18678 . 19027) (GIT-FIND-CLONE 19029 . 20110) (GIT-MAINBRANCH 20112 - . 20507) (GIT-MAINBRANCH? 20509 . 21000)) (26465 31394 (PRC-COMMAND 26475 . 31392)) (31450 34238 ( -ALLSUBDIRS 31460 . 32746) (MEDLEYSUBDIRS 32748 . 33441) (GITSUBDIRS 33443 . 34236)) (34239 36640 ( -TOGIT 34249 . 35655) (FROMGIT 35657 . 36638)) (36641 39644 (MYMEDLEYSUBDIR 36651 . 37107) (GITSUBDIR -37109 . 37552) (STRIPDIR 37554 . 37925) (STRIPHOST 37927 . 38167) (STRIPNAME 38169 . 38922) ( -STRIPWHERE 38924 . 39642)) (39645 41880 (GFILE4MFILE 39655 . 40351) (MFILE4GFILE 40353 . 40922) ( -GIT-REPO-FILENAME 40924 . 41878)) (41929 52184 (GIT-COMMIT 41939 . 42765) (GIT-PUSH 42767 . 43527) ( -GIT-PULL 43529 . 44281) (GIT-APPROVAL 44283 . 44632) (GIT-GET-FILE 44634 . 46549) (GIT-FILE-EXISTS? -46551 . 46825) (GIT-REMOTE-UPDATE 46827 . 47662) (GIT-REMOTE-ADD 47664 . 47971) (GIT-FILE-DATE 47973 - . 49020) (GIT-FILE-HISTORY 49022 . 50956) (GIT-PRINT-FILE-HISTORY 50958 . 52008) (GIT-FETCH 52010 . -52182)) (52214 63694 (GIT-BRANCH-DIFF 52224 . 59113) (GIT-COMMIT-DIFFS 59115 . 60006) ( -GIT-BRANCH-RELATIONS 60008 . 63692)) (63739 82478 (GIT-BRANCH-NUM 63749 . 64322) (GIT-CHECKOUT 64324 - . 65610) (GIT-WHICH-BRANCH 65612 . 66019) (GIT-MAKE-BRANCH 66021 . 68600) (GIT-BRANCHES 68602 . 71197 -) (GIT-BRANCH-EXISTS? 71199 . 72070) (GIT-PICK-BRANCH 72072 . 72562) (GIT-BRANCH-MENU 72564 . 73445) ( -GIT-BRANCH-WHENSELECTEDFN 73447 . 74986) (GIT-PULL-REQUESTS 74988 . 78859) (GIT-SHORT-BRANCH-NAME -78861 . 79152) (GIT-LONG-NAME 79154 . 79471) (GIT-PRC-BRANCHES 79473 . 82476)) (82508 85956 ( -GIT-MY-CURRENT-BRANCH 82518 . 82888) (GIT-MY-BRANCHP 82890 . 83508) (GIT-MY-NEXT-BRANCH 83510 . 84004) - (GIT-MY-BRANCHES 84006 . 85954)) (86002 90077 (GIT-ADD-WORKTREE 86012 . 87619) (GIT-REMOVE-WORKTREE -87621 . 88551) (GIT-LIST-WORKTREES 88553 . 89357) (WORKTREEDIR 89359 . 90075)) (90125 123133 ( -GIT-GET-DIFFERENT-FILES 90135 . 97043) (GIT-BRANCHES-COMPARE-DIRECTORIES 97045 . 104672) ( -GIT-WORKING-COMPARE-DIRECTORIES 104674 . 110470) (GIT-COMPARE-WORKTREE 110472 . 114450) ( -GITCDOBJBUTTONFN 114452 . 118942) (GIT-CD-LABELFN 118944 . 120026) (GIT-CD-MENUFN 120028 . 121114) ( -GIT-WORKING-COMPARE-FILES 121116 . 121736) (GIT-BRANCHES-COMPARE-FILES 121738 . 122902) ( -GIT-PR-COMPARE 122904 . 123131)) (123203 131526 (CDGITDIR 123213 . 123900) (GIT-COMMAND 123902 . -125460) (GITORIGIN 125462 . 126159) (GIT-INITIALS 126161 . 126465) (GIT-COMMAND-TO-FILE 126467 . -129952) (GIT-RESULT-TO-LINES 129954 . 130859) (STRIPLOCAL 130861 . 131524))))) + (FILEMAP (NIL (4178 21056 (GIT-CLONEP 4188 . 5619) (GIT-INIT 5621 . 6251) (GIT-MAKE-PROJECT 6253 . +14110) (GIT-GET-PROJECT 14112 . 16037) (GIT-PUT-PROJECT-FIELD 16039 . 17680) (GIT-PROJECT-PATH 17682 + . 18726) (FIND-ANCESTOR-DIRECTORY 18728 . 19079) (GIT-FIND-CLONE 19081 . 20164) (GIT-MAINBRANCH 20166 + . 20561) (GIT-MAINBRANCH? 20563 . 21054)) (26519 31448 (PRC-COMMAND 26529 . 31446)) (31504 34292 ( +ALLSUBDIRS 31514 . 32800) (MEDLEYSUBDIRS 32802 . 33495) (GITSUBDIRS 33497 . 34290)) (34293 36698 ( +TOGIT 34303 . 35711) (FROMGIT 35713 . 36696)) (36699 39709 (MYMEDLEYSUBDIR 36709 . 37165) (GITSUBDIR +37167 . 37610) (STRIPDIR 37612 . 37990) (STRIPHOST 37992 . 38232) (STRIPNAME 38234 . 38987) ( +STRIPWHERE 38989 . 39707)) (39710 41945 (GFILE4MFILE 39720 . 40416) (MFILE4GFILE 40418 . 40987) ( +GIT-REPO-FILENAME 40989 . 41943)) (41994 52251 (GIT-COMMIT 42004 . 42830) (GIT-PUSH 42832 . 43592) ( +GIT-PULL 43594 . 44346) (GIT-APPROVAL 44348 . 44697) (GIT-GET-FILE 44699 . 46614) (GIT-FILE-EXISTS? +46616 . 46890) (GIT-REMOTE-UPDATE 46892 . 47727) (GIT-REMOTE-ADD 47729 . 48036) (GIT-FILE-DATE 48038 + . 49085) (GIT-FILE-HISTORY 49087 . 51021) (GIT-PRINT-FILE-HISTORY 51023 . 52075) (GIT-FETCH 52077 . +52249)) (52281 64233 (GIT-BRANCH-DIFF 52291 . 59180) (GIT-COMMIT-DIFFS 59182 . 60073) ( +GIT-BRANCH-RELATIONS 60075 . 63759) (GIT-MODIFIED 63761 . 64231)) (64278 83045 (GIT-BRANCH-NUM 64288 + . 64861) (GIT-CHECKOUT 64863 . 66149) (GIT-WHICH-BRANCH 66151 . 66558) (GIT-MAKE-BRANCH 66560 . 69139 +) (GIT-BRANCHES 69141 . 71738) (GIT-BRANCH-EXISTS? 71740 . 72611) (GIT-PICK-BRANCH 72613 . 73103) ( +GIT-BRANCH-MENU 73105 . 73994) (GIT-BRANCH-WHENSELECTEDFN 73996 . 75535) (GIT-PULL-REQUESTS 75537 . +79422) (GIT-SHORT-BRANCH-NAME 79424 . 79715) (GIT-LONG-NAME 79717 . 80034) (GIT-PRC-BRANCHES 80036 . +83043)) (83075 87829 (GIT-MY-CURRENT-BRANCH 83085 . 83455) (GIT-MY-BRANCHP 83457 . 84075) ( +GIT-MY-NEXT-BRANCH 84077 . 85877) (GIT-MY-BRANCHES 85879 . 87827)) (87875 91959 (GIT-ADD-WORKTREE +87885 . 89492) (GIT-REMOVE-WORKTREE 89494 . 90426) (GIT-LIST-WORKTREES 90428 . 91239) (WORKTREEDIR +91241 . 91957)) (92007 125045 (GIT-GET-DIFFERENT-FILES 92017 . 98925) ( +GIT-BRANCHES-COMPARE-DIRECTORIES 98927 . 106566) (GIT-WORKING-COMPARE-DIRECTORIES 106568 . 112370) ( +GIT-COMPARE-WORKTREE 112372 . 116350) (GITCDOBJBUTTONFN 116352 . 120850) (GIT-CD-LABELFN 120852 . +121938) (GIT-CD-MENUFN 121940 . 123026) (GIT-WORKING-COMPARE-FILES 123028 . 123648) ( +GIT-BRANCHES-COMPARE-FILES 123650 . 124814) (GIT-PR-COMPARE 124816 . 125043)) (125115 133446 (CDGITDIR + 125125 . 125812) (GIT-COMMAND 125814 . 127372) (GITORIGIN 127374 . 128071) (GIT-INITIALS 128073 . +128377) (GIT-COMMAND-TO-FILE 128379 . 131864) (GIT-RESULT-TO-LINES 131866 . 132779) (STRIPLOCAL 132781 + . 133444))))) STOP diff --git a/lispusers/GITFNS.LCOM b/lispusers/GITFNS.LCOM index da2bc98b..edc706ad 100644 Binary files a/lispusers/GITFNS.LCOM and b/lispusers/GITFNS.LCOM differ diff --git a/lispusers/HELPSYS b/lispusers/HELPSYS index 4ff064d9..748a9348 100644 --- a/lispusers/HELPSYS +++ b/lispusers/HELPSYS @@ -1,12 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-May-2025 22:04:32" {WMEDLEY}HELPSYS.;15 87966 +(FILECREATED "27-Jan-2026 13:21:10" {WMEDLEY}HELPSYS.;21 88654 :EDIT-BY rmk - :CHANGES-TO (FNS CLHS.INDEX) + :CHANGES-TO (FNS DOCS.LOOKUP GENERIC.MAN.LOOKUP) + (VARS HELPSYSCOMS) - :PREVIOUS-DATE " 4-May-2025 13:30:47" {WMEDLEY}HELPSYS.;12) + :PREVIOUS-DATE " 5-May-2025 22:04:32" {WMEDLEY}HELPSYS.;15) (PRETTYCOMPRINT HELPSYSCOMS) @@ -17,7 +18,7 @@ (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) DINFO HASH)) [COMS (COMMANDS "man") - (FNS HELPSYS IRM.LOOKUP GENERIC.MAN.LOOKUP IRM.SMART.LOOKUP IRM.RESET) + (FNS HELPSYS IRM.LOOKUP GENERIC.MAN.LOOKUP IRM.SMART.LOOKUP IRM.RESET DOCS.LOOKUP) (INITVARS (IRM.HOST&DIR) (IRM.HASHFILE.NAME)) (GLOBALVARS IRM.HOST&DIR IRM.HASHFILE.NAME) @@ -161,7 +162,8 @@ NIL]) (GENERIC.MAN.LOOKUP - [LAMBDA (KEYWORD GRAPH TYPE) (* ; "Edited 27-Aug-2022 12:15 by larry") + [LAMBDA (KEYWORD GRAPH TYPE) (* ; "Edited 27-Jan-2026 11:42 by rmk") + (* ; "Edited 27-Aug-2022 12:15 by larry") (* ; "Edited 24-Aug-2022 22:35 by larry") (* ; "Edited 19-Aug-2022 19:35 by lmm") (* drc%: " 6-Jan-86 14:50") @@ -171,7 +173,8 @@ (APPEND (IRM.LOOKUP KEYWORD NIL GRAPH T) (CLHS.LOOKUP KEYWORD) - (REPO.LOOKUP KEYWORD)) + (REPO.LOOKUP KEYWORD) + (DOCS.LOOKUP KEYWORD)) elseif (NOT (LITATOM KEYWORD)) then (* ;; " not a string -- list or number. turn it into a string, removing parens") @@ -192,7 +195,8 @@ (AND (CL:FIND-SYMBOL KEYWORD "IL") (IRM.LOOKUP KEYWORD TYPE GRAPH T))) else (APPEND (IRM.LOOKUP KEYWORD TYPE GRAPH T) - (REPO.LOOKUP KEYWORD]) + (REPO.LOOKUP KEYWORD) + (DOCS.LOOKUP KEYWORD]) (IRM.SMART.LOOKUP [LAMBDA (KEYWORD GRAPH) (* drc%: " 6-Jan-86 14:50") @@ -208,6 +212,15 @@ (CLOSEHASHFILE \IRM.HASHFILE) (SETQ \IRM.HASHFILE) (SETQ \IRM.KEYWORDS]) + +(DOCS.LOOKUP + [LAMBDA (KEYWORD) (* ; "Edited 27-Jan-2026 13:20 by rmk") + (LET ((DIR (MEDLEYDIR (CONCAT "library/" (L-CASE KEYWORD) + "/docs/") + NIL NIL T))) + (CL:WHEN DIR + (ShellOpen (CONCAT "file://" (SLASHIT (TRUEFILENAME DIR) + NIL T))))]) ) (RPAQ? IRM.HOST&DIR ) @@ -1703,14 +1716,14 @@ (PUTPROPS HELPSYS FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4571 10304 (HELPSYS 4581 . 6422) (IRM.LOOKUP 6424 . 8062) (GENERIC.MAN.LOOKUP 8064 . -9733) (IRM.SMART.LOOKUP 9735 . 9891) (IRM.RESET 9893 . 10302)) (10561 17880 (CLHS.INDEX 10571 . 13535) - (CLHS.LOOKUP 13537 . 15543) (CLHS.OPENER 15545 . 16868) (REPO.LOOKUP 16870 . 17878)) (70975 72493 ( -IRM.GET.DINFOGRAPH 70985 . 71860) (IRM.DISPLAY.REF 71862 . 72491)) (72495 72857 (IRM.LOAD-GRAPH 72495 - . 72857)) (73182 78686 (IRM.DISPLAY.CREF 73192 . 74906) (IRM.CREF.BOX 74908 . 75735) (IRM.PUT.CREF -75737 . 75962) (IRM.GET.CREF 75964 . 76335) (IRM.CREF.BUTTONEVENTFN 76337 . 78684)) (79241 87547 ( -\IRM.GET.REF 79251 . 80582) (\IRM.SMART.REF 80584 . 82511) (\IRM.CHOOSE.REF 82513 . 83764) ( -\IRM.WILD.REF 83766 . 85021) (\IRM.WILDCARD 85023 . 85389) (\IRM.WILD.MATCH 85391 . 86621) ( -\IRM.GET.HASHFILE 86623 . 87086) (\IRM.GET.KEYWORDS 87088 . 87545)) (87684 87840 (\IRM.AROUND-EXIT -87684 . 87840))))) + (FILEMAP (NIL (4640 10992 (HELPSYS 4650 . 6491) (IRM.LOOKUP 6493 . 8131) (GENERIC.MAN.LOOKUP 8133 . +10001) (IRM.SMART.LOOKUP 10003 . 10159) (IRM.RESET 10161 . 10570) (DOCS.LOOKUP 10572 . 10990)) (11249 +18568 (CLHS.INDEX 11259 . 14223) (CLHS.LOOKUP 14225 . 16231) (CLHS.OPENER 16233 . 17556) (REPO.LOOKUP +17558 . 18566)) (71663 73181 (IRM.GET.DINFOGRAPH 71673 . 72548) (IRM.DISPLAY.REF 72550 . 73179)) ( +73183 73545 (IRM.LOAD-GRAPH 73183 . 73545)) (73870 79374 (IRM.DISPLAY.CREF 73880 . 75594) ( +IRM.CREF.BOX 75596 . 76423) (IRM.PUT.CREF 76425 . 76650) (IRM.GET.CREF 76652 . 77023) ( +IRM.CREF.BUTTONEVENTFN 77025 . 79372)) (79929 88235 (\IRM.GET.REF 79939 . 81270) (\IRM.SMART.REF 81272 + . 83199) (\IRM.CHOOSE.REF 83201 . 84452) (\IRM.WILD.REF 84454 . 85709) (\IRM.WILDCARD 85711 . 86077) +(\IRM.WILD.MATCH 86079 . 87309) (\IRM.GET.HASHFILE 87311 . 87774) (\IRM.GET.KEYWORDS 87776 . 88233)) ( +88372 88528 (\IRM.AROUND-EXIT 88372 . 88528))))) STOP diff --git a/lispusers/HELPSYS.LCOM b/lispusers/HELPSYS.LCOM index d7b729ab..8307d3e2 100644 Binary files a/lispusers/HELPSYS.LCOM and b/lispusers/HELPSYS.LCOM differ diff --git a/lispusers/ISO8859IO b/lispusers/ISO8859IO index 0c0204ef..da16ac65 100644 --- a/lispusers/ISO8859IO +++ b/lispusers/ISO8859IO @@ -1,45 +1,44 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT XCCS) -(FILECREATED " 8-Aug-2021 13:22:31"  -{DSK}kaplan>Local>medley3.5>git-medley>lispusers>ISO8859IO.;18 22218 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS \8859OUTCHARFN \IBMOUTCHARFN \MACOUTCHARFN) +(FILECREATED "22-Feb-2026 12:22:12" {WMEDLEY}ISO8859IO.;22 21861 - previous date%: " 6-Aug-2021 16:12:42" -{DSK}kaplan>Local>medley3.5>git-medley>lispusers>ISO8859IO.;17) + :EDIT-BY rmk + :CHANGES-TO (FNS ISO1TOMSTRING MTOISO1STRING) + (VARS ISO8859IOCOMS) + + :PREVIOUS-DATE " 2-Feb-2026 23:20:20" {WMEDLEY}ISO8859IO.;20) -(* ; " -Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation. -") (PRETTYCOMPRINT ISO8859IOCOMS) (RPAQQ ISO8859IOCOMS ( - (* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding.") + (* ;; "This package defines EXTERNALFORMATS for files that are encoded in ISIO8859/1, the standard IBM extended ascii, or the legacy MAC encoding.") - (COMS (* ; "ISO8859/1") - (FNS \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN) - (GLOBALVARS *XEROXTOISO8859MAP* *ISO8859TOXEROXMAP*) - (FNS MAKEISOFORMAT) - (P (MAKEISOFORMAT))) - (COMS (* ; "IBM-PC Extended Ascii") + [COMS (* ; "ISO8859/1") + (FNS ISO1TOMCODE MTOISO1CODE \CREATE.ISO1.FORMAT) + (FNS ISO1TOMSTRING MTOISO1STRING) + (VARS ISO1TOMCCS) + (GLOBALVARS ISO1TOMCCS) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.ISO1.FORMAT] + (COMS (* ; "IBM-PC Extended Ascii") (FNS \IBMOUTCHARFN \IBMINCCODEFN \IBMPEEKCCODEFN) (GLOBALVARS *XEROXTOIBMMAP* *IBMTOXEROXMAP*) (FNS MAKEIBMFORMAT) (P (MAKEIBMFORMAT))) - (COMS (* ; "Macintosh") + (COMS (* ; "Macintosh") (FNS \MACOUTCHARFN \MACINCCODEFN \MACPEEKCCODEFN) (GLOBALVARS *XEROXTOMACMAP* *MACTOXEROXMAP*) (FNS MAKEMACFORMAT) (P (MAKEMACFORMAT))) - (COMS (* ; "Independent of char encoding") + (COMS (* ; "Independent of char encoding") (FNS \COMMONBACKCCODEFN \MAKERECODEMAP \RECODECCODE)))) (* ;; -"This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding." +"This package defines EXTERNALFORMATS for files that are encoded in ISIO8859/1, the standard IBM extended ascii, or the legacy MAC encoding." ) @@ -49,146 +48,150 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation. (DEFINEQ -(\8859OUTCHARFN - [LAMBDA (STREAM CHARCODE) - (DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 8-Aug-2021 13:21 by rmk:") - (* ; "Edited 7-Dec-95 14:34 by ") - (* ; "Edited 7-Dec-95 14:32 by ") +(ISO1TOMCODE + [LAMBDA (ICODE) (* ; "Edited 5-Feb-2026 12:09 by rmk") + (* ; "Edited 2-Feb-2026 23:14 by rmk") + (* ; "Edited 7-Sep-2025 22:39 by rmk") + (* ; "Edited 3-Sep-2025 10:21 by rmk") + (* ; "Edited 7-Aug-2025 09:37 by rmk") - (* ;; "Converts CHARCODE from internal encoding to ISO8859 before printing.") + (* ;; "ISO codes are 8bit, MCODES maybe not. Caller shouldn't pass a fat code.") - (* ;; "Unconverted codes are left unchanged (no error).") + (OR [CAR (find PAIR in ISO1TOMCCS suchthat (EQ ICODE (CADR PAIR] + ICODE]) - (* ;; "If any remaining codes are out of charset 0, the streams external format will be used. ") +(MTOISO1CODE + [LAMBDA (MCODE) (* ; "Edited 5-Feb-2026 12:26 by rmk") + (* ; "Edited 2-Feb-2026 22:58 by rmk") + (OR (CADR (ASSOC MCODE ISO1TOMCCS)) + MCODE]) - (IF (EQ CHARCODE (CHARCODE EOL)) - THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) - (\BOUTEOL STREAM) - ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM) - (IPLUS16 1 DATUM)) - (\BOUT STREAM (IF (IGREATERP CHARCODE 127) - THEN - - (* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with Xerox on first 128") - - (\RECODECCODE CHARCODE *XEROXTOISO8859MAP*) - ELSE CHARCODE]) - -(\8859INCCODEFN - [LAMBDA (STRM COUNTP) (* ; "Edited 6-Aug-2021 16:10 by rmk:") - (* ; "Edited 7-Dec-95 15:24 by ") - (* ; "Edited 7-Dec-95 15:19 by ") - (DECLARE (USEDFREE *BYTECOUNTER*)) - (CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1)) - (\RECODECCODE (\BIN STRM) - *ISO8859TOXEROXMAP*]) - -(\8859PEEKCCODEFN - [LAMBDA (STRM NOERROR) (* ; "Edited 5-May-2021 17:44 by rmk:") - (* ; "Edited 3-Jan-96 14:21 by ") - (* ; "Edited 7-Dec-95 15:51 by ") - (* ; "Edited 7-Dec-95 15:19 by ") - (\RECODECCODE (\PEEKCCODE STRM NOERROR) - *ISO8859TOXEROXMAP*]) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS *XEROXTOISO8859MAP* *ISO8859TOXEROXMAP*) +(\CREATE.ISO1.FORMAT + [LAMBDA NIL (* ; "Edited 5-Feb-2026 10:42 by rmk") + (* ; "Edited 2-Feb-2026 23:37 by rmk") + (* ; "Edited 1-Feb-2026 11:18 by rmk") + (* ; "Edited 5-Aug-2021 22:15 by rmk:") + (* ; "Edited 9-Mar-99 17:19 by rmk:") + (* ; "Edited 7-Dec-95 16:24 by ") + (* ; "Edited 7-Dec-95 16:20 by ") + (MAKE-EXTERNALFORMAT :ISO8859/1 [FUNCTION (LAMBDA (STREAM COUNTP) + (ISO1TOMCODE (\THROUGHIN STREAM COUNTP] + [FUNCTION (LAMBDA (STREAM NOERRORFLG) + (ISO1TOMCODE (\PEEKBIN STREAM NOERRORFLG] + (FUNCTION \THROUGHBACKCCODE) + (FUNCTION NILL) + (FUNCTION NILL) + NIL NIL (FUNCTION MTOISO1STRING) + NIL + (FUNCTION NILL) + (FUNCTION ISO1TOMSTRING]) ) (DEFINEQ -(MAKEISOFORMAT - [LAMBDA NIL (* ; "Edited 5-Aug-2021 22:15 by rmk:") - (* ; "Edited 9-Mar-99 17:19 by rmk:") - (* ; "Edited 7-Dec-95 16:24 by ") - (* ; "Edited 7-Dec-95 16:20 by ") - (LET [(XEROXTOISO '((61217 160) - (61291 166) - (8994 168) - (211 169) - (227 170) - (61290 172) - (61219 173) - (210 174) - (9086 175) - (8999 180) - (203 184) - (209 185) - (235 186) - (61729 192) - (61730 193) - (61731 194) - (61732 195) - (61735 196) - (61736 197) - (225 198) - (61741 199) - (61744 200) - (61745 201) - (61746 202) - (61749 203) - (61758 204) - (61759 205) - (61760 206) - (61764 207) - (226 208) - (61772 209) - (61775 210) - (61776 211) - (61777 212) - (61778 213) - (61780 214) - (180 215) - (233 216) - (61791 217) - (61792 218) - (61793 219) - (61797 220) - (61803 221) - (236 222) - (251 223) - (61857 224) - (61858 225) - (61859 226) - (61860 227) - (61863 228) - (61864 229) - (241 230) - (61869 231) - (61872 232) - (61873 233) - (61874 234) - (61877 235) - (61886 236) - (61887 237) - (61888 238) - (61892 239) - (243 240) - (61900 241) - (61903 242) - (61904 243) - (61905 244) - (61906 245) - (61908 246) - (184 247) - (249 248) - (61919 249) - (61920 250) - (61921 251) - (61925 252) - (61931 253) - (252 254) - (61933 255) - (61805 376] - (SETQ *XEROXTOISO8859MAP* (\MAKERECODEMAP XEROXTOISO)) - (SETQ *ISO8859TOXEROXMAP* (\MAKERECODEMAP XEROXTOISO T))) - (MAKE-EXTERNALFORMAT :ISO8859/1 (FUNCTION \8859INCCODEFN) - (FUNCTION \8859PEEKCCODEFN) - (FUNCTION \COMMONBACKCCODEFN) - (FUNCTION \8859OUTCHARFN]) +(ISO1TOMSTRING + [LAMBDA (ISTRING DESTRUCTIVE) (* ; "Edited 22-Feb-2026 12:21 by rmk") + (* ; "Edited 5-Feb-2026 11:01 by rmk") + (* ; "Edited 2-Feb-2026 23:46 by rmk") + (* ; "Edited 2-Sep-2025 12:14 by rmk") + (* ; "Edited 29-Apr-2025 13:08 by rmk") + + (* ;; "Converts ISO8859/1 codes to MCCS codes in MSTRING.") + + (for I ICODE (MSTRING _ (CL:IF DESTRUCTIVE + ISTRING + (CONCAT ISTRING))) from 1 while (SETQ ICODE (NTHCHARCODE ISTRING I)) + do (RPLCHARCODE MSTRING I (ISO1TOMCODE ICODE)) finally (RETURN MSTRING]) + +(MTOISO1STRING + [LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 22-Feb-2026 12:22 by rmk") + (* ; "Edited 2-Feb-2026 23:47 by rmk") + (* ; "Edited 2-Sep-2025 12:22 by rmk") + (* ; "Edited 29-Apr-2025 13:08 by rmk") + + (* ;; "Converts MCCS to ISO8859/1 codes in MSTRING.") + + (for I MCODE (ISTRING _ (CL:IF DESTRUCTIVE + MSTRING + (CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I)) + do (RPLCHARCODE ISTRING I (MTOISO1CODE MCODE)) finally (RETURN ISTRING]) ) -(MAKEISOFORMAT) +(RPAQQ ISO1TOMCCS + ((94 8593) + (95 8592) + (169 8216) + (170 8220) + (172 95) + (173 94) + (174 8594) + (175 8595) + (180 215) + (184 247) + (185 8217) + (186 8221) + (193 768) + (194 769) + (195 770) + (196 771) + (197 772) + (198 774) + (199 775) + (200 776) + (202 778) + (203 807) + (204 818) + (205 779) + (206 808) + (207 780) + (208 8213) + (209 185) + (210 174) + (211 169) + (212 8482) + (213 9834) + (220 8539) + (221 8540) + (222 8541) + (223 8542) + (224 8486) + (225 198) + (226 208) + (227 170) + (228 294) + (229 567) + (230 306) + (231 319) + (232 321) + (233 216) + (234 338) + (235 186) + (236 222) + (237 358) + (238 330) + (239 329) + (240 312) + (241 230) + (242 273) + (243 240) + (244 295) + (245 305) + (246 307) + (247 320) + (248 322) + (249 248) + (250 339) + (251 223) + (252 254) + (253 359) + (254 331))) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS ISO1TOMCCS) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\CREATE.ISO1.FORMAT) +) @@ -515,26 +518,28 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation. T)]) (\MAKERECODEMAP - [LAMBDA (CODEMAP INVERTED) (* ; "Edited 9-Mar-99 17:23 by rmk:") + [LAMBDA (CODEMAP INVERTED) (* ; "Edited 1-Feb-2026 13:03 by rmk") + (* ; "Edited 9-Mar-99 17:23 by rmk:") - (* ;; "Produces a map array for use by \RECODECCODE. The map array is a 256-array of either NIL or 256-arrays, so that space isn't allocated for widely separated codes.") + (* ;; "Produces a map array for use by \RECODECCODE. The map array is a 256-array of either NIL or 256-arrays, so that space isn't allocated for widely separated codes.") (DECLARE (USEDFREE FASTRECODEMAPCACHE)) (CL:WHEN INVERTED [SETQ CODEMAP (FOR C IN CODEMAP COLLECT (LIST (CADR C) - (CAR C]) - (FOR M (MAPARRAY _ (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) - CSMAP IN CODEMAP UNLESS (EQ (CAR M) - (CADR M)) - DO (CL:UNLESS (SETQ CSMAP (CL:SVREF MAPARRAY (LRSH (CAR M) - 8))) - (SETQ CSMAP (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) - (CL:SETF (CL:SVREF MAPARRAY (LRSH (CAR M) - 8)) - CSMAP)) - (CL:SETF (CL:SVREF CSMAP (LOGAND (CAR M) - 255)) - (CADR M)) FINALLY (RETURN MAPARRAY]) + (CAR C]) + (FOR M LEFT RIGHT (MAPARRAY ¬ (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) + CSMAP IN CODEMAP eachtime (SETQ LEFT (CAR M)) + (SETQ RIGHT (CADR M)) + (CL:UNLESS (CHARCODEP LEFT) + (SETQ LEFT (CHARCODE.DECODE LEFT))) + (CL:UNLESS (CHARCODEP RIGHT) + (SETQ RIGHT (CHARCODE.DECODE RIGHT))) + UNLESS (EQ LEFT RIGHT) DO (CL:UNLESS (SETQ CSMAP (CL:SVREF MAPARRAY (LRSH LEFT 8))) + (SETQ CSMAP (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT NIL)) + (CL:SETF (CL:SVREF MAPARRAY (LRSH LEFT 8)) + CSMAP)) + (CL:SETF (CL:SVREF CSMAP (LOGAND LEFT 255)) + RIGHT) FINALLY (RETURN MAPARRAY]) (\RECODECCODE [LAMBDA (CODE MAPARRAY) (* ; "Edited 9-Mar-99 17:28 by rmk:") @@ -546,12 +551,11 @@ Copyright (c) 1995-1997, 1999, 2021 by Xerox Corporation. (OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255))) CODE]) ) -(PUTPROPS ISO8859IO COPYRIGHT ("Xerox Corporation" 1995 1996 1997 1999 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1909 4233 (\8859OUTCHARFN 1919 . 3222) (\8859INCCODEFN 3224 . 3710) (\8859PEEKCCODEFN -3712 . 4231)) (4325 7866 (MAKEISOFORMAT 4335 . 7864)) (7926 9844 (\IBMOUTCHARFN 7936 . 8739) ( -\IBMINCCODEFN 8741 . 9222) (\IBMPEEKCCODEFN 9224 . 9842)) (9928 13459 (MAKEIBMFORMAT 9938 . 13457)) ( -13507 15354 (\MACOUTCHARFN 13517 . 14574) (\MACINCCODEFN 14576 . 14940) (\MACPEEKCCODEFN 14942 . 15352 -)) (15438 19991 (MAKEMACFORMAT 15448 . 19989)) (20058 22117 (\COMMONBACKCCODEFN 20068 . 20438) ( -\MAKERECODEMAP 20440 . 21670) (\RECODECCODE 21672 . 22115))))) + (FILEMAP (NIL (1834 4154 (ISO1TOMCODE 1844 . 2593) (MTOISO1CODE 2595 . 2885) (\CREATE.ISO1.FORMAT 2887 + . 4152)) (4155 5904 (ISO1TOMSTRING 4165 . 5090) (MTOISO1STRING 5092 . 5902)) (7310 9228 ( +\IBMOUTCHARFN 7320 . 8123) (\IBMINCCODEFN 8125 . 8606) (\IBMPEEKCCODEFN 8608 . 9226)) (9312 12843 ( +MAKEIBMFORMAT 9322 . 12841)) (12891 14738 (\MACOUTCHARFN 12901 . 13958) (\MACINCCODEFN 13960 . 14324) +(\MACPEEKCCODEFN 14326 . 14736)) (14822 19375 (MAKEMACFORMAT 14832 . 19373)) (19442 21838 ( +\COMMONBACKCCODEFN 19452 . 19822) (\MAKERECODEMAP 19824 . 21391) (\RECODECCODE 21393 . 21836))))) STOP diff --git a/lispusers/ISO8859IO.LCOM b/lispusers/ISO8859IO.LCOM index ac6c89f1..7db674a3 100644 Binary files a/lispusers/ISO8859IO.LCOM and b/lispusers/ISO8859IO.LCOM differ diff --git a/lispusers/LAMBDATRAN b/lispusers/LAMBDATRAN index 69e9672e..98ce0d57 100644 --- a/lispusers/LAMBDATRAN +++ b/lispusers/LAMBDATRAN @@ -1,41 +1,38 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED "19-Feb-87 10:40:43" {QV}PARSER>NEXT>LAMBDATRAN.;2 9556 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS) +(FILECREATED "18-Feb-2026 16:30:17" {WMEDLEY}LAMBDATRAN.;2 9157 - previous date%: "19-Feb-87 09:56:18" {QV}PARSER>NEXT>LAMBDATRAN.;1) + :EDIT-BY rmk + :PREVIOUS-DATE "19-Feb-87 10:40:43" {WMEDLEY}LAMBDATRAN.;1) -(* " -Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT LAMBDATRANCOMS) -(RPAQQ LAMBDATRANCOMS [(* Translation machinery for new LAMBDA words) - (LOCALVARS . T) - [DECLARE%: FIRST (P (VIRGINFN 'ARGLIST T) - (MOVD? 'ARGLIST 'OLDARGLIST) - (VIRGINFN 'NARGS T) - (MOVD? 'NARGS 'OLDNARGS) - (VIRGINFN 'ARGTYPE T) - (MOVD? 'ARGTYPE 'OLDARGTYPE) - (MOVD? 'NILL 'LTDWIMUSERFN] - (FNS ARGLIST ARGTYPE FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS) - (ADDVARS (DWIMUSERFORMS (LTDWIMUSERFN))) - (PROP VARTYPE LAMBDATRANFNS) - (ALISTS (LAMBDATRANFNS)) - (PROP MACRO LTSTKNAME) - (P (PUTHASH 'LTSTKNAME '(NIL) MSTEMPLATES)) - (P (RELINK 'WORLD)) - (DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T)) - (GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS BOUNDPDUMMY - )) - (DECLARE%: DONTCOPY (RECORDS LAMBDAWORD)) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - (ADDVARS (NLAMA) - (NLAML LTSTKNAME) - (LAMA]) +(RPAQQ LAMBDATRANCOMS + [(* Translation machinery for new LAMBDA words) + (LOCALVARS . T) + [DECLARE%: FIRST (P (VIRGINFN 'ARGLIST T) + (MOVD? 'ARGLIST 'OLDARGLIST) + (VIRGINFN 'NARGS T) + (MOVD? 'NARGS 'OLDNARGS) + (VIRGINFN 'ARGTYPE T) + (MOVD? 'ARGTYPE 'OLDARGTYPE) + (MOVD? 'NILL 'LTDWIMUSERFN] + (FNS ARGLIST ARGTYPE FNTYP1 LTDWIMUSERFN LTSTKNAME NARGS) + (ADDVARS (DWIMUSERFORMS (LTDWIMUSERFN))) + (PROP VARTYPE LAMBDATRANFNS) + (ALISTS (LAMBDATRANFNS)) + (PROP MACRO LTSTKNAME) + (P (PUTHASH 'LTSTKNAME '(NIL) + MSTEMPLATES)) + (P (RELINK 'WORLD)) + (DECLARE%: EVAL@COMPILE DONTCOPY (P (RESETSAVE DWIMIFYCOMPFLG T)) + (GLOBALVARS CLISPARRAY COMMENTFLG LAMBDASPLST LAMBDATRANFNS BOUNDPDUMMY)) + (DECLARE%: DONTCOPY (RECORDS LAMBDAWORD)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML LTSTKNAME) + (LAMA]) @@ -46,12 +43,19 @@ Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved. (LOCALVARS . T) ) (DECLARE%: FIRST + (VIRGINFN 'ARGLIST T) + (MOVD? 'ARGLIST 'OLDARGLIST) + (VIRGINFN 'NARGS T) + (MOVD? 'NARGS 'OLDNARGS) + (VIRGINFN 'ARGTYPE T) + (MOVD? 'ARGTYPE 'OLDARGTYPE) + (MOVD? 'NILL 'LTDWIMUSERFN) ) (DEFINEQ @@ -190,14 +194,18 @@ Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved. (ADDTOVAR DWIMUSERFORMS (LTDWIMUSERFN)) -(PUTPROPS LAMBDATRANFNS VARTYPE ALIST) +(PUTPROPS LAMBDATRANFNS VARTYPE ALIST) (ADDTOVAR LAMBDATRANFNS ) -(PUTPROPS LTSTKNAME MACRO (X (CONS COMMENTFLG X))) -(PUTHASH 'LTSTKNAME '(NIL) MSTEMPLATES) +(PUTPROPS LTSTKNAME MACRO (X (CONS COMMENTFLG X))) + +(PUTHASH 'LTSTKNAME '(NIL) + MSTEMPLATES) + (RELINK 'WORLD) (DECLARE%: EVAL@COMPILE DONTCOPY + (RESETSAVE DWIMIFYCOMPFLG T) (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -219,8 +227,7 @@ Copyright (c) 1984, 1987 by Xerox Corporation. All rights reserved. (ADDTOVAR LAMA ) ) -(PUTPROPS LAMBDATRAN COPYRIGHT ("Xerox Corporation" 1984 1987)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2224 8821 (ARGLIST 2234 . 3188) (ARGTYPE 3190 . 3544) (FNTYP1 3546 . 4455) ( -LTDWIMUSERFN 4457 . 7957) (LTSTKNAME 7959 . 8483) (NARGS 8485 . 8819))))) + (FILEMAP (NIL (1871 8468 (ARGLIST 1881 . 2835) (ARGTYPE 2837 . 3191) (FNTYP1 3193 . 4102) ( +LTDWIMUSERFN 4104 . 7604) (LTSTKNAME 7606 . 8130) (NARGS 8132 . 8466))))) STOP diff --git a/lispusers/LAMBDATRAN.LCOM b/lispusers/LAMBDATRAN.LCOM index 2c586bd0..f11cf025 100644 Binary files a/lispusers/LAMBDATRAN.LCOM and b/lispusers/LAMBDATRAN.LCOM differ diff --git a/lispusers/LAYOUT-SEDIT b/lispusers/LAYOUT-SEDIT index 691b0076..705a6a3b 100644 --- a/lispusers/LAYOUT-SEDIT +++ b/lispusers/LAYOUT-SEDIT @@ -1,128 +1,127 @@ -(DEFINE-FILE-INFO §READTABLE "XCL" §PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" (§NICKNAMES "L-S"))) -(il:filecreated " 9-Jan-87 19:55:25" il:{eris}lispcore>layout-sedit.\;2 7190 +(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" (NICKNAMES "L-S")) READTABLE "XCL" BASE 10) - il:|changes| il:|to:| (il:variables user::*l-s-region-zero* user::*l-s-region-delta* - user::*l-s-reuse-earlier-regions*) - (il:functions get-region save-region user::use-l-s-regions - user::stop-using-l-s-regions) - (il:vars il:layout-seditcoms) +(IL:FILECREATED "18-Feb-2026 16:36:18" IL:|{WMEDLEY}LAYOUT-SEDIT.;2| 5714 - il:|previous| il:|date:| "26-Dec-86 19:42:46" il:{eris}lisp>layout-sedit.\;2) + :EDIT-BY IL:|rmk| + + :CHANGES-TO (IL:VARS IL:LAYOUT-SEDITCOMS) + (IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA* + USER::*L-S-REUSE-EARLIER-REGIONS*) + (IL:FUNCTIONS USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS REGION-PLUS + GET-REGION SAVE-REGION) + + :PREVIOUS-DATE " 9-Jan-87 19:55:25" IL:|{WMEDLEY}LAYOUT-SEDIT.;1|) -; Copyright (c) 1986, 1987 by Pavel Curtis. All rights reserved. +(IL:PRETTYCOMPRINT IL:LAYOUT-SEDITCOMS) -(il:prettycomprint il:layout-seditcoms) +(IL:RPAQQ IL:LAYOUT-SEDITCOMS + ((IL:FUNCTIONS USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS) + (IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA* + USER::*L-S-REUSE-EARLIER-REGIONS*) + (IL:FUNCTIONS REGION-PLUS) + (IL:FUNCTIONS GET-REGION SAVE-REGION) + (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (USER::USE-L-S-REGIONS) + )) + + (IL:* IL:|;;| "Arrange to use the proper compiler and makefile environment ") -(il:rpaqq il:layout-seditcoms ((il:functions user::use-l-s-regions user::stop-using-l-s-regions) - (il:variables *region-alist* user::*l-s-region-zero* - user::*l-s-region-delta* user::*l-s-reuse-earlier-regions*) - (il:functions region-plus) - (il:functions get-region save-region) - (il:declare\: il:donteval@load il:donteval@compile il:docopy - (il:p (user::use-l-s-regions))) - (il:* il:|;;| - "Arrange to use the proper compiler and makefile environment ") - (il:prop (il:filetype il:makefile-environment) - il:layout-sedit))) + (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) + IL:LAYOUT-SEDIT))) -(defun user::use-l-s-regions nil (assert (null il:|\\\\contexts|) - nil "Close all open SEdit windows") - (il:sedit.reset) - (il:movd 'il:sedit.get.window.region 'old-get-region) - (il:movd 'il:sedit.save.window.region 'old-save-region) - (il:movd 'get-region 'il:sedit.get.window.region) - (il:movd 'save-region 'il:sedit.save.window.region)) +(DEFUN USER::USE-L-S-REGIONS () + (ASSERT (NULL IL:|\\\\contexts|) + NIL "Close all open SEdit windows") + (IL:SEDIT.RESET) + (IL:MOVD 'IL:SEDIT.GET.WINDOW.REGION 'OLD-GET-REGION) + (IL:MOVD 'IL:SEDIT.SAVE.WINDOW.REGION 'OLD-SAVE-REGION) + (IL:MOVD 'GET-REGION 'IL:SEDIT.GET.WINDOW.REGION) + (IL:MOVD 'SAVE-REGION 'IL:SEDIT.SAVE.WINDOW.REGION)) +(DEFUN USER::STOP-USING-L-S-REGIONS () + (ASSERT (NULL IL:|\\\\contexts|) + NIL "Close all open SEdit windows") + (IL:SEDIT.RESET) + (IL:MOVD 'OLD-GET-REGION 'IL:SEDIT.GET.WINDOW.REGION) + (IL:MOVD 'OLD-SAVE-REGION 'IL:SEDIT.SAVE.WINDOW.REGION)) -(defun user::stop-using-l-s-regions nil (assert (null il:|\\\\contexts|) - nil "Close all open SEdit windows") - (il:sedit.reset) - (il:movd 'old-get-region 'il:sedit.get.window.region) - (il:movd 'old-save-region 'il:sedit.save.window.region)) +(DEFVAR *REGION-ALIST* NIL +(IL:* IL:|;;;| "An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL.") -(defvar *region-alist* nil + ) -(il:* il:|;;;| "An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL.") -) - - -(defvar user::*l-s-region-zero* (il:createregion 25 (- (truncate il:screenheight 2) +(DEFVAR USER::*L-S-REGION-ZERO* (IL:CREATEREGION 25 (- (TRUNCATE IL:SCREENHEIGHT 2) 19) - (truncate il:screenwidth 2) - (truncate il:screenheight 2)) + (TRUNCATE IL:SCREENWIDTH 2) + (TRUNCATE IL:SCREENHEIGHT 2)) -(il:* il:|;;;| "The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window.") - ) +(IL:* IL:|;;;| "The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window.") + ) -(defvar user::*l-s-region-delta* (il:createregion 11 -44 0 0) ) +(DEFVAR USER::*L-S-REGION-DELTA* (IL:CREATEREGION 11 -44 0 0)) +(DEFVAR USER::*L-S-REUSE-EARLIER-REGIONS* NIL -(defvar user::*l-s-reuse-earlier-regions* nil +(IL:* IL:|;;;| "If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created.") -(il:* il:|;;;| "If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created.") -) + ) +(DEFUN REGION-PLUS (ONE TWO) + (IL:CREATEREGION (+ (IL:FETCH (IL:REGION IL:LEFT) IL:OF ONE) + (IL:FETCH (IL:REGION IL:LEFT) IL:OF TWO)) + (+ (IL:FETCH (IL:REGION IL:BOTTOM) IL:OF ONE) + (IL:FETCH (IL:REGION IL:BOTTOM) IL:OF TWO)) + (+ (IL:FETCH (IL:REGION IL:WIDTH) IL:OF ONE) + (IL:FETCH (IL:REGION IL:WIDTH) IL:OF TWO)) + (+ (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF ONE) + (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF TWO)))) -(defun region-plus (one two) (il:createregion (+ (il:fetch (il:region il:left) il:of one) - (il:fetch (il:region il:left) il:of two)) - (+ (il:fetch (il:region il:bottom) il:of one) - (il:fetch (il:region il:bottom) il:of two)) - (+ (il:fetch (il:region il:width) il:of one) - (il:fetch (il:region il:width) il:of two)) - (+ (il:fetch (il:region il:height) il:of one) - (il:fetch (il:region il:height) il:of two)))) +(DEFUN GET-REGION (CONTEXT) + (LET ((PAIR (AND USER::*L-S-REUSE-EARLIER-REGIONS* (FIND NIL *REGION-ALIST* :KEY 'CDR)))) + (COND + ((NULL PAIR) + (COND + ((NULL *REGION-ALIST*) + (SETQ *REGION-ALIST* (LIST (CONS USER::*L-S-REGION-ZERO* CONTEXT))) + USER::*L-S-REGION-ZERO*) + (T (LET ((NEW-REGION (REGION-PLUS (CAR (FIRST *REGION-ALIST*)) + USER::*L-S-REGION-DELTA*))) + (PUSH (CONS NEW-REGION CONTEXT) + *REGION-ALIST*) + NEW-REGION)))) + (T (SETF (CDR PAIR) + CONTEXT) + (CAR PAIR))))) +(DEFUN SAVE-REGION (CONTEXT) -(defun get-region (context) (let ((pair (and user::*l-s-reuse-earlier-regions* (find nil - *region-alist* - :key - 'cdr)))) - (cond - ((null pair) - (cond - ((null *region-alist*) - (setq *region-alist* (list (cons user::*l-s-region-zero* - context))) - user::*l-s-region-zero*) - (t (let ((new-region (region-plus (car (first *region-alist*) - ) - user::*l-s-region-delta*))) - (push (cons new-region context) - *region-alist*) - new-region)))) - (t (setf (cdr pair) - context) - (car pair))))) +(IL:* IL:|;;;| "The context is done with its region. Deallocate it.") + (LET ((PAIR (FIND CONTEXT *REGION-ALIST* :KEY 'CDR))) + (IF (NULL PAIR) + (WARN "An SEdit context is trying to give up an unallocated region.") + (SETF (CDR PAIR) + NIL)) + (SETQ *REGION-ALIST* (MEMBER-IF-NOT 'NULL *REGION-ALIST* :KEY 'CDR)))) +(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY -(defun save-region (context) - -(il:* il:|;;;| "The context is done with its region. Deallocate it.") - (let ((pair (find context *region-alist* :key 'cdr))) - (if (null pair) - (warn "An SEdit context is trying to give up an unallocated region.") - (setf (cdr pair) - nil)) - (setq *region-alist* (member-if-not 'null *region-alist* :key 'cdr)))) - -(il:declare\: il:donteval@load il:donteval@compile il:docopy -(user::use-l-s-regions) +(USER::USE-L-S-REGIONS) ) -(il:* il:|;;| "Arrange to use the proper compiler and makefile environment ") +(IL:* IL:|;;| "Arrange to use the proper compiler and makefile environment ") -(il:putprops il:layout-sedit il:filetype compile-file) +(IL:PUTPROPS IL:LAYOUT-SEDIT IL:FILETYPE COMPILE-FILE) -(il:putprops il:layout-sedit il:makefile-environment (:readtable "XCL" :package (xcl:defpackage +(IL:PUTPROPS IL:LAYOUT-SEDIT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "LAYOUT-SEDIT" - (:nicknames "L-S")))) -(il:putprops il:layout-sedit il:copyright ("Pavel Curtis" 1986 1987)) -(il:declare\: il:dontcopy - (il:filemap (nil))) -il:stop + (:NICKNAMES "L-S")))) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL (1426 1788 (USER::USE-L-S-REGIONS 1426 . 1788)) (1790 2051 (USER::STOP-USING-L-S-REGIONS + 1790 . 2051)) (3443 4007 (REGION-PLUS 3443 . 4007)) (4009 4732 (GET-REGION 4009 . 4732)) (4734 5138 ( +SAVE-REGION 4734 . 5138))))) +IL:STOP diff --git a/lispusers/LAYOUT-SEDIT.LCOM b/lispusers/LAYOUT-SEDIT.LCOM index b129cec6..d3524c3f 100644 --- a/lispusers/LAYOUT-SEDIT.LCOM +++ b/lispusers/LAYOUT-SEDIT.LCOM @@ -1 +1,52 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" (NICKNAMES "L-S"))) (IL:FILECREATED " 9-Sep-94 13:47:35" ("compiled on " IL:|{DSK}lispusers>LAYOUT-SEDIT.;1|) "28-Jul-94 17:28:46" IL:|bcompl'd| IL:|in| "Medley 25-Aug-94 ..." IL:|dated| "25-Aug-94 10:02:49") (IL:FILECREATED " 9-Jan-87 19:55:25" IL:{ERIS}LISPCORE>LAYOUT-SEDIT.\;2 7190 IL:|changes| IL:|to:| (IL:VARIABLES USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA* USER::*L-S-REUSE-EARLIER-REGIONS* ) (IL:FUNCTIONS GET-REGION SAVE-REGION USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS) (IL:VARS IL:LAYOUT-SEDITCOMS) IL:|previous| IL:|date:| "26-Dec-86 19:42:46" IL:{ERIS}LISP>LAYOUT-SEDIT.\;2 ) (IL:PRETTYCOMPRINT IL:LAYOUT-SEDITCOMS) (IL:RPAQQ IL:LAYOUT-SEDITCOMS ((IL:FUNCTIONS USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS) ( IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA* USER::*L-S-REUSE-EARLIER-REGIONS*) (IL:FUNCTIONS REGION-PLUS) (IL:FUNCTIONS GET-REGION SAVE-REGION) ( IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (USER::USE-L-S-REGIONS))) (IL:* IL:|;;| "Arrange to use the proper compiler and makefile environment ") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:LAYOUT-SEDIT))) (DEFUN USER::USE-L-S-REGIONS NIL (ASSERT (NULL IL:|\\\\contexts|) NIL "Close all open SEdit windows") (IL:SEDIT.RESET) (IL:MOVD (QUOTE IL:SEDIT.GET.WINDOW.REGION) (QUOTE OLD-GET-REGION)) (IL:MOVD (QUOTE IL:SEDIT.SAVE.WINDOW.REGION) (QUOTE OLD-SAVE-REGION)) (IL:MOVD (QUOTE GET-REGION) (QUOTE IL:SEDIT.GET.WINDOW.REGION)) (IL:MOVD (QUOTE SAVE-REGION) (QUOTE IL:SEDIT.SAVE.WINDOW.REGION))) (DEFUN USER::STOP-USING-L-S-REGIONS NIL (ASSERT (NULL IL:|\\\\contexts|) NIL "Close all open SEdit windows") (IL:SEDIT.RESET) (IL:MOVD (QUOTE OLD-GET-REGION) (QUOTE IL:SEDIT.GET.WINDOW.REGION)) (IL:MOVD (QUOTE OLD-SAVE-REGION) (QUOTE IL:SEDIT.SAVE.WINDOW.REGION))) (DEFVAR *REGION-ALIST* NIL (IL:* IL:|;;;| "An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL." )) (DEFVAR USER::*L-S-REGION-ZERO* (IL:CREATEREGION 25 (- (TRUNCATE IL:SCREENHEIGHT 2) 19) (TRUNCATE IL:SCREENWIDTH 2) (TRUNCATE IL:SCREENHEIGHT 2)) (IL:* IL:|;;;| "The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window." )) (DEFVAR USER::*L-S-REGION-DELTA* (IL:CREATEREGION 11 -44 0 0)) (DEFVAR USER::*L-S-REUSE-EARLIER-REGIONS* NIL (IL:* IL:|;;;| "If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created." )) (DEFUN REGION-PLUS (ONE TWO) (IL:CREATEREGION (+ (IL:FETCH (IL:REGION IL:LEFT) IL:OF ONE) (IL:FETCH ( IL:REGION IL:LEFT) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:BOTTOM) IL:OF ONE) (IL:FETCH (IL:REGION IL:BOTTOM) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:WIDTH) IL:OF ONE) (IL:FETCH (IL:REGION IL:WIDTH) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF ONE) (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF TWO)))) (DEFUN GET-REGION (CONTEXT) (LET ((PAIR (AND USER::*L-S-REUSE-EARLIER-REGIONS* (FIND NIL *REGION-ALIST* :KEY (QUOTE CDR))))) (COND ((NULL PAIR) (COND ((NULL *REGION-ALIST*) (SETQ *REGION-ALIST* (LIST (CONS USER::*L-S-REGION-ZERO* CONTEXT))) USER::*L-S-REGION-ZERO*) (T (LET (( NEW-REGION (REGION-PLUS (CAR (FIRST *REGION-ALIST*)) USER::*L-S-REGION-DELTA*))) (PUSH (CONS NEW-REGION CONTEXT) *REGION-ALIST*) NEW-REGION)))) (T (SETF (CDR PAIR) CONTEXT) (CAR PAIR))))) (DEFUN SAVE-REGION (CONTEXT) (IL:* IL:|;;;| "The context is done with its region. Deallocate it.") ( LET ((PAIR (FIND CONTEXT *REGION-ALIST* :KEY (QUOTE CDR)))) (IF (NULL PAIR) (WARN "An SEdit context is trying to give up an unallocated region.") (SETF (CDR PAIR) NIL)) (SETQ *REGION-ALIST* (MEMBER-IF-NOT (QUOTE NULL) *REGION-ALIST* :KEY (QUOTE CDR))))) (USER::USE-L-S-REGIONS) (IL:PUTPROPS IL:LAYOUT-SEDIT IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:LAYOUT-SEDIT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "LAYOUT-SEDIT" (:NICKNAMES "L-S")))) (IL:PUTPROPS IL:LAYOUT-SEDIT IL:COPYRIGHT ("Pavel Curtis" 1986 1987)) NIL \ No newline at end of file +(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LAYOUT-SEDIT" (NICKNAMES "L-S")) READTABLE "XCL" BASE 10) + +(IL:FILECREATED "18-Feb-2026 16:39:44" ("compiled on " IL:|{WMEDLEY}LAYOUT-SEDIT.;2|) +"18-Feb-2026 16:37:55" IL:|bcompl'd| IL:|in| "FULL 18-Feb-2026 ..." IL:|dated| "18-Feb-2026 16:38:04") +(IL:FILECREATED "18-Feb-2026 16:36:18" IL:|{WMEDLEY}LAYOUT-SEDIT.;2| 5714 :EDIT-BY IL:|rmk| + :CHANGES-TO (IL:VARS IL:LAYOUT-SEDITCOMS) (IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* +USER::*L-S-REGION-DELTA* USER::*L-S-REUSE-EARLIER-REGIONS*) (IL:FUNCTIONS USER::USE-L-S-REGIONS +USER::STOP-USING-L-S-REGIONS REGION-PLUS GET-REGION SAVE-REGION) :PREVIOUS-DATE " 9-Jan-87 19:55:25" +IL:|{WMEDLEY}LAYOUT-SEDIT.;1|) +(IL:PRETTYCOMPRINT IL:LAYOUT-SEDITCOMS) +(IL:RPAQQ IL:LAYOUT-SEDITCOMS ((IL:FUNCTIONS USER::USE-L-S-REGIONS USER::STOP-USING-L-S-REGIONS) ( +IL:VARIABLES *REGION-ALIST* USER::*L-S-REGION-ZERO* USER::*L-S-REGION-DELTA* +USER::*L-S-REUSE-EARLIER-REGIONS*) (IL:FUNCTIONS REGION-PLUS) (IL:FUNCTIONS GET-REGION SAVE-REGION) ( +IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (USER::USE-L-S-REGIONS))) (IL:* +IL:|;;| "Arrange to use the proper compiler and makefile environment ") (IL:PROP (IL:FILETYPE +IL:MAKEFILE-ENVIRONMENT) IL:LAYOUT-SEDIT))) +(DEFUN USER::USE-L-S-REGIONS NIL (ASSERT (NULL IL:|\\\\contexts|) NIL "Close all open SEdit windows") +(IL:SEDIT.RESET) (IL:MOVD (QUOTE IL:SEDIT.GET.WINDOW.REGION) (QUOTE OLD-GET-REGION)) (IL:MOVD (QUOTE +IL:SEDIT.SAVE.WINDOW.REGION) (QUOTE OLD-SAVE-REGION)) (IL:MOVD (QUOTE GET-REGION) (QUOTE +IL:SEDIT.GET.WINDOW.REGION)) (IL:MOVD (QUOTE SAVE-REGION) (QUOTE IL:SEDIT.SAVE.WINDOW.REGION))) +(DEFUN USER::STOP-USING-L-S-REGIONS NIL (ASSERT (NULL IL:|\\\\contexts|) NIL +"Close all open SEdit windows") (IL:SEDIT.RESET) (IL:MOVD (QUOTE OLD-GET-REGION) (QUOTE +IL:SEDIT.GET.WINDOW.REGION)) (IL:MOVD (QUOTE OLD-SAVE-REGION) (QUOTE IL:SEDIT.SAVE.WINDOW.REGION))) +(DEFVAR *REGION-ALIST* NIL (IL:* IL:|;;;| +"An AList mapping a region to the SEdit context that currently owns it. The associations of regions no longer in use should have a CDR of NIL. The list is kept in reverse order, with the farthest region from *REGION-ZERO* at the front of the list. So as to allow experimentation by users, we maintain the invariant that the first association on the list never has a CDR of NIL. To reestablish that invariant, we sometimes POP the AList rather than set the CDR to NIL." +)) +(DEFVAR USER::*L-S-REGION-ZERO* (IL:CREATEREGION 25 (- (TRUNCATE IL:SCREENHEIGHT 2) 19) (TRUNCATE +IL:SCREENWIDTH 2) (TRUNCATE IL:SCREENHEIGHT 2)) (IL:* IL:|;;;| +"The region to be used by the first SEdit window. This works in conjunction with USER::*L-S-REGION-DELTA* to specify the region for each new SEdit window." +)) +(DEFVAR USER::*L-S-REGION-DELTA* (IL:CREATEREGION 11 -44 0 0)) +(DEFVAR USER::*L-S-REUSE-EARLIER-REGIONS* NIL (IL:* IL:|;;;| +"If non-NIL, then earlier regions (i.e., those closer to USER::*L-S-REGION-ZERO* will get reused when free. Otherwise, new regions, farther from USER::*L-S-REGION-ZERO* than any currently in use, will be created." +)) +(DEFUN REGION-PLUS (ONE TWO) (IL:CREATEREGION (+ (IL:FETCH (IL:REGION IL:LEFT) IL:OF ONE) (IL:FETCH ( +IL:REGION IL:LEFT) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:BOTTOM) IL:OF ONE) (IL:FETCH (IL:REGION +IL:BOTTOM) IL:OF TWO)) (+ (IL:FETCH (IL:REGION IL:WIDTH) IL:OF ONE) (IL:FETCH (IL:REGION IL:WIDTH) IL:OF + TWO)) (+ (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF ONE) (IL:FETCH (IL:REGION IL:HEIGHT) IL:OF TWO)))) +(DEFUN GET-REGION (CONTEXT) (LET ((PAIR (AND USER::*L-S-REUSE-EARLIER-REGIONS* (FIND NIL +*REGION-ALIST* :KEY (QUOTE CDR))))) (COND ((NULL PAIR) (COND ((NULL *REGION-ALIST*) (SETQ +*REGION-ALIST* (LIST (CONS USER::*L-S-REGION-ZERO* CONTEXT))) USER::*L-S-REGION-ZERO*) (T (LET (( +NEW-REGION (REGION-PLUS (CAR (FIRST *REGION-ALIST*)) USER::*L-S-REGION-DELTA*))) (PUSH (CONS +NEW-REGION CONTEXT) *REGION-ALIST*) NEW-REGION)))) (T (SETF (CDR PAIR) CONTEXT) (CAR PAIR))))) +(DEFUN SAVE-REGION (CONTEXT) (IL:* IL:|;;;| "The context is done with its region. Deallocate it.") ( +LET ((PAIR (FIND CONTEXT *REGION-ALIST* :KEY (QUOTE CDR)))) (IF (NULL PAIR) (WARN +"An SEdit context is trying to give up an unallocated region.") (SETF (CDR PAIR) NIL)) (SETQ +*REGION-ALIST* (MEMBER-IF-NOT (QUOTE NULL) *REGION-ALIST* :KEY (QUOTE CDR))))) +(USER::USE-L-S-REGIONS) +(IL:PUTPROPS IL:LAYOUT-SEDIT IL:FILETYPE COMPILE-FILE) +(IL:PUTPROPS IL:LAYOUT-SEDIT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE +"LAYOUT-SEDIT" (:NICKNAMES "L-S")))) +NIL diff --git a/lispusers/PHONE-DIRECTORY b/lispusers/PHONE-DIRECTORY index a2f4a9e3..5ab74fb8 100644 --- a/lispusers/PHONE-DIRECTORY +++ b/lispusers/PHONE-DIRECTORY @@ -1,32 +1,27 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED " 2-Feb-87 10:38:19" {ERIS}LYRIC>PHONE-DIRECTORY.;1 9029 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (VARS PHONE-DIRECTORYCOMS) +(FILECREATED "18-Feb-2026 16:27:33" {WMEDLEY}PHONE-DIRECTORY.;2 8485 - previous date%: " 9-Jan-87 19:45:25" {ERIS}KOTO>PHONE-DIRECTORY.;3) + :EDIT-BY rmk + :PREVIOUS-DATE " 2-Feb-87 10:38:19" {WMEDLEY}PHONE-DIRECTORY.;1) -(* " -Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT PHONE-DIRECTORYCOMS) -(RPAQQ PHONE-DIRECTORYCOMS ((FNS Cache-Phone-Directory-Files Let-your-fingers-do-the-walking - Phone-Directory-Kill-Proc Phone-Window-ButtonEventFn Lookup-Person - Phone-Window-WhenOpenedFn) - (VARS fingersIconMask fingersIconBM) - (INITVARS (*Cached-Phone-Directory-Files* NIL) - (*Phone-Directory-Pos* (create POSITION XCOORD _ 15 YCOORD _ - (DIFFERENCE SCREENHEIGHT 75))) - (*Phone-Directory-Region* (CREATEREGION 15 (DIFFERENCE - SCREENHEIGHT 258 - ) - 400 250))) - (GLOBALVARS *Cached-Phone-Directory-Files* *Phone-Directory-Pos* - *Phone-Directory-Region* fingersIconMask fingersIconBM) - (FILES GREP) - (P (Let-your-fingers-do-the-walking)))) +(RPAQQ PHONE-DIRECTORYCOMS + ((FNS Cache-Phone-Directory-Files Let-your-fingers-do-the-walking Phone-Directory-Kill-Proc + Phone-Window-ButtonEventFn Lookup-Person Phone-Window-WhenOpenedFn) + (VARS fingersIconMask fingersIconBM) + (INITVARS (*Cached-Phone-Directory-Files* NIL) + (*Phone-Directory-Pos* (create POSITION XCOORD _ 15 YCOORD _ (DIFFERENCE SCREENHEIGHT + 75))) + (*Phone-Directory-Region* (CREATEREGION 15 (DIFFERENCE SCREENHEIGHT 258) + 400 250))) + (GLOBALVARS *Cached-Phone-Directory-Files* *Phone-Directory-Pos* *Phone-Directory-Region* + fingersIconMask fingersIconBM) + (FILES GREP) + (P (Let-your-fingers-do-the-walking)))) (DEFINEQ (Cache-Phone-Directory-Files @@ -139,11 +134,12 @@ Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. (GLOBALVARS *Cached-Phone-Directory-Files* *Phone-Directory-Pos* *Phone-Directory-Region* fingersIconMask fingersIconBM) ) + (FILESLOAD GREP) -(Let-your-fingers-do-the-walking) -(PUTPROPS PHONE-DIRECTORY COPYRIGHT ("Xerox Corporation" 1986 1987)) + +(Let-your-fingers-do-the-walking) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1649 6373 (Cache-Phone-Directory-Files 1659 . 2954) (Let-your-fingers-do-the-walking -2956 . 4251) (Phone-Directory-Kill-Proc 4253 . 4684) (Phone-Window-ButtonEventFn 4686 . 5362) ( -Lookup-Person 5364 . 5976) (Phone-Window-WhenOpenedFn 5978 . 6371))))) + (FILEMAP (NIL (1168 5892 (Cache-Phone-Directory-Files 1178 . 2473) (Let-your-fingers-do-the-walking +2475 . 3770) (Phone-Directory-Kill-Proc 3772 . 4203) (Phone-Window-ButtonEventFn 4205 . 4881) ( +Lookup-Person 4883 . 5495) (Phone-Window-WhenOpenedFn 5497 . 5890))))) STOP diff --git a/lispusers/SKETCHCOLOR b/lispusers/SKETCHCOLOR index 499438c2..9a9e0b69 100644 --- a/lispusers/SKETCHCOLOR +++ b/lispusers/SKETCHCOLOR @@ -1,15 +1,11 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED " 9-Jan-87 16:47:16" {ERIS}LIBRARY>SKETCHCOLOR.;2 4779 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (VARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE - GREENTEXTURE BLUETEXTURE SKETCHCOLORCOMS) +(FILECREATED "18-Feb-2026 16:28:03" {WMEDLEY}SKETCHCOLOR.;2 4732 - previous date%: "29-Oct-85 14:44:30" {ERIS}LIBRARY>SKETCHCOLOR.;1) + :EDIT-BY rmk + :PREVIOUS-DATE " 9-Jan-87 16:47:16" {WMEDLEY}SKETCHCOLOR.;1) -(* " -Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT SKETCHCOLORCOMS) @@ -75,25 +71,30 @@ Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. ) (RPAQQ SKETCHINCOLORFLG T) + (FILESLOAD COLOR STYLESHEET) -(PUTPROPS \FILLCIRCLE.DISPLAY READVICE [NIL (BEFORE NIL (COND ((LISTP TEXTURE) - (COND ((TEXTUREP (CAR TEXTURE)) - (SETQ TEXTURE (CAR TEXTURE))) - (T (SETQ TEXTURE - (TEXTUREOFCOLOR - (CADR TEXTURE]) +[XCL:REINSTALL-ADVICE '\FILLCIRCLE.DISPLAY :BEFORE '((:LAST (COND + ((LISTP TEXTURE) + (COND + ((TEXTUREP (CAR TEXTURE)) + (SETQ TEXTURE (CAR TEXTURE))) + (T (SETQ TEXTURE + (TEXTUREOFCOLOR (CADR TEXTURE] + +[XCL:REINSTALL-ADVICE '\POLYSHADE.DISPLAY :BEFORE '((:LAST (COND + ((LISTP FILL.SHADE) + (COND + ((TEXTUREP (CAR FILL.SHADE)) + (SETQ FILL.SHADE (CAR FILL.SHADE)) + ) + (T (SETQ FILL.SHADE + (TEXTUREOFCOLOR (CADR + FILL.SHADE + ] -(PUTPROPS \POLYSHADE.DISPLAY READVICE [NIL (BEFORE NIL (COND ((LISTP FILL.SHADE) - (COND ((TEXTUREP (CAR FILL.SHADE)) - (SETQ FILL.SHADE (CAR FILL.SHADE - ))) - (T (SETQ FILL.SHADE - (TEXTUREOFCOLOR - (CADR FILL.SHADE]) (READVISE \FILLCIRCLE.DISPLAY \POLYSHADE.DISPLAY) -(PUTPROPS SKETCHCOLOR COPYRIGHT ("Xerox Corporation" 1985 1987)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (771 3368 (COLORTEXTURETEST 781 . 2128) (LEVELTEXTURE 2130 . 2662) (PRIMARYTEXTURE 2664 - . 3366))))) + (FILEMAP (NIL (547 3144 (COLORTEXTURETEST 557 . 1904) (LEVELTEXTURE 1906 . 2438) (PRIMARYTEXTURE 2440 + . 3142))))) STOP diff --git a/lispusers/TRANSOR b/lispusers/TRANSOR index 2f9ea07c..f71957c0 100644 --- a/lispusers/TRANSOR +++ b/lispusers/TRANSOR @@ -1,16 +1,18 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED "17-Mar-87 17:03:54" {DSK}TRANSOR.;16 44778 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (VARS TRANSORCOMS) - (FNS PRECH1 TRANSOUT) +(FILECREATED "18-Feb-2026 21:57:19" {WMEDLEY}TRANSOR.;2 43458 - previous date%: "17-Mar-87 17:00:04" {DSK}TRANSOR.;15) + :EDIT-BY rmk + + :CHANGES-TO (VARS TRANSORCOMS) + + :PREVIOUS-DATE "17-Mar-87 17:03:54" {WMEDLEY}TRANSOR.;1) (PRETTYCOMPRINT TRANSORCOMS) -(RPAQQ TRANSORCOMS - ((FNS TRANSOR TRANSOR-PROCEED TRANSORFORM TRANSORFNS TRANSFORM TRANSIT TRANXT TRANSEXIT +(RPAQQ TRANSORCOMS + [(FNS TRANSOR TRANSOR-PROCEED TRANSORFORM TRANSORFNS TRANSFORM TRANSIT TRANXT TRANSEXIT KEEPLIST TRANSERR TRANSOUT PPASS1 TRANSLIST TRANSLIST1 PREMTEXT WACHADOON PRECH PRECH1 PRECH2 RETAIL LNC PRESCAN) TRANSORMACROS TRANSOREMARKS TRANSORGLOBALS @@ -18,8 +20,10 @@ (TESTRAN) (USERMACROS (APPEND TRANSORMACROS USERMACROS)) (GLOBALVARS (APPEND TRANSORGLOBALS GLOBALVARS)) - (EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE) EDITCOMSA)) - (EDITCOMSL (UNION '(REMARK) EDITCOMSL)) + (EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE) + EDITCOMSA)) + (EDITCOMSL (UNION '(REMARK) + EDITCOMSL)) (TRANSITCONSES '(ORR NIL XFORMER)) (PRESCARRAY (ARRAY 127 127))) (INITVARS (NLISTPCOMS) @@ -36,10 +40,9 @@ (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) (NIL PRESCAN (GLOBALVARS PRESCARRAY))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML TRANSERR KEEPLIST + (NLAML TRANSERR KEEPLIST TRANSOR-PROCEED) - (LAMA))) - (EDITHIST TRANSOR))) + (LAMA]) (DEFINEQ (TRANSOR @@ -861,52 +864,49 @@ TRANSOR made a translation error: " T) (RETURN (CLOSEF OUTF))))) ) -(RPAQQ TRANSORMACROS ((REMARK (TXT) - (E (KEEPLIST TXT) - T)) - (NLAM NIL (E (SETQQ WHERETOGONEXT NLAMIT) - T)) - [NLAMIT NIL (ORR NX !NX ((E (TRANSEXIT] - (DOTHESE NIL (E (TRANSOR-PROCEED DOTHESE) - T) - NLAM) - (DOTHIS NIL (E (TRANSOR-PROCEED DOTHIS) - T) - NLAM) - (XFORMER NIL (E (TRANSERR TRANSFORMATIONERROR "FAULTY TRANSFORMATION" - (CURRENTFORM CURRENTCOMS)) - T)))) +(RPAQQ TRANSORMACROS + ((REMARK (TXT) + (E (KEEPLIST TXT) + T)) + (NLAM NIL (E (SETQQ WHERETOGONEXT NLAMIT) + T)) + [NLAMIT NIL (ORR NX !NX ((E (TRANSEXIT] + (DOTHESE NIL (E (TRANSOR-PROCEED DOTHESE) + T) + NLAM) + (DOTHIS NIL (E (TRANSOR-PROCEED DOTHIS) + T) + NLAM) + (XFORMER NIL (E (TRANSERR TRANSFORMATIONERROR "FAULTY TRANSFORMATION" (CURRENTFORM + CURRENTCOMS)) + T)))) -(RPAQQ TRANSOREMARKS ((TRANSFORMATIONERROR (* The TRANSFORMATIONS specified for this form failed to - work properly. The TTY message %'FAULTY TRANSFORMATION' - was printed, any commands remaining in the - transformation after the erroneous one were skipped, - and translation continued as if the transformation had - been normally completed. The user should treat the - translated form with caution and amend his - transformation to avoid future problems.)) - (TRANSERROR (* TRANSOR got confused at this point. The TTY message %'SHOW JIM - GOODWIN' was printed and translation continued with the next - form, but the user should treat the compromised area of code - with caution.)) - (BLAMBDA1 (* Non-atomic CAR of form, but not an open lambda. Either a - parenthesis error or computed CAR of form. Computed CAR of form is - no longer legal in BBN-LISP; APPLY* is used instead. If computed - CAR of form was intended, the translation to APPLY* will run ok. - See manual for discussion of APPLY*.)) - (BLAMBDA2 (* Open LAMBDA with wrong number of args. What can it mean?)) - (BLAMBDA3 (* Lambda-expression without forms. What can it mean?)) - (ILLCAR (* Illegal data-type encountered as CAR of form Expression treated as - list of forms.)) - (TAILP/DOTHIS (* When the transormacro DOTHIS is executed at a TAILP position, - TRANSOR does a 1 command first, assuming that the current - position is a list of forms and CAR of it is the form - intended. The user should make sure that this is what was - intended by the TRANSFORMATIONS which called DOTHIS, i.e. the - TRANSFORMATIONS for the form containing this one.)))) +(RPAQQ TRANSOREMARKS + ((TRANSFORMATIONERROR (* The TRANSFORMATIONS specified for this form failed to work properly. + The TTY message %'FAULTY TRANSFORMATION' was printed, any commands + remaining in the transformation after the erroneous one were skipped, + and translation continued as if the transformation had been normally + completed. The user should treat the translated form with caution and + amend his transformation to avoid future problems.)) + (TRANSERROR (* TRANSOR got confused at this point. The TTY message %'SHOW JIM GOODWIN' was + printed and translation continued with the next form, but the user should + treat the compromised area of code with caution.)) + (BLAMBDA1 (* Non-atomic CAR of form, but not an open lambda. Either a parenthesis error or + computed CAR of form. Computed CAR of form is no longer legal in BBN-LISP; + APPLY* is used instead. If computed CAR of form was intended, the translation to + APPLY* will run ok. See manual for discussion of APPLY*.)) + (BLAMBDA2 (* Open LAMBDA with wrong number of args. What can it mean?)) + (BLAMBDA3 (* Lambda-expression without forms. What can it mean?)) + (ILLCAR (* Illegal data-type encountered as CAR of form Expression treated as list of forms.) + ) + (TAILP/DOTHIS (* When the transormacro DOTHIS is executed at a TAILP position, TRANSOR does a + 1 command first, assuming that the current position is a list of forms and + CAR of it is the form intended. The user should make sure that this is what + was intended by the TRANSFORMATIONS which called DOTHIS, i.e. the + TRANSFORMATIONS for the form containing this one.)))) (RPAQQ TRANSORGLOBALS (USERNOTES USERNOTES TESTFORM TESTFORM TRANSFORMATIONS TRANSFORMATIONS - XFORMSFNS XFORMSVARS XFORMSVARS DUMPFILE TRANSFORMATIONS TRANSFORMATIONS + XFORMSFNS XFORMSVARS XFORMSVARS DUMPFILE TRANSFORMATIONS TRANSFORMATIONS TRANSFORMATIONS TRANSFORMATIONS)) (RPAQQ MAXLOOP 1530) @@ -917,9 +917,11 @@ TRANSOR made a translation error: " T) (RPAQ GLOBALVARS (APPEND TRANSORGLOBALS GLOBALVARS)) -(RPAQ EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE) EDITCOMSA)) +(RPAQ EDITCOMSA (UNION '(NLAM NLAMIT DOTHESE DOTHIS XFORMER CONTINUE) + EDITCOMSA)) -(RPAQ EDITCOMSL (UNION '(REMARK) EDITCOMSL)) +(RPAQ EDITCOMSL (UNION '(REMARK) + EDITCOMSL)) (RPAQQ TRANSITCONSES (ORR NIL XFORMER)) @@ -932,7 +934,7 @@ TRANSOR made a translation error: " T) (RPAQ? TRANSOUTREADTABLE FILERDTBL) (DECLARE%: DOEVAL@LOAD DOEVAL@COMPILE DONTCOPY -(PUTPROPS TAILP BLKLIBRARYDEF [LAMBDA (.BLKVAR.X .BLKVAR.Y) +(PUTPROPS TAILP BLKLIBRARYDEF [LAMBDA (.BLKVAR.X .BLKVAR.Y) (* True if .BLKVAR.X is A tail of .BLKVAR.Y .BLKVAR.X and .BLKVAR.Y non-null.) (* Included with editor for block compilation purposes.) @@ -944,15 +946,19 @@ TRANSOR made a translation error: " T) (GO LP]) ) -(PUTPROPS TRANSOR FILEGROUP (TRANSOR TSET)) +(PUTPROPS TRANSOR FILEGROUP (TRANSOR TSET)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY + (BLOCK%: PRECHBLOCK PRECH PRECH1 PRECH2 RETAIL LNC (ENTRIES PRECH) (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) + (BLOCK%: TRANSITBLOCK TRANSIT WACHADOON (ENTRIES TRANSIT WACHADOON) (GLOBALVARS WACHADID WHENTODOIT TRANSITCONSES LAMBDACOMS NLISTPCOMS) (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) + (BLOCK%: TRANXTBLOCK TRANXT (ENTRIES TRANXT) (BLKLIBRARY TAILP MEMB LAST LENGTH ASSOC GETP)) + (BLOCK%: NIL PRESCAN (GLOBALVARS PRESCARRAY)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS @@ -963,23 +969,11 @@ TRANSOR made a translation error: " T) (ADDTOVAR LAMA ) ) -(DECLARE%: DONTCOPY - -(ADDTOVAR EDITHISTALIST (TRANSOR (" 5-Feb-87 16:18:06" DJVB {DSK}TRANSOR.;11 (TRANSOR) - (FIXED TO WORK WITH NEW FILE RULES IN LYRIC)) - (" 6-Feb-87 15:24:20" DJVB {DSK}TRANSOR.;12 (TRANSOR)) - (" 6-Mar-87 14:41:26" DJVB {DSK}TRANSOR.;13 - (TRANSOR TRANSOR-PROCEED TRANSORFORM TRANSORFNS TRANSFORM - RETAIL)) - ("17-Mar-87 17:01:53" DJVB {DSK}TRANSOR.;15 (PRECH1 TRANSOUT) - (ADDED SPLIT READ/WRITE READTABLES AND PP FOR DEFUN)))) -) -(PUTPROPS TRANSOR COPYRIGHT (NONE)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2231 38324 (TRANSOR 2241 . 6284) (TRANSOR-PROCEED 6286 . 9093) (TRANSORFORM 9095 . 9527 -) (TRANSORFNS 9529 . 10225) (TRANSFORM 10227 . 11965) (TRANSIT 11967 . 14735) (TRANXT 14737 . 17950) ( -TRANSEXIT 17952 . 18262) (KEEPLIST 18264 . 19224) (TRANSERR 19226 . 19990) (TRANSOUT 19992 . 22436) ( -PPASS1 22438 . 22679) (TRANSLIST 22681 . 23700) (TRANSLIST1 23702 . 23934) (PREMTEXT 23936 . 24641) ( -WACHADOON 24643 . 25114) (PRECH 25116 . 25609) (PRECH1 25611 . 27779) (PRECH2 27781 . 28727) (RETAIL -28729 . 29976) (LNC 29978 . 30841) (PRESCAN 30843 . 38322))))) + (FILEMAP (NIL (2262 38355 (TRANSOR 2272 . 6315) (TRANSOR-PROCEED 6317 . 9124) (TRANSORFORM 9126 . 9558 +) (TRANSORFNS 9560 . 10256) (TRANSFORM 10258 . 11996) (TRANSIT 11998 . 14766) (TRANXT 14768 . 17981) ( +TRANSEXIT 17983 . 18293) (KEEPLIST 18295 . 19255) (TRANSERR 19257 . 20021) (TRANSOUT 20023 . 22467) ( +PPASS1 22469 . 22710) (TRANSLIST 22712 . 23731) (TRANSLIST1 23733 . 23965) (PREMTEXT 23967 . 24672) ( +WACHADOON 24674 . 25145) (PRECH 25147 . 25640) (PRECH1 25642 . 27810) (PRECH2 27812 . 28758) (RETAIL +28760 . 30007) (LNC 30009 . 30872) (PRESCAN 30874 . 38353))))) STOP diff --git a/lispusers/TRANSOR-LOADTRAN b/lispusers/TRANSOR-LOADTRAN index f8a7ed9c..af8a0b57 100644 --- a/lispusers/TRANSOR-LOADTRAN +++ b/lispusers/TRANSOR-LOADTRAN @@ -1,25 +1,19 @@ -(DEFINE-FILE-INFO §PACKAGE "XCL-USER" §READTABLE "XCL") -(IL:FILECREATED "13-Apr-87 17:38:17" IL:{DSK}LOADTRAN.\;9 2045 +(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL" BASE 10) - IL:|changes| IL:|to:| (IL:VARS IL:LOADTRANCOMS STOP) - (IL:FUNCTIONS MYLOAD I.S.OPR PRETTYCOMPRINT SETTEMPLATE DEFINE-FILE-INFO - ) - (IL:FNS PRETTYCOMPRINT SETTEMPLATE) +(IL:FILECREATED "18-Feb-2026 22:58:35" IL:|{WMEDLEY}TRANSOR-LOADTRAN.;2| 1561 - IL:|previous| IL:|date:| " 6-Apr-87 16:57:48" IL:{DSK}LOADTRAN.\;1) + :EDIT-BY IL:|rmk|) -; Copyright (c) 1987 by System Development Corp.. All rights reserved. +(IL:PRETTYCOMPRINT IL:TRANSOR-LOADTRANCOMS) -(IL:PRETTYCOMPRINT IL:LOADTRANCOMS) - -(IL:RPAQQ IL:LOADTRANCOMS ((IL:VARS STOP) - (IL:FNS PRETTYCOMPRINT SETTEMPLATE) - (IL:FUNCTIONS DEFINE-FILE-INFO I.S.OPR MYLOAD) - (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY - IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA PRETTYCOMPRINT) - (IL:NLAML) - (IL:LAMA SETTEMPLATE))))) +(IL:RPAQQ IL:TRANSOR-LOADTRANCOMS ((IL:VARS STOP) + (IL:FNS PRETTYCOMPRINT SETTEMPLATE) + (IL:FUNCTIONS DEFINE-FILE-INFO I.S.OPR MYLOAD) + (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY + IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA PRETTYCOMPRINT) + (IL:NLAML) + (IL:LAMA SETTEMPLATE))))) (IL:RPAQQ STOP STOP) (IL:DEFINEQ @@ -33,17 +27,17 @@ (BLOCK SETTEMPLATE (NILL)))) ) -(DEFUN DEFINE-FILE-INFO (&REST ARGS) (NILL)) +(DEFUN DEFINE-FILE-INFO (&REST ARGS) + (NILL)) +(DEFUN I.S.OPR (X) + (NILL)) -(DEFUN I.S.OPR (X) (NILL)) - - -(DEFUN MYLOAD (FILE) (LET ((FILE (OPEN FILE :DIRECTION :INPUT))) - (UNWIND-PROTECT (IL:\\CML-LOAD FILE T *TERMINAL-IO* (FIND-PACKAGE - "XCL-USER")) - (CLOSE FILE)))) - +(DEFUN MYLOAD (FILE) + (LET ((FILE (OPEN FILE :DIRECTION :INPUT))) + (UNWIND-PROTECT + (IL:\\CML-LOAD FILE T *TERMINAL-IO* (FIND-PACKAGE "XCL-USER")) + (CLOSE FILE)))) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA PRETTYCOMPRINT) @@ -52,7 +46,7 @@ (IL:ADDTOVAR IL:LAMA SETTEMPLATE) ) -(IL:PUTPROPS IL:LOADTRAN IL:COPYRIGHT ("System Development Corp." 1987)) (IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL (1134 1357 (PRETTYCOMPRINT 1147 . 1283) (SETTEMPLATE 1285 . 1355))))) + (IL:FILEMAP (NIL (830 1053 (PRETTYCOMPRINT 843 . 979) (SETTEMPLATE 981 . 1051)) (1055 1106 ( +DEFINE-FILE-INFO 1055 . 1106)) (1108 1141 (I.S.OPR 1108 . 1141)) (1143 1341 (MYLOAD 1143 . 1341))))) IL:STOP diff --git a/lispusers/TRANSOR-LOADTRAN.LCOM b/lispusers/TRANSOR-LOADTRAN.LCOM index 0657438e..bd1a4f8b 100644 Binary files a/lispusers/TRANSOR-LOADTRAN.LCOM and b/lispusers/TRANSOR-LOADTRAN.LCOM differ diff --git a/lispusers/TRANSOR.LCOM b/lispusers/TRANSOR.LCOM index 61e65aec..2b9bd1e4 100644 Binary files a/lispusers/TRANSOR.LCOM and b/lispusers/TRANSOR.LCOM differ diff --git a/lispusers/UNBOXEDOPS b/lispusers/UNBOXEDOPS index 5482c4cf..5805f91b 100644 --- a/lispusers/UNBOXEDOPS +++ b/lispusers/UNBOXEDOPS @@ -1,20 +1,15 @@ -(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) -(FILECREATED " 7-Dec-86 17:26:23" {ERIS}LISPCORE>UNBOXEDOPS.;7 12906 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (OPTIMIZERS UFREMAINDER2 UFREMAINDER) - (FNS UFREMAINDER) - (VARS UNBOXEDOPSCOMS) +(FILECREATED "18-Feb-2026 16:17:02" {WMEDLEY}UNBOXEDOPS.;2 10856 - previous date%: " 3-Nov-86 20:30:24" {ERIS}LISPCORE>UNBOXEDOPS.;6) + :EDIT-BY rmk + :PREVIOUS-DATE " 7-Dec-86 17:26:23" {WMEDLEY}UNBOXEDOPS.;1) -(* " -Copyright (c) 1986 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT UNBOXEDOPSCOMS) -(RPAQQ UNBOXEDOPSCOMS +(RPAQQ UNBOXEDOPSCOMS [(FNS UFABS UFEQP UFGEQ UFGREATERP UFIX UFLEQ UFLESSP UFMAX UFMIN UFMINUS UFREMAINDER) (OPTIMIZERS UFABS UFABS1 UFEQP UFEQP2 UFGEQ UFGEQ2 UFGREATERP UFGREATERP2 UFIX UFIX1 UFLEQ UFLEQ2 UFLESSP UFLESSP2 UFMAX UFMAX2 UFMIN UFMIN2 UFMINUS UFMINUS1 UFREMAINDER) @@ -81,178 +76,168 @@ Copyright (c) 1986 by Xerox Corporation. All rights reserved. FY]) ) -(DEFOPTIMIZER UFABS (&OPTIONAL (ARG1 NIL ARG1GIVEN) - &REST RESTARGS &WHOLE ORIGINAL) (if (OR (NOT ARG1GIVEN) - RESTARGS) - then (PRINTOUT T "************" T) - (PRINTOUT T - "Illegal args to UFABS" %, - %, ORIGINAL T) - (PRINTOUT T "************" T)) - (LIST 'UFABS1 ARG1)) +(DEFOPTIMIZER UFABS (&OPTIONAL (ARG1 NIL ARG1GIVEN) + &REST RESTARGS &WHOLE ORIGINAL) + (if (OR (NOT ARG1GIVEN) + RESTARGS) + then (PRINTOUT T "************" T) + (PRINTOUT T "Illegal args to UFABS" %, %, ORIGINAL T) + (PRINTOUT T "************" T)) + (LIST 'UFABS1 ARG1)) +(DEFOPTIMIZER UFABS1 (X) + `[\FLOATBOX ((OPCODES UBFLOAT1 2) + (\FLOATUNBOX ,X]) -(DEFOPTIMIZER UFABS1 (X) `[\FLOATBOX ((OPCODES UBFLOAT1 2) - (\FLOATUNBOX ,X]) - - -(DEFOPTIMIZER UFEQP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) +(DEFOPTIMIZER UFEQP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) - &REST RESTARGS) (if (OR (NOT ARG1GIVEN) - (NOT ARG2GIVEN) - RESTARGS) - then (PRINTOUT T "************" T) - (PRINTOUT T "Illegal args to UFEQP" %, %, - ORIGINAL T) - (PRINTOUT T "************" T)) - (LIST 'UFEQP2 ARG1 ARG2)) + &REST RESTARGS) + (if (OR (NOT ARG1GIVEN) + (NOT ARG2GIVEN) + RESTARGS) + then (PRINTOUT T "************" T) + (PRINTOUT T "Illegal args to UFEQP" %, %, ORIGINAL T) + (PRINTOUT T "************" T)) + (LIST 'UFEQP2 ARG1 ARG2)) +(DEFOPTIMIZER UFEQP2 (X Y) + `(EQ (\FLOATUNBOX (FDIFFERENCE ,X ,Y)) + NIL)) -(DEFOPTIMIZER UFEQP2 (X Y) `(EQ (\FLOATUNBOX (FDIFFERENCE ,X ,Y)) - NIL)) - - -(DEFOPTIMIZER UFGEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) +(DEFOPTIMIZER UFGEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) - &REST RESTARGS) (if (OR (NOT ARG1GIVEN) - (NOT ARG2GIVEN) - RESTARGS) - then (PRINTOUT T "************" T) - (PRINTOUT T "Illegal args to UFGEQ" %, %, - ORIGINAL T) - (PRINTOUT T "************" T)) - (LIST 'UFGEQ2 ARG1 ARG2)) + &REST RESTARGS) + (if (OR (NOT ARG1GIVEN) + (NOT ARG2GIVEN) + RESTARGS) + then (PRINTOUT T "************" T) + (PRINTOUT T "Illegal args to UFGEQ" %, %, ORIGINAL T) + (PRINTOUT T "************" T)) + (LIST 'UFGEQ2 ARG1 ARG2)) +(DEFOPTIMIZER UFGEQ2 (X Y) + `[NOT ((OPCODES SWAP UBFLOAT2 5) + (\FLOATUNBOX ,X) + (\FLOATUNBOX ,Y]) -(DEFOPTIMIZER UFGEQ2 (X Y) `[NOT ((OPCODES SWAP UBFLOAT2 5) - (\FLOATUNBOX ,X) - (\FLOATUNBOX ,Y]) - - -(DEFOPTIMIZER UFGREATERP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) +(DEFOPTIMIZER UFGREATERP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) - &REST RESTARGS) (if (OR (NOT ARG1GIVEN) - (NOT ARG2GIVEN) - RESTARGS) - then (PRINTOUT T "************" T) - (PRINTOUT T "Illegal args to UFGREATERP" %, - %, ORIGINAL T) - (PRINTOUT T "************" T)) - (LIST 'UFGREATERP2 ARG1 ARG2)) + &REST RESTARGS) + (if (OR (NOT ARG1GIVEN) + (NOT ARG2GIVEN) + RESTARGS) + then (PRINTOUT T "************" T) + (PRINTOUT T "Illegal args to UFGREATERP" %, %, ORIGINAL T) + (PRINTOUT T "************" T)) + (LIST 'UFGREATERP2 ARG1 ARG2)) +(DEFOPTIMIZER UFGREATERP2 (X Y) + `((OPCODES UBFLOAT2 5) + (\FLOATUNBOX ,X) + (\FLOATUNBOX ,Y))) -(DEFOPTIMIZER UFGREATERP2 (X Y) `((OPCODES UBFLOAT2 5) - (\FLOATUNBOX ,X) - (\FLOATUNBOX ,Y))) +(DEFOPTIMIZER UFIX (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) + &REST RESTARGS) + (if (OR (NOT ARG1GIVEN) + RESTARGS) + then (PRINTOUT T "************" T) + (PRINTOUT T "Illegal args to UFIX" %, %, ORIGINAL T) + (PRINTOUT T "************" T)) + (LIST 'UFIX1 ARG1)) +(DEFOPTIMIZER UFIX1 (X) + `((OPCODES UBFLOAT1 4) + (\FLOATUNBOX ,X))) -(DEFOPTIMIZER UFIX (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) - &REST RESTARGS) (if (OR (NOT ARG1GIVEN) - RESTARGS) - then (PRINTOUT T "************" T) - (PRINTOUT T "Illegal args to UFIX" %, %, ORIGINAL - T) - (PRINTOUT T "************" T)) - (LIST 'UFIX1 ARG1)) - - -(DEFOPTIMIZER UFIX1 (X) `((OPCODES UBFLOAT1 4) - (\FLOATUNBOX ,X))) - - -(DEFOPTIMIZER UFLEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) +(DEFOPTIMIZER UFLEQ (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) - &REST RESTARGS) (if (OR (NOT ARG1GIVEN) - (NOT ARG2GIVEN) - RESTARGS) - then (PRINTOUT T "************" T) - (PRINTOUT T "Illegal args to UFLEQ" %, %, - ORIGINAL T) - (PRINTOUT T "************" T)) - (LIST 'UFLEQ2 ARG1 ARG2)) + &REST RESTARGS) + (if (OR (NOT ARG1GIVEN) + (NOT ARG2GIVEN) + RESTARGS) + then (PRINTOUT T "************" T) + (PRINTOUT T "Illegal args to UFLEQ" %, %, ORIGINAL T) + (PRINTOUT T "************" T)) + (LIST 'UFLEQ2 ARG1 ARG2)) +(DEFOPTIMIZER UFLEQ2 (X Y) + `[NOT ((OPCODES UBFLOAT2 5) + (\FLOATUNBOX ,X) + (\FLOATUNBOX ,Y]) -(DEFOPTIMIZER UFLEQ2 (X Y) `[NOT ((OPCODES UBFLOAT2 5) +(DEFOPTIMIZER UFLESSP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) + (ARG2 NIL ARG2GIVEN) + &REST RESTARGS) + (if (OR (NOT ARG1GIVEN) + (NOT ARG2GIVEN) + RESTARGS) + then (PRINTOUT T "************" T) + (PRINTOUT T "Illegal args to UFLESSP" %, %, ORIGINAL T) + (PRINTOUT T "************" T)) + (LIST 'UFLESSP2 ARG1 ARG2)) + +(DEFOPTIMIZER UFLESSP2 (X Y) + `((OPCODES SWAP UBFLOAT2 5) + (\FLOATUNBOX ,X) + (\FLOATUNBOX ,Y))) + +(DEFOPTIMIZER UFMAX (&OPTIONAL (ARG1 NIL ARG1GIVEN) + (ARG2 NIL ARG2GIVEN) + &REST RESTARGS) + (if (NOT ARG1GIVEN) + then 'MIN.FLOAT + elseif (NOT ARG2GIVEN) + then `(FLOAT %, ARG1) + elseif RESTARGS + then `(UFMAX (UFMAX2 %, ARG1 %, ARG2) + ., RESTARGS) + else (LIST 'UFMAX2 ARG1 ARG2))) + +(DEFOPTIMIZER UFMAX2 (X Y) + `[\FLOATBOX ((OPCODES UBFLOAT2 6) (\FLOATUNBOX ,X) (\FLOATUNBOX ,Y]) - -(DEFOPTIMIZER UFLESSP (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) - (ARG2 NIL ARG2GIVEN) - &REST RESTARGS) (if (OR (NOT ARG1GIVEN) - (NOT ARG2GIVEN) - RESTARGS) - then (PRINTOUT T "************" T) - (PRINTOUT T "Illegal args to UFLESSP" %, %, - ORIGINAL T) - (PRINTOUT T "************" T)) - (LIST 'UFLESSP2 ARG1 ARG2)) - - -(DEFOPTIMIZER UFLESSP2 (X Y) `((OPCODES SWAP UBFLOAT2 5) - (\FLOATUNBOX ,X) - (\FLOATUNBOX ,Y))) - - -(DEFOPTIMIZER UFMAX (&OPTIONAL (ARG1 NIL ARG1GIVEN) +(DEFOPTIMIZER UFMIN (&OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) - &REST RESTARGS) (if (NOT ARG1GIVEN) - then 'MIN.FLOAT - elseif (NOT ARG2GIVEN) - then `(FLOAT %, ARG1) - elseif RESTARGS - then `(UFMAX (UFMAX2 %, ARG1 %, ARG2) - ., RESTARGS) - else (LIST 'UFMAX2 ARG1 ARG2))) + &REST RESTARGS) + (if (NOT ARG1GIVEN) + then 'MAX.FLOAT + elseif (NOT ARG2GIVEN) + then `(FLOAT %, ARG1) + elseif RESTARGS + then `(UFMIN (UFMIN2 %, ARG1 %, ARG2) + ., RESTARGS) + else (LIST 'UFMIN2 ARG1 ARG2))) +(DEFOPTIMIZER UFMIN2 (X Y) + `[\FLOATBOX ((OPCODES UBFLOAT2 7) + (\FLOATUNBOX ,X) + (\FLOATUNBOX ,Y]) -(DEFOPTIMIZER UFMAX2 (X Y) `[\FLOATBOX ((OPCODES UBFLOAT2 6) - (\FLOATUNBOX ,X) - (\FLOATUNBOX ,Y]) +(DEFOPTIMIZER UFMINUS (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) + &REST RESTARGS) + (if (OR (NOT ARG1GIVEN) + RESTARGS) + then (PRINTOUT T "************" T) + (PRINTOUT T "Illegal args to UFMINUS" %, %, ORIGINAL T) + (PRINTOUT T "************" T)) + (LIST 'UFMINUS1 ARG1)) +(DEFOPTIMIZER UFMINUS1 (X) + `[\FLOATBOX ((OPCODES UBFLOAT1 3) + (\FLOATUNBOX ,X]) -(DEFOPTIMIZER UFMIN (&OPTIONAL (ARG1 NIL ARG1GIVEN) - (ARG2 NIL ARG2GIVEN) - &REST RESTARGS) (if (NOT ARG1GIVEN) - then 'MAX.FLOAT - elseif (NOT ARG2GIVEN) - then `(FLOAT %, ARG1) - elseif RESTARGS - then `(UFMIN (UFMIN2 %, ARG1 %, ARG2) - ., RESTARGS) - else (LIST 'UFMIN2 ARG1 ARG2))) +(DEFOPTIMIZER UFREMAINDER (X Y) + (CL:IF (AND (OR (CL:CONSTANTP X) + (CL:SYMBOLP X)) + (OR (CL:CONSTANTP Y) + (CL:SYMBOLP Y))) + `(FDIFFERENCE ,X (FTIMES [FLOAT (UFIX (FQUOTIENT ,X ,Y] + ,Y)) + 'COMPILER:PASS)) - -(DEFOPTIMIZER UFMIN2 (X Y) `[\FLOATBOX ((OPCODES UBFLOAT2 7) - (\FLOATUNBOX ,X) - (\FLOATUNBOX ,Y]) - - -(DEFOPTIMIZER UFMINUS (&WHOLE ORIGINAL &OPTIONAL (ARG1 NIL ARG1GIVEN) - &REST RESTARGS) (if (OR (NOT ARG1GIVEN) - RESTARGS) - then (PRINTOUT T "************" T) - (PRINTOUT T "Illegal args to UFMINUS" %, %, - ORIGINAL T) - (PRINTOUT T "************" T)) - (LIST 'UFMINUS1 ARG1)) - - -(DEFOPTIMIZER UFMINUS1 (X) `[\FLOATBOX ((OPCODES UBFLOAT1 3) - (\FLOATUNBOX ,X]) - - -(DEFOPTIMIZER UFREMAINDER (X Y) (CL:IF (AND (OR (CL:CONSTANTP X) - (CL:SYMBOLP X)) - (OR (CL:CONSTANTP Y) - (CL:SYMBOLP Y))) - `(FDIFFERENCE ,X (FTIMES [FLOAT (UFIX (FQUOTIENT ,X - ,Y] - ,Y)) - 'COMPILER:PASS)) - - -(PUTPROPS UNBOXEDOPS FILETYPE CL:COMPILE-FILE) +(PUTPROPS UNBOXEDOPS FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -267,9 +252,8 @@ Copyright (c) 1986 by Xerox Corporation. All rights reserved. (ADDTOVAR LAMA UFMIN UFMAX) ) -(PUTPROPS UNBOXEDOPS COPYRIGHT ("Xerox Corporation" 1986)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1185 3385 (UFABS 1195 . 1316) (UFEQP 1318 . 1441) (UFGEQ 1443 . 1565) (UFGREATERP 1567 - . 1700) (UFIX 1702 . 1821) (UFLEQ 1823 . 1945) (UFLESSP 1947 . 2074) (UFMAX 2076 . 2478) (UFMIN 2480 - . 2879) (UFMINUS 2881 . 3006) (UFREMAINDER 3008 . 3383))))) + (FILEMAP (NIL (983 3183 (UFABS 993 . 1114) (UFEQP 1116 . 1239) (UFGEQ 1241 . 1363) (UFGREATERP 1365 . +1498) (UFIX 1500 . 1619) (UFLEQ 1621 . 1743) (UFLESSP 1745 . 1872) (UFMAX 1874 . 2276) (UFMIN 2278 . +2677) (UFMINUS 2679 . 2804) (UFREMAINDER 2806 . 3181))))) STOP diff --git a/lispusers/UNBOXEDOPS.DFASL b/lispusers/UNBOXEDOPS.DFASL new file mode 100644 index 00000000..97415849 Binary files /dev/null and b/lispusers/UNBOXEDOPS.DFASL differ diff --git a/lispusers/VERSIONDEFS b/lispusers/VERSIONDEFS index 97896c14..9920f955 100644 --- a/lispusers/VERSIONDEFS +++ b/lispusers/VERSIONDEFS @@ -1,22 +1,21 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8) -(FILECREATED "27-Jan-2025 08:49:34" {WMEDLEY}VERSIONDEFS.;12 5880 +(FILECREATED " 7-Mar-2026 22:55:43" {WMEDLEY}VERSIONDEFS.;18 6534 :EDIT-BY rmk - :CHANGES-TO (FNS GETVINFO) - - :PREVIOUS-DATE "12-Dec-2024 15:07:45" {WMEDLEY}VERSIONDEFS.;11) + :PREVIOUS-DATE " 6-Mar-2026 22:47:25" {WMEDLEY}VERSIONDEFS.;17) (PRETTYCOMPRINT VERSIONDEFSCOMS) -(RPAQQ VERSIONDEFSCOMS [(FNS FINDFILEVERSION GETVINFO VERSIONP) - (FNS EDV DFV) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - (ADDVARS (NLAMA DFV EDV) - (NLAML) - (LAMA]) +(RPAQQ VERSIONDEFSCOMS + [(FNS FINDFILEVERSION GETVINFO VERSIONP) + (FNS EDV DFV) + (PROP ARGNAMES EDV DFV) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DFV EDV) + (NLAML) + (LAMA]) (DEFINEQ (FINDFILEVERSION @@ -119,16 +118,26 @@ (CAR VINFO]) (DFV - [NLAMBDA ARGS (* ; "Edited 6-Dec-2024 21:29 by rmk") + [NLAMBDA ARGS (* ; "Edited 6-Mar-2026 22:42 by rmk") + (* ; "Edited 6-Dec-2024 21:29 by rmk") (* ; "Edited 2-Dec-2024 00:08 by rmk") (SETQ ARGS (MKLIST ARGS)) - (APPLY (FUNCTION EDV) - (LIST (POP ARGS) - NIL - (POP ARGS) - (POP ARGS) - (POP ARGS]) + (LET ((NAME (POP ARGS))) (* ; "If FNS and FUNCTIONS, show both") + (CL:WHEN (HASDEF NAME 'FUNCTIONS '?) + (APPLY (FUNCTION EDV) + (LIST NAME 'FUNCTIONS (POP ARGS) + (POP ARGS) + (POP ARGS)))) + (CL:WHEN (HASDEF NAME 'FNS '?) + (APPLY (FUNCTION EDV) + (LIST NAME 'FNS (POP ARGS) + (POP ARGS) + (POP ARGS))))]) ) + +(PUTPROPS EDV ARGNAMES (NAME TYPE FILE VERSION DIRLST . VINFO)) + +(PUTPROPS DFV ARGNAMES (NAME FILE VERSION DIRLST . VINFO)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DFV EDV) @@ -138,6 +147,6 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (671 4570 (FINDFILEVERSION 681 . 2128) (GETVINFO 2130 . 4253) (VERSIONP 4255 . 4568)) ( -4571 5717 (EDV 4581 . 5281) (DFV 5283 . 5715))))) + (FILEMAP (NIL (706 4605 (FINDFILEVERSION 716 . 2163) (GETVINFO 2165 . 4288) (VERSIONP 4290 . 4603)) ( +4606 6230 (EDV 4616 . 5316) (DFV 5318 . 6228))))) STOP diff --git a/lispusers/VERSIONDEFS.LCOM b/lispusers/VERSIONDEFS.LCOM index 36259932..3914a5c6 100644 Binary files a/lispusers/VERSIONDEFS.LCOM and b/lispusers/VERSIONDEFS.LCOM differ diff --git a/lispusers/VERSIONDEFS.TEDIT b/lispusers/VERSIONDEFS.TEDIT index f869387e..7b67a98f 100644 Binary files a/lispusers/VERSIONDEFS.TEDIT and b/lispusers/VERSIONDEFS.TEDIT differ diff --git a/lispusers/WHOCALLS b/lispusers/WHOCALLS index b6be7cc9..e7526e7b 100644 --- a/lispusers/WHOCALLS +++ b/lispusers/WHOCALLS @@ -1,19 +1,17 @@ -(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "XCL" §BASE 10) -(filecreated "18-Dec-86 19:03:25" {eris}internal>library>whocalls.\;2 4500 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) - |changes| |to:| (fns distribute.callinfo distribute-call-info-for-symbol) - (vars whocallscoms) +(FILECREATED "18-Feb-2026 16:08:45" |{WMEDLEY}WHOCALLS.;2| 4272 - |previous| |date:| " 7-Nov-86 02:47:11" {eris}lispcore>whocalls.\;2) + :EDIT-BY |rmk| + + :PREVIOUS-DATE "18-Dec-86 19:03:25" |{WMEDLEY}WHOCALLS.;1|) -; Copyright (c) 1986 by Xerox Corporation. All rights reserved. +(PRETTYCOMPRINT WHOCALLSCOMS) -(prettycomprint whocallscoms) - -(rpaqq whocallscoms ((fns whocalls whocalls1 distribute.callinfo distribute-call-info-for-symbol) - (prop proptype calledby usedfreeby usedglobalby boundby))) -(defineq +(RPAQQ WHOCALLSCOMS ((FNS WHOCALLS WHOCALLS1 DISTRIBUTE.CALLINFO DISTRIBUTE-CALL-INFO-FOR-SYMBOL) + (PROP PROPTYPE CALLEDBY USEDFREEBY USEDGLOBALBY BOUNDBY))) +(DEFINEQ (WHOCALLS (LAMBDA (CALLEE USAGE) @@ -78,15 +76,14 @@ x)))))) ) -(putprops calledby proptype ignore) +(PUTPROPS CALLEDBY PROPTYPE IGNORE) -(putprops usedfreeby proptype ignore) +(PUTPROPS USEDFREEBY PROPTYPE IGNORE) -(putprops usedglobalby proptype ignore) +(PUTPROPS USEDGLOBALBY PROPTYPE IGNORE) -(putprops boundby proptype ignore) -(putprops whocalls copyright ("Xerox Corporation" 1986)) -(declare\: dontcopy - (filemap (nil (653 4251 (whocalls 663 . 2057) (whocalls1 2059 . 3191) (distribute.callinfo 3193 . 3419 -) (distribute-call-info-for-symbol 3421 . 4249))))) -stop +(PUTPROPS BOUNDBY PROPTYPE IGNORE) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (466 4064 (WHOCALLS 476 . 1870) (WHOCALLS1 1872 . 3004) (DISTRIBUTE.CALLINFO 3006 . 3232 +) (DISTRIBUTE-CALL-INFO-FOR-SYMBOL 3234 . 4062))))) +STOP diff --git a/lispusers/WHOCALLS.LCOM b/lispusers/WHOCALLS.LCOM index c867c896..a04c53ad 100644 Binary files a/lispusers/WHOCALLS.LCOM and b/lispusers/WHOCALLS.LCOM differ diff --git a/lispusers/compilebang b/lispusers/compilebang index 53128e12..943b97f0 100644 --- a/lispusers/compilebang +++ b/lispusers/compilebang @@ -1,14 +1,11 @@ -(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) -(FILECREATED "22-Dec-86 18:42:34" {ERIS}LISPCORE>COMPILEBANG.;3 3465 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - changes to%: (FNS COMPILE!) +(FILECREATED "18-Feb-2026 16:23:37" {WMEDLEY}compilebang.;2 3232 - previous date%: "18-Nov-86 22:23:43" {ERIS}LISPCORE>COMPILEBANG.;2) + :EDIT-BY rmk + :PREVIOUS-DATE "22-Dec-86 18:42:34" {WMEDLEY}compilebang.;1) -(* " -Copyright (c) 1982, 1983, 1984, 1986 by Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT COMPILEBANGCOMS) @@ -63,23 +60,22 @@ Copyright (c) 1982, 1983, 1984, 1986 by Xerox Corporation. All rights reserved. NIL NIL T)) (T C)))) -(ADDTOVAR USERMACROS [C NIL (ORR (UP 1) - NIL) - (ORR ((E (COMPILE! (OR (LISTP (%##)) - (%## !0)) - T T T))) - ((E 'C?]) +(ADDTOVAR USERMACROS + [C NIL (ORR (UP 1) + NIL) + (ORR ((E (COMPILE! (OR (LISTP (%##)) + (%## !0)) + T T T))) + ((E 'C?]) (ADDTOVAR EDITCOMSA C) -(DEFCOMMAND (C :EVAL) (&REST LISPXLINE) (COND - (LISPXLINE (COMPILE! (CAR LISPXLINE) +(DEFCOMMAND (C :EVAL) (&REST LISPXLINE) (COND + (LISPXLINE (COMPILE! (CAR LISPXLINE) NIL NIL T)) (T C))) - -(PUTPROPS COMPILEBANG FILETYPE CL:COMPILE-FILE) -(PUTPROPS COMPILEBANG COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1986)) +(PUTPROPS COMPILEBANG FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTCOPY - (FILEMAP (NIL (622 2567 (COMPILE! 632 . 2565))))) + (FILEMAP (NIL (506 2451 (COMPILE! 516 . 2449))))) STOP diff --git a/obsolete/clos/2.0/CLOS-BROWSER.TEDIT.Z b/obsolete/clos/2.0/CLOS-BROWSER.TEDIT.Z deleted file mode 100644 index 337dd792..00000000 Binary files a/obsolete/clos/2.0/CLOS-BROWSER.TEDIT.Z and /dev/null differ diff --git a/obsolete/clos/2.0/NEW-CLOS-BROWSER b/obsolete/clos/2.0/NEW-CLOS-BROWSER deleted file mode 100644 index fbc4c912..00000000 --- a/obsolete/clos/2.0/NEW-CLOS-BROWSER +++ /dev/null @@ -1,1634 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (CLIN-PACKAGE "CLOS-BROWSER") (CLUSE-PACKAGE "CLOS") ( -CLFIND-PACKAGE "USER")) READTABLE "XCL" BASE 10) -(IL:FILECREATED " 4-Dec-91 12:16:19"  -IL:|{DSK}local>users>welch>lisp>clos>browser>NEW-CLOS-BROWSER.;22| 91732 - - IL:|previous| IL:|date:| "19-Nov-91 14:14:15" -IL:|{DSK}local>users>welch>lisp>clos>browser>NEW-CLOS-BROWSER.;21|) - - -; Copyright (c) 1991 by Venue. All rights reserved. - -(IL:PRETTYCOMPRINT IL:NEW-CLOS-BROWSERCOMS) - -(IL:RPAQQ IL:NEW-CLOS-BROWSERCOMS - ( - -(IL:* IL:|;;;| "***************************************") - - - -(IL:* IL:|;;;| "") - - - -(IL:* IL:|;;;| "Print out a copyright notice when loading") - - - (IL:* IL:|;;| "") - - (IL:P (FORMAT T - "~&;CLOS-BROWSER Copyright (c) 1991 VENUE Corporation. All rights reserved.~%" - )) - - -(IL:* IL:|;;;| "LOAD DEPENDENT MODULES") - - - (IL:* IL:|;;| "Note: before compiling clos-browser:") - - - (IL:* IL:|;;| " (load 'web-editor.dfasl)") - - - (IL:* IL:|;;| " (load 'clos-browser.dfasl)") - - - (IL:* IL:|;;| " (load 'clos-browser 'prop)") - - - (IL:* IL:|;;| "") - - - -(IL:* IL:|;;;| "PACKAGE STUFF ") - - (IL:PROPS (IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT) - (IL:NEW-CLOS-BROWSER IL:FILETYPE)) - - (IL:* IL:|;;| "(IL:P IL:* USER::CLOS-BROWSER-PACKAGE-COMMANDS)") - - - (IL:* IL:|;;| "") - - - -(IL:* IL:|;;;| "SYSTEM PATCHES") - - - (IL:* IL:|;;| "") - - - (IL:* IL:|;;| "") - - - (IL:* IL:|;;| "") - - - -(IL:* IL:|;;;| "CLOS-ICON CLASS & INSTANCE INITIALIZATION") - - (CLOS::CLASSES CLOS-BROWSER:CLOS-ICON) - (IL:VARIABLES CLOS-BROWSER:CLOS-ICON) - - (IL:* IL:|;;| "") - - - -(IL:* IL:|;;;| "CLOS-BROWSER CLASS") - - (IL:FUNCTIONS CLOS-BROWSER:BROWSE-CLASS CLOS-BROWSER::COLLECT-FAMILY - CLOS-BROWSER::MAKE-NODES CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN - CLOS-BROWSER::BROWSER-CONTAINS-P) - (CLOS::CLASSES CLOS-BROWSER::CLOS-BROWSER) - (CLOS::METHODS (CLOS-BROWSER::ADD-ROOT (CLOS-BROWSER::CLOS-BROWSER)) - (CLOS-BROWSER::ADD-ROOTS (CLOS-BROWSER::CLOS-BROWSER)) - (WEB:BOX-NODE (CLOS-BROWSER::CLOS-BROWSER)) - (WEB:BROWSE (CLOS-BROWSER::CLOS-BROWSER)) - (CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES (CLOS-BROWSER::CLOS-BROWSER)) - (WEB:ICON-TITLE (CLOS-BROWSER::CLOS-BROWSER)) - (WEB:INITIALIZE-EDITOR (CLOS-BROWSER::CLOS-BROWSER)) - (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER::CLOS-BROWSER)) - (WEB:RECOMPUTE (CLOS-BROWSER::CLOS-BROWSER)) - (CLOS-BROWSER::REAL-ADD-ROOT (CLOS-BROWSER::CLOS-BROWSER)) - (WEB:SHAPE-TO-HOLD (CLOS-BROWSER::CLOS-BROWSER)) - (IL:* IL:\; "multi-method") - (CLOS-BROWSER::SUBCLASSES-OF NIL) - (CLOS-BROWSER::CONTAINS-P (T CLOS-BROWSER::CLOS-BROWSER))) - - (IL:* IL:|;;| "") - - - -(IL:* IL:|;;;| "CLOS-BROWSER-NODE CLASS") - - (CLOS::CLASSES CLOS-BROWSER::CLOS-BROWSER-NODE) - (CLOS::METHODS (CLOS-BROWSER::OBJECT-NAME (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::OVERRIDE (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::CACHE (T CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::UNCACHE (CLOS-BROWSER::CLOS-BROWSER-NODE))) - (IL:VARS (CLOS-BROWSER::*METHOD-PROMPT-STRING* (CONCATENATE 'STRING - "Left button to edit the method." - " -" "Middle button provides a menu of operations."))) - (IL:FUNCTIONS CLOS-BROWSER::EDIT CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS - CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS - CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU) - - (IL:* IL:|;;| "") - - - (IL:* IL:|;;| "OPERATORS (via CLOS-BROWSER-NODE) ON CLOS::STANDARD-CLASS") - - (CLOS::METHODS (CLOS-BROWSER:ADD-BROWSER-METHOD (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::BROWSE-SUBS (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::EDIT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::INSPECT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::MENU-METHODS (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::MAKE-WHENSELECTEDFN (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::DESCRIBE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::DOCUMENTATION-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::PRINT-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER::SPECIALIZE-CLASS (CLOS-BROWSER::CLOS-BROWSER-NODE))) - (IL:FUNCTIONS CLOS-BROWSER::COMPLETE-ADD-METHOD CLOS-BROWSER::COMPLETE-SPECIALIZE - CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE CLOS-BROWSER::THIS-CLASS-NODE-P - CLOS::CLASS-DIRECT-METHODS) - - (IL:* IL:|;;| "") - - - (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-CLASS (directly)") - - (CLOS::METHODS (CLOS::COMPUTE-INHERITED-METHODS (STANDARD-CLASS)) - (CLOS-BROWSER::SPECIALIZE (STANDARD-CLASS)) - (CLOS-BROWSER::SUBCLASSES-OF (STANDARD-CLASS))) - - (IL:* IL:|;;| "") - - - (IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-METHOD") - - (CLOS::METHODS (CLOS-BROWSER::DELETE-METHOD (STANDARD-METHOD)) - (CLOS-BROWSER::COPY (STANDARD-METHOD STANDARD-CLASS)) - (CLOS-BROWSER::MOVE (STANDARD-METHOD STANDARD-CLASS)) - (IL:* IL:\; - "web:move is shadowed above") - (CLOS-BROWSER::PRINT-DEFINITION (STANDARD-METHOD)) - (CLOS-BROWSER::DESCRIBE-METHOD (CLOS::METHOD)) - (CLOS-BROWSER::RENAME (STANDARD-METHOD)) - (CLOS-BROWSER::UPDATE-CACHED-MENUES (STANDARD-METHOD)) - (CLOS-BROWSER::WHO-OWNS (STANDARD-METHOD)) - - (IL:* IL:|;;| - "update-cached-menues must appear before add-method :after in the coms") - - (ADD-METHOD :AFTER (STANDARD-GENERIC-FUNCTION STANDARD-METHOD))) - (IL:FUNCTIONS CLOS-BROWSER::REPLACE-SPECIALIZERS) - - (IL:* IL:|;;| "") - - - -(IL:* IL:|;;;| "SETUP RELEASE INFO") - - (IL:VARS (CLOS-BROWSER::RELEASE-ID "0.02") - (CLOS-BROWSER::SYSTEM-DATE (CAAR (IL:GETPROP 'IL:CLOS-BROWSER 'IL:FILEDATES)))) - - (IL:* IL:|;;| "") - - - (IL:* IL:|;;| "") - - - (IL:* IL:|;;| "SETUP BACKGROUND MENU") - - (IL:FUNCTIONS CLOS-BROWSER::IN-SELECT-PACKAGE CLOS-BROWSER::CLASSES-IN-PACKAGE) - (IL:P - (IL:* IL:|;;| "pushnew should eliminate this") - - (SETQ IL:|BackgroundMenuCommands| (REMOVE 'IL:|BrowseClass| - IL:|BackgroundMenuCommands| :KEY - #'CAR)) - (PUSH '(IL:|BrowseClass| (CLOS-BROWSER:BROWSE-CLASS) - "Bring up a class browser." - (IL:SUBITEMS (IL:|all in a package| (CLOS-BROWSER:BROWSE-CLASS - (CLOS-BROWSER::CLASSES-IN-PACKAGE - (CLOS-BROWSER::IN-SELECT-PACKAGE - ))) - - "Select a package and browse all the classes defined in that package." - ))) - IL:|BackgroundMenuCommands|) - (SETQ IL:|BackgroundMenu| NIL)))) - - - -(IL:* IL:|;;;| "***************************************") - - - - -(IL:* IL:|;;;| "") - - - - -(IL:* IL:|;;;| "Print out a copyright notice when loading") - - - - -(IL:* IL:|;;| "") - - -(FORMAT T "~&;CLOS-BROWSER Copyright (c) 1991 VENUE Corporation. All rights reserved.~%") - - - -(IL:* IL:|;;;| "LOAD DEPENDENT MODULES") - - - - -(IL:* IL:|;;| "Note: before compiling clos-browser:") - - - - -(IL:* IL:|;;| " (load 'web-editor.dfasl)") - - - - -(IL:* IL:|;;| " (load 'clos-browser.dfasl)") - - - - -(IL:* IL:|;;| " (load 'clos-browser 'prop)") - - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;;| "PACKAGE STUFF ") - - -(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:MAKEFILE-ENVIRONMENT (:PACKAGE (LET ((*PACKAGE*)) - (IN-PACKAGE - "CLOS-BROWSER") - (USE-PACKAGE "CLOS") - (FIND-PACKAGE "USER")) - :READTABLE "XCL" :BASE 10)) - -(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:FILETYPE :COMPILE-FILE) - - - -(IL:* IL:|;;| "(IL:P IL:* USER::CLOS-BROWSER-PACKAGE-COMMANDS)") - - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;;| "SYSTEM PATCHES") - - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;;| "CLOS-ICON CLASS & INSTANCE INITIALIZATION") - - -(DEFCLASS CLOS-BROWSER:CLOS-ICON (STANDARD-OBJECT) - ((CLOS-BROWSER::CLASS-BROWSERS :ALLOCATION :CLASS :INITFORM NIL) - (IL:* IL:\; - "list of all open browsers") - (CLOS-BROWSER::DESTINATION-BROWSER :ALLOCATION :CLASS :INITFORM NIL) - (IL:* IL:\; - "browser containing boxed node") - (CLOS-BROWSER::MENU-CACHE-SWITCH :ALLOCATION :CLASS :INITFORM :LAZY - - (IL:* IL:|;;| "valid values:") - - (IL:* IL:|;;| ":none for never use cache") - - (IL:* IL:|;;| ":lazy for invalidate cache at method create or remove time causing re-compute and cache at menu request time.") - - (IL:* IL:|;;| - ":eager (not implemented) for re-compute and cache menu whenever a method is created or removed") - - ))) - -(XCL:DEFGLOBALPARAMETER CLOS-BROWSER:CLOS-ICON (MAKE-INSTANCE 'CLOS-BROWSER:CLOS-ICON)) - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;;| "CLOS-BROWSER CLASS") - - -(DEFUN CLOS-BROWSER:BROWSE-CLASS (&OPTIONAL CLOS-BROWSER::CLASS-NAME-OR-LIST &KEY ( - CLOS-BROWSER::DIRECTION - :SUB) - (CLOS-BROWSER::WINDOW-OR-TITLE "CLOS-browser") - CLOS-BROWSER::GOOD-CLASSES POSITION) - (LET* ((CLOS-BROWSER::ROOT-CLASSES (WHEN CLOS-BROWSER::CLASS-NAME-OR-LIST - (IF (LISTP CLOS-BROWSER::CLASS-NAME-OR-LIST) - (MAPCAR #'FIND-CLASS CLOS-BROWSER::CLASS-NAME-OR-LIST) - (CONS (FIND-CLASS CLOS-BROWSER::CLASS-NAME-OR-LIST))))) - (CLOS-BROWSER::NODES (CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::COLLECT-FAMILY NIL - CLOS-BROWSER::ROOT-CLASSES))) - (CLOS-BROWSER::CLOS-BROWSER (MAKE-INSTANCE 'CLOS-BROWSER::CLOS-BROWSER))) - (WEB:INITIALIZE-EDITOR CLOS-BROWSER::CLOS-BROWSER) - (SETF (SLOT-VALUE CLOS-BROWSER::CLOS-BROWSER 'CLOS-BROWSER::ROOT-CLASSES) - CLOS-BROWSER::ROOT-CLASSES) - (SETF (SLOT-VALUE CLOS-BROWSER::CLOS-BROWSER 'CLOS-BROWSER::TITLE) - CLOS-BROWSER::CLASS-NAME-OR-LIST) - (WEB:BROWSE CLOS-BROWSER::CLOS-BROWSER CLOS-BROWSER::NODES CLOS-BROWSER::WINDOW-OR-TITLE - CLOS-BROWSER::GOOD-CLASSES POSITION) - (UNLESS CLOS-BROWSER::NODES (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::CLOS-BROWSER)) - CLOS-BROWSER::CLOS-BROWSER)) - -(DEFUN CLOS-BROWSER::COLLECT-FAMILY (CLOS-BROWSER::FAMILY CLOS-BROWSER::CLASS-LIST) - "gather all of the sub-classes of the class passed as family" - - (IL:* IL:|;;| "for efficiency, to avoid gathering and filtering subclasses more than once, we assume family only contains classes whose family has already been gathered.") - - (IF CLOS-BROWSER::CLASS-LIST - (LET ((CLOS-BROWSER::FIRST-CLASS (CAR CLOS-BROWSER::CLASS-LIST)) - (REST (CDR CLOS-BROWSER::CLASS-LIST))) - (IF (MEMBER CLOS-BROWSER::FIRST-CLASS CLOS-BROWSER::FAMILY) - (PROGN - (IL:* IL:|;;| "skip gathering class-direct-subclasses ") - - (CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::FAMILY REST)) - (PROGN (PUSH CLOS-BROWSER::FIRST-CLASS CLOS-BROWSER::FAMILY) - (CLOS-BROWSER::COLLECT-FAMILY CLOS-BROWSER::FAMILY (APPEND REST - ( - CLOS::CLASS-DIRECT-SUBCLASSES - - CLOS-BROWSER::FIRST-CLASS - )))))) - CLOS-BROWSER::FAMILY)) - -(DEFUN CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::CLASS-LIST) - (LET* ((CLOS-BROWSER::NODE-HASH (MAKE-HASH-TABLE)) - (CLOS-BROWSER::NODE-LIST (MAP 'LIST #'(LAMBDA (CLOS-BROWSER::CLASS - &AUX - (CLOS-BROWSER::NODE (MAKE-INSTANCE - - ' - CLOS-BROWSER::CLOS-BROWSER-NODE - ))) - (SETF (SLOT-VALUE CLOS-BROWSER::NODE - 'CLOS-BROWSER::CLASS) - CLOS-BROWSER::CLASS) - (SETF (WEB:NODE-NAME CLOS-BROWSER::NODE) - (CLASS-NAME CLOS-BROWSER::CLASS)) - (SETF (GETHASH CLOS-BROWSER::CLASS - CLOS-BROWSER::NODE-HASH) - CLOS-BROWSER::NODE) - CLOS-BROWSER::NODE) - CLOS-BROWSER::CLASS-LIST))) - (DOLIST (CLOS-BROWSER::NODE CLOS-BROWSER::NODE-LIST) - (SETF (WEB:NODE-LINKS CLOS-BROWSER::NODE) - (MAP 'LIST #'(LAMBDA (CLOS-BROWSER::SUB) - (GETHASH CLOS-BROWSER::SUB CLOS-BROWSER::NODE-HASH)) - (CLOS::CLASS-DIRECT-SUBCLASSES (SLOT-VALUE CLOS-BROWSER::NODE - 'CLOS-BROWSER::CLASS))))) - CLOS-BROWSER::NODE-LIST)) - -(DEFUN CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN (CLOS-BROWSER::WINDOW) - (LET ((CLOS-BROWSER::BROWSER (IL:WINDOWPROP CLOS-BROWSER::WINDOW 'WEB:WEB-EDITOR))) - (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS) - (REMOVE CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::CLASS-BROWSERS))) - (WHEN (EQ CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::DESTINATION-BROWSER)) - (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) - NIL)))) - -(DEFUN CLOS-BROWSER::BROWSER-CONTAINS-P (CLOS-BROWSER::CLASS CLOS-BROWSER::BROWSER) - "created because too slow to call contains-p method inside a tight loop" - (LET ((CLOS-BROWSER::NODE (CAR (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER - 'WEB::STARTING-LIST) - :TEST - #'CLOS-BROWSER::THIS-CLASS-NODE-P)))) - (WHEN (AND CLOS-BROWSER::NODE (NOT (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE - CLOS-BROWSER::BROWSER - 'WEB::BAD-LIST) - :TEST - #'CLOS-BROWSER::THIS-CLASS-NODE-P))) - CLOS-BROWSER::NODE))) - -(DEFCLASS CLOS-BROWSER::CLOS-BROWSER (WEB:WEB-EDITOR) - ((CLOS-BROWSER::ROOT-CLASSES) - (WEB:TITLE-ITEMS :ALLOCATION :INSTANCE - - (IL:* IL:|;;| "Items for menu of selections in title of window") - - :INITFORM - '(("Recompute" WEB:RECOMPUTE "Recompute lattice from starting objects" - (IL:SUBITEMS ("Recompute" WEB:RECOMPUTE - "Recompute lattice from starting objects") - ("Recompute labels" WEB:RECOMPUTE-LABELS "Recomputes the labels") - ("Recompute in place" WEB:RECOMPUTE-IN-PLACE - "Recompute keeping current view in window") - ("Clear caches" CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES - "Clear cached menues of methods."))) - ("Browser looks" NIL "" (IL:SUBITEMS ("Shape to hold" WEB:SHAPE-TO-HOLD - "Make window large or small enough to just hold graph" - ) - ("Change font size" WEB:CHANGE-FONT-SIZE - "Choose a new size Font") - ("Change format" WEB:CHANGE-FORMAT - "Change format between lattice and tree"))) - ("Add root " CLOS-BROWSER::ADD-ROOT "Add named item to startingList for browser." - (IL:SUBITEMS ("all in a package" CLOS-BROWSER::ADD-ROOTS - "Add all the classes in a package to this browser."))) - - (IL:* IL:|;;| - "(\"Unhide class\" remove-from-bad-list \"Restore item previously deleted from browser\")") - - )) - (WEB:LEFT-BUTTON-ITEMS :ALLOCATION :CLASS - - (IL:* IL:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see local-commands") - - :INITFORM - 'WEB:BOX-NODE) - (WEB:MIDDLE-BUTTON-ITEMS :ALLOCATION :INSTANCE - - (IL:* IL:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see local-commands") - - :INITFORM - '(("Edit" CLOS-BROWSER::EDIT-CLASS "Edit the class." (IL:SUBITEMS ("Edit" - CLOS-BROWSER::EDIT-CLASS - - "Edit the class." - ) - ("Inspect" - CLOS-BROWSER::INSPECT-CLASS - - "Bring up an inspector on the class." - ))) - ("Add method" CLOS-BROWSER:ADD-BROWSER-METHOD "Add a method to the class.") - ("Browse" CLOS-BROWSER::BROWSE-SUBS "Bring up a browser on this class." - (WHEN NIL (IL:* IL:\; - "superclasses not implemented") - (IL:SUBITEMS ("sub classes" CLOS-BROWSER::BROWSE-SUBS - "Bring up a browser on this class.") - ("super classes" CLOS-BROWSER::BROWSE-SUPERS "Not Implemented")))) - ("Print" CLOS-BROWSER::PRINT-CLASS "Print the form defining the class." - (IL:SUBITEMS ("Print" CLOS-BROWSER::PRINT-CLASS - "Print the form defining the class.") - ("Describe" CLOS-BROWSER::DESCRIBE-CLASS - "Print a description of the class.") - ("Documentation" CLOS-BROWSER::DOCUMENTATION-CLASS - "Display the documentation for the class."))) - ("Specialize" CLOS-BROWSER::SPECIALIZE-CLASS "Create a new sub-class of this class.") - ("------" CLOS-BROWSER::EDIT-CLASS - "Above this line operates on the class. -Below this line operates on individual slots and methods.") - ("slots" CLOS-BROWSER::EDIT-CLASS "Edit the defclass definition.") - ("methods" (CLOS-BROWSER::MENU-METHODS) - "Build a menu of methods local to this class." - (IL:SUBITEMS ("local" (CLOS-BROWSER::MENU-METHODS) - "Show a menu of methods specialized on this class.." - (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS) - "Do not recompute the menu of methods") - ("Recompute menu" (CLOS-BROWSER::MENU-METHODS NIL NIL - NIL T) - "Recompute the menu of methods"))) - ("inherited" (CLOS-BROWSER::MENU-METHODS :INHERITED) - "Show only methods inherited by this class." - (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS - :INHERITED) - "Do not recompute the menu of methods") - ("Recompute menu" (CLOS-BROWSER::MENU-METHODS :INHERITED - NIL NIL T) - "Recompute the menu of methods"))) - ("all" (CLOS-BROWSER::MENU-METHODS :ALL) - "Show all methods understood by this class." - (IL:SUBITEMS ("Use cached menu" (CLOS-BROWSER::MENU-METHODS :ALL) - "Do not recompute the menu of methods") - ("Recompute menu" (CLOS-BROWSER::MENU-METHODS :ALL NIL NIL - T) - "Recompute the menu of methods"))))))) - (CLOS-BROWSER::TITLE :INITFORM "CLOS Browser" (IL:* IL:\; - "Title passed to GRAPHER package")))) - -(DEFMETHOD CLOS-BROWSER::ADD-ROOT ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER) - &OPTIONAL - (CLOS-BROWSER::NEW-ITEM (CLOS-BROWSER::NEW-ITEM - CLOS-BROWSER::BROWSER))) - "Add a named item to the starting list of the browser " - (IF (CLOS-BROWSER::REAL-ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::NEW-ITEM) - (WEB:RECOMPUTE CLOS-BROWSER::BROWSER) - - (IL:* IL:|;;| "otherwise warn the user") - - (WEB:PROMPT-PRINT CLOS-BROWSER::BROWSER (FORMAT NIL "~A not added to browser." - CLOS-BROWSER::NEW-ITEM)))) - -(DEFMETHOD CLOS-BROWSER::ADD-ROOTS ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER) - &OPTIONAL - (CLOS-BROWSER::NEW-ITEMS (CLOS-BROWSER::CLASSES-IN-PACKAGE - (CLOS-BROWSER::IN-SELECT-PACKAGE - )))) - "Add all classes in a package to the starting list of the browser" - (DOLIST (CLOS-BROWSER::CLASS CLOS-BROWSER::NEW-ITEMS) - (UNLESS (CLOS-BROWSER::REAL-ADD-ROOT CLOS-BROWSER::BROWSER CLOS-BROWSER::CLASS) - (WEB:PROMPT-PRINT CLOS-BROWSER::BROWSER (FORMAT NIL "~A not added to browser." - CLOS-BROWSER::CLASS)))) - (WEB:RECOMPUTE CLOS-BROWSER::BROWSER)) - -(DEFMETHOD WEB:BOX-NODE ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER) - CLOS-BROWSER::OBJECT &OPTIONAL CLOS-BROWSER::KEEP-PREVIOUS-BOX) - (CALL-NEXT-METHOD) - (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) - CLOS-BROWSER::BROWSER)) - -(DEFMETHOD WEB:BROWSE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER) - &OPTIONAL CLOS-BROWSER::BROWSE-LIST CLOS-BROWSER::WINDOW-OR-TITLE - CLOS-BROWSER::GOOD-LIST POSITION) - (LET ((CLOS-BROWSER::BROWSER (CALL-NEXT-METHOD))) - (PUSHNEW CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::CLASS-BROWSERS)))) - -(DEFMETHOD CLOS-BROWSER::CLEAR-METHOD-MENU-CACHES ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER - )) - (DOLIST (CLOS-BROWSER::NODE (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST - (IL:* IL:\; - "starting-list is really all the nodes in the browser.") - )) - (SETF (SLOT-VALUE CLOS-BROWSER::NODE WEB::MENU-CACHE) - NIL))) - -(DEFMETHOD WEB:ICON-TITLE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER)) - (WEB:NODE-NAME (CAR (LAST (SLOT-VALUE CLOS-BROWSER::SELF `WEB::STARTING-LIST))))) - -(DEFMETHOD WEB:INITIALIZE-EDITOR ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)) - "initialize and setup closefn" - (CALL-NEXT-METHOD) - (PUSHNEW CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::CLASS-BROWSERS)) - (LET ((CLOS-BROWSER::WINDOW (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::WINDOW))) - (IL:WINDOWADDPROP CLOS-BROWSER::WINDOW 'IL:CLOSEFN 'CLOS-BROWSER::CLOS-BROWSER-CLOSE-FN T)) - CLOS-BROWSER::BROWSER) - -(DEFMETHOD CLOS-BROWSER::NEW-ITEM ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER) - &OPTIONAL CLOS-BROWSER::NEW-ITEM) - (UNLESS CLOS-BROWSER::NEW-ITEM - (SETQ CLOS-BROWSER::NEW-ITEM (WEB:PROMPT-READ CLOS-BROWSER::SELF "Class")))) - -(DEFMETHOD WEB:RECOMPUTE ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER) - &OPTIONAL CLOS-BROWSER::DONT-RESHAPE-FLG) - - (IL:* IL:|;;| "this should be moved to a more intelligent recompute-nodes function that does not have to re-build every single node.") - - (SETF (SLOT-VALUE CLOS-BROWSER::SELF 'WEB::STARTING-LIST) - (CLOS-BROWSER::MAKE-NODES (CLOS-BROWSER::COLLECT-FAMILY - NIL - (IL:FOR CLOS-BROWSER::EACH - IL:IN (REVERSE - (IL:* IL:\; - "so they come out in the original order") - (SLOT-VALUE CLOS-BROWSER::SELF - 'WEB::STARTING-LIST)) IL:WHEN - - CLOS-BROWSER::EACH - IL:COLLECT (SLOT-VALUE CLOS-BROWSER::EACH - `CLOS-BROWSER::CLASS))))) - (CALL-NEXT-METHOD) - (WHEN (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) - - (IL:* IL:|;;| "Node has been invalidated, so get rid of this pointer to it. ") - - (SETF (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) - 'WEB:BOXED-NODE) - NIL) - (SETF (SLOT-VALUE CLOS-BROWSER:CLOS-ICON 'CLOS-BROWSER::DESTINATION-BROWSER) - NIL))) - -(DEFMETHOD CLOS-BROWSER::REAL-ADD-ROOT ((CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER) - CLOS-BROWSER::CLASS) - "Add a class to the starting list of the browser" - (WHEN CLOS-BROWSER::CLASS - (LET* ((CLOS-BROWSER::CLASS (IF (TYPEP CLOS-BROWSER::CLASS 'STANDARD-CLASS) - CLOS-BROWSER::CLASS - (FIND-CLASS CLOS-BROWSER::CLASS))) - (CLOS-BROWSER::NEW-NODE (CAR (CLOS-BROWSER::MAKE-NODES (LIST CLOS-BROWSER::CLASS))) - )) - (IF CLOS-BROWSER::NEW-NODE - (PROGN (PUSHNEW CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER - 'WEB::STARTING-LIST)) - (IF (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::GOOD-LIST) - (PUSHNEW CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER - 'WEB::GOOD-LIST))) - (SETF (SLOT-VALUE CLOS-BROWSER::BROWSER 'WEB::BAD-LIST) - (IL:DREMOVE CLOS-BROWSER::NEW-NODE (SLOT-VALUE CLOS-BROWSER::BROWSER - 'WEB::BAD-LIST))) - CLOS-BROWSER::BROWSER) - - (IL:* IL:|;;| "otherwise return nil") - - NIL)))) - -(DEFMETHOD WEB:SHAPE-TO-HOLD ((WEB::SELF CLOS-BROWSER::CLOS-BROWSER)) - "give a larger width for empty browsers so add-node will have room" - (LET* ((WEB::WINDOW (SLOT-VALUE WEB::SELF 'WEB::WINDOW)) - (WEB::NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP WEB::WINDOW - 'IL:GRAPH)))) - (IF WEB::NODES - (CALL-NEXT-METHOD) - (LET ((WEB::REGION (IL:WINDOWPROP WEB::WINDOW 'IL:REGION)) - (WEB::MIN-HEIGHT (IL:FONTHEIGHT (IL:DSPFONT NIL WEB::WINDOW))) - (WEB::MIN-WIDTH (MAX 250 (IL:IPLUS 5 (IL:STRINGWIDTH (SLOT-VALUE WEB::SELF - 'WEB::TITLE) - (IL:DSPFONT NIL - IL:|WindowTitleDisplayStream|)) - )))) - (WEB::SET-REGION WEB::SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| - WEB::REGION) - (IL:|fetch| IL:BOTTOM IL:|of| WEB::REGION - ) - WEB::MIN-WIDTH WEB::MIN-HEIGHT)))))) - -(DEFMETHOD CLOS-BROWSER::SUBCLASSES-OF ((CLOS-BROWSER::CLASS T)) - (APPEND (LIST CLOS-BROWSER::CLASS) - (IL:FOR CLOS-BROWSER::SUBCLASS IL:IN (SLOT-VALUE CLOS-BROWSER::CLASS - 'CLOS::DIRECT-SUBCLASSES) - IL:JOIN (IF (SLOT-VALUE CLOS-BROWSER::SUBCLASS 'CLOS::DIRECT-SUBCLASSES) - (CLOS-BROWSER::SUBCLASSES-OF CLOS-BROWSER::SUBCLASS) - (LIST CLOS-BROWSER::SUBCLASS))))) - -(DEFMETHOD CLOS-BROWSER::CONTAINS-P ((CLOS-BROWSER::CLASS T) - (CLOS-BROWSER::BROWSER CLOS-BROWSER::CLOS-BROWSER)) - (LET ((CLOS-BROWSER::NODE (CAR (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::BROWSER - 'WEB::STARTING-LIST) - :TEST - #'CLOS-BROWSER::THIS-CLASS-NODE-P)))) - (WHEN (AND CLOS-BROWSER::NODE (NOT (MEMBER CLOS-BROWSER::CLASS (SLOT-VALUE - CLOS-BROWSER::BROWSER - 'WEB::BAD-LIST) - :TEST - #'CLOS-BROWSER::THIS-CLASS-NODE-P))) - CLOS-BROWSER::NODE))) - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;;| "CLOS-BROWSER-NODE CLASS") - - -(DEFCLASS CLOS-BROWSER::CLOS-BROWSER-NODE (WEB:WEB-NODE) - ((CLOS-BROWSER::CLASS (IL:* IL:\; - "The class represented by this node") - ) - (CLOS-BROWSER::MENU-CACHE :INITFORM NIL) (IL:* IL:\; - "Menus of methods and slots. See clos-icon for the switch that controls when this gets updated.") - (CLOS-BROWSER::LARGE-MENU-SIZE :ALLOCATION :CLASS :INITFORM 22) - (CLOS-BROWSER::LARGE-MENU-FONT :ALLOCATION :INSTANCE :INITFORM (IL:FONTCREATE - `(IL:HELVETICA 8))) - (CLOS-BROWSER::LOCAL-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM - '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition." - (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method"))) - ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition." - (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.") - ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.") - ("Documentation" 'DOCUMENTATION "Print this method's documentation."))) - ("Delete" 'CLOS-BROWSER::DELETE-METHOD "Remove this method.") - ("Copy" 'CLOS-BROWSER::COPY "Copy this method to boxed class.") - ("Move" 'CLOS-BROWSER::MOVE "Move this method to boxed class.") - ("Rename" 'CLOS-BROWSER::RENAME - "Change the name of this method to new name you specify") - ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.") - ("Trace" 'CLOS::TRACE-METHOD "Trace this method.") - ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.") - ("Who owns" 'CLOS-BROWSER::WHO-OWNS - "Show the classes on which this method is specialized."))) - (CLOS-BROWSER::INHERITED-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM - '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition." - (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method"))) - ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition." - (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.") - ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.") - ("Documentation" 'DOCUMENTATION "Print this method's documentation."))) - ("Override" 'CLOS-BROWSER::OVERRIDE "Create a local method with this name.") - ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.") - ("Trace" 'CLOS::TRACE-METHOD "Trace this method.") - ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.") - ("Who owns" 'CLOS-BROWSER::WHO-OWNS - "Show the classes on which this method is specialized."))) - (CLOS-BROWSER::ALL-METHOD-OPERATIONS :ALLOCATION :INSTANCE :INITFORM - '(("Edit" 'CLOS-BROWSER::EDIT "Bring up the editor on this method's definition." - (IL:SUBITEMS ("Inspect" 'INSPECT "Inspect this method"))) - ("Print" 'CLOS-BROWSER::PRINT-DEFINITION "Pretty Print this method's definition." - (IL:SUBITEMS ("Print" 'PRINT "Print this method's definition.") - ("Describe" 'CLOS-BROWSER::DESCRIBE-METHOD "Describe this method.") - ("Documentation" 'DOCUMENTATION "Print this method's documentation."))) - ("Delete" 'DELETE "Remove this method.") - ("Copy" 'CLOS-BROWSER::COPY "Copy this method to boxed class.") - ("Move" 'CLOS-BROWSER::MOVE "Move this method to boxed class.") - ("Rename" 'CLOS-BROWSER::RENAME - "Change the name of this method to new name you specify") - ("Override" 'CLOS-BROWSER::OVERRIDE "Create a local method with this name.") - ("Break" 'CLOS::BREAK-METHOD "Cause a break window whenever this method is invoked.") - ("Trace" 'CLOS::TRACE-METHOD "Trace this method.") - ("UnBreak" 'CLOS::UNBREAK-METHOD "Unbreak this method.") - ("Who owns" 'CLOS-BROWSER::WHO-OWNS - "Show the classes on which this method is specialized."))))) - -(DEFMETHOD CLOS-BROWSER::OBJECT-NAME ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE)) - (WEB:NODE-NAME CLOS-BROWSER::SELF)) - -(DEFMETHOD CLOS-BROWSER::OVERRIDE ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) - CLOS-BROWSER::METHOD) - "Create a method specialized on the class." - (ADD-METHOD CLOS-BROWSER::NODE NIL (SLOT-VALUE (CLOS::METHOD-GENERIC-FUNCTION CLOS-BROWSER::METHOD - ) - 'CLOS::NAME))) - -(DEFMETHOD CLOS-BROWSER::CACHE (CLOS-BROWSER::MENU (CLOS-BROWSER::NODE - CLOS-BROWSER::CLOS-BROWSER-NODE) - &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL) - (LET ((CLOS-BROWSER::MENU-TYPE (CASE CLOS-BROWSER::INHERITED-OR-ALL - ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU) - (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU) - (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU)))) - (IF (NOT (ASSOC CLOS-BROWSER::MENU-TYPE (SLOT-VALUE CLOS-BROWSER::NODE - 'CLOS-BROWSER::MENU-CACHE))) - - (IL:* IL:|;;| "then initialize alist") - - (SETF (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE) - (ACONS CLOS-BROWSER::MENU-TYPE CLOS-BROWSER::MENU (SLOT-VALUE CLOS-BROWSER::NODE - 'CLOS-BROWSER::MENU-CACHE) - )) - - (IL:* IL:|;;| "otherwise replace what is already there") - - (RPLACD (ASSOC CLOS-BROWSER::MENU-TYPE (SLOT-VALUE CLOS-BROWSER::NODE - 'CLOS-BROWSER::MENU-CACHE)) - CLOS-BROWSER::MENU)))) - -(DEFMETHOD CLOS-BROWSER::UNCACHE ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) - &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL) - (RPLACD (ASSOC (CASE CLOS-BROWSER::INHERITED-OR-ALL - ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU) - (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU) - (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU)) - (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::MENU-CACHE)) - NIL)) - -(IL:RPAQ CLOS-BROWSER::*METHOD-PROMPT-STRING* (CONCATENATE 'STRING - "Left button to edit the method." " -" "Middle button provides a menu of operations.")) - -(DEFUN CLOS-BROWSER::EDIT (CLOS-BROWSER::METHOD) - (LET ((*PACKAGE* (SYMBOL-PACKAGE (CLOS::GENERIC-FUNCTION-NAME (CLOS::METHOD-GENERIC-FUNCTION - CLOS-BROWSER::METHOD))))) - (ED (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD) - ':DONTWAIT))) - -(DEFUN CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS (CLOS::METHODS CLOS-BROWSER::CLASS &OPTIONAL - CLOS-BROWSER::INHERITED-OR-ALL) - "gather method-list into menu items list" - (LET ((CLOS-BROWSER::METHOD-MENU-ITEMS (CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS - CLOS::METHODS CLOS-BROWSER::INHERITED-OR-ALL)) - (CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS)) - (LET ((CLOS-BROWSER::PREVIOUS.ITEM NIL) - (CLOS-BROWSER::THIS.POSITION 0) - CLOS-BROWSER::GF-NAME) - (DOLIST (CLOS-BROWSER::THIS.ITEM CLOS-BROWSER::METHOD-MENU-ITEMS) - (SETQ CLOS-BROWSER::GF-NAME (CAR CLOS-BROWSER::THIS.ITEM)) - (INCF CLOS-BROWSER::THIS.POSITION) - (IF (NOT (AND CLOS-BROWSER::PREVIOUS.ITEM (IF (NOT (FIRST CLOS-BROWSER::THIS.ITEM)) - - (IL:* IL:|;;| - "then look for different gf objects with nil name") - - (EQ (CLOS::METHOD-GENERIC-FUNCTION - (SECOND - CLOS-BROWSER::PREVIOUS.ITEM - )) - (CLOS::METHOD-GENERIC-FUNCTION - (SECOND CLOS-BROWSER::THIS.ITEM)) - ) - - (IL:* IL:|;;| - "otherwise use slightly more efficient test for same gf") - - (EQ (FIRST CLOS-BROWSER::PREVIOUS.ITEM - ) - (FIRST CLOS-BROWSER::THIS.ITEM)))) - ) - - (IL:* IL:|;;| "then go on to the next") - - (SETQ CLOS-BROWSER::PREVIOUS.ITEM CLOS-BROWSER::THIS.ITEM) - - (IL:* IL:|;;| "otherwise we have multi-methods") - - (PROGN - (IL:* IL:|;;| "build a sub-menu of all the multi-methods") - - (IF (NOT (FOURTH CLOS-BROWSER::PREVIOUS.ITEM)) - - (IL:* IL:|;;| "then create the sub-menu") - - (NCONC CLOS-BROWSER::PREVIOUS.ITEM (LIST (LIST 'IL:SUBITEMS - ( - CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU - (SECOND - CLOS-BROWSER::PREVIOUS.ITEM - ) - CLOS-BROWSER::CLASS) - ( - CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU - (SECOND - CLOS-BROWSER::THIS.ITEM - ) - CLOS-BROWSER::CLASS)) - )) - - (IL:* IL:|;;| "otherwise add another item to the sub-menu") - - (NCONC (FOURTH CLOS-BROWSER::PREVIOUS.ITEM) - (LIST (CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU - (SECOND CLOS-BROWSER::THIS.ITEM) - CLOS-BROWSER::CLASS)))) - - (IL:* IL:|;;| - "collect the position of the extra multi-method menu item") - - (PUSH CLOS-BROWSER::THIS.POSITION CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS - ))))) - - (IL:* IL:|;;| "remove extra multi-method menu items last first.") - - (DOLIST (CLOS-BROWSER::EACH.POSITION CLOS-BROWSER::EXTRA-MENU-ITEM-POSITIONS) - (SETQ CLOS-BROWSER::METHOD-MENU-ITEMS (DELETE-IF #'XCL:TRUE - CLOS-BROWSER::METHOD-MENU-ITEMS :START - (- CLOS-BROWSER::EACH.POSITION 1) - :END CLOS-BROWSER::EACH.POSITION))) - - (IL:* IL:|;;| "prepend the Add method item") - - (APPEND '(("Add method" NIL - "Bring up an editor containing a template for a new method on this class.")) - CLOS-BROWSER::METHOD-MENU-ITEMS))) - -(DEFUN CLOS-BROWSER::MAKE-TOP-LEVEL-METHOD-MENU-ITEMS (CLOS::METHODS &OPTIONAL - CLOS-BROWSER::INHERITED-OR-ALL) - "gather local-methods into menu items list" - (DECLARE (SPECIAL CLOS-BROWSER::*METHOD-PROMPT-STRING*)) - (SORT (IL:FOR CLOS-BROWSER::EACH.METHOD IL:IN CLOS::METHODS IL:BIND - CLOS-BROWSER::METHOD-NAME - IL:UNLESS (AND (NOT (EQL CLOS-BROWSER::INHERITED-OR-ALL :ALL)) - (CLOS::*TYPEP CLOS-BROWSER::EACH.METHOD - 'CLOS::STANDARD-ACCESSOR-METHOD)) - - (IL:* IL:|;;| "weed out auto-generated slot access methods ") - IL:|eachtime| (SETQ CLOS-BROWSER::METHOD-NAME (CAR (CLOS::FULL-METHOD-NAME - CLOS-BROWSER::EACH.METHOD NIL))) - IL:|collect| (LIST CLOS-BROWSER::METHOD-NAME CLOS-BROWSER::EACH.METHOD - CLOS-BROWSER::*METHOD-PROMPT-STRING*)) - #'IL:ALPHORDER :KEY #'CAR)) - -(DEFUN CLOS-BROWSER::MAKE-MULTI-METHOD-SUB-MENU (CLOS-BROWSER::METHOD CLOS-BROWSER::CLASS) - "make a menu item to distinguish methods on the same gf" - (LET (CLOS-BROWSER::SUB-ITEM-NAME) - (DECLARE (SPECIAL CLOS-BROWSER::*METHOD-PROMPT-STRING*)) - - (IL:* IL:|;;| "first put out the qualifiers if any") - - (DOLIST (CLOS-BROWSER::QUALIFIER (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::SPECIALIZERS)) - (SETQ CLOS-BROWSER::SUB-ITEM-NAME (CONCATENATE 'STRING CLOS-BROWSER::SUB-ITEM-NAME - (WHEN CLOS-BROWSER::SUB-ITEM-NAME " ") - (PRIN1-TO-STRING CLOS-BROWSER::QUALIFIER)))) - - (IL:* IL:|;;| "then do the specializers ") - - (IL:* IL:|;;| "(DOLIST (TYPE-SPECIFIER (SLOT-VALUE METHOD 'CLOS::TYPE-SPECIFIERS)) (SETQ SUB-ITEM-NAME (CONCATENATE 'STRING SUB-ITEM-NAME (WHEN SUB-ITEM-NAME \" \") (IF (EQ CLASS TYPE-SPECIFIER) ;; then lets just do a plus sign \"+\" ;; else print the name (PRIN1-TO-STRING ;; test until class-name works properly (IF (TYPEP TYPE-SPECIFIER 'STANDARD-CLASS) (CLASS-NAME TYPE-SPECIFIER) TYPE-SPECIFIER))))))") - - (LIST CLOS-BROWSER::SUB-ITEM-NAME CLOS-BROWSER::METHOD CLOS-BROWSER::*METHOD-PROMPT-STRING*))) - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;| "OPERATORS (via CLOS-BROWSER-NODE) ON CLOS::STANDARD-CLASS") - - -(DEFMETHOD CLOS-BROWSER:ADD-BROWSER-METHOD ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) - &OPTIONAL CLOS-BROWSER::FORM - CLOS-BROWSER::METHOD-NAME) - "bring up sedit on a template to add a method to this class" - (DECLARE (SPECIAL SEDIT::BASIC-GAP SEDIT::BODY-GAP SEDIT::ARGS-GAP)) - (LET* ((CLASS-NAME (CLASS-NAME (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))) - CLOS-BROWSER::CONTEXT - (CLOS-BROWSER::NAME (FORMAT NIL "New method on ~A" CLASS-NAME)) - (*PACKAGE* (SYMBOL-PACKAGE CLASS-NAME))) - (UNLESS CLOS-BROWSER::FORM - (SETQ CLOS-BROWSER::FORM (LIST 'DEFMETHOD (OR CLOS-BROWSER::METHOD-NAME SEDIT::BASIC-GAP - ) - (LIST (LIST (INTERN "SELF") - CLASS-NAME) - SEDIT::ARGS-GAP) - SEDIT::BODY-GAP))) - (SEDIT:SEDIT CLOS-BROWSER::FORM (LIST :NAME CLOS-BROWSER::NAME :COMPLETION-FN - #'CLOS-BROWSER::COMPLETE-ADD-METHOD) - :DONTWAIT))) - -(DEFMETHOD CLOS-BROWSER::BROWSE-SUBS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS-BROWSER:BROWSE-CLASS (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS) - 'CLOS::NAME))) - -(DEFMETHOD CLOS-BROWSER::EDIT-CLASS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE)) - (LET* ((CLOS-BROWSER::CLASS (CLASS-NAME (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))) - (*PACKAGE* (SYMBOL-PACKAGE CLOS-BROWSER::CLASS))) - (ED CLOS-BROWSER::CLASS '(CLOS-BROWSER::CLASSES :DONTWAIT)))) - -(DEFMETHOD CLOS-BROWSER::INSPECT-CLASS ((CLOS::OBJECT CLOS-BROWSER::CLOS-BROWSER-NODE)) - (INSPECT (SLOT-VALUE CLOS::OBJECT 'CLOS-BROWSER::CLASS))) - -(DEFMETHOD CLOS-BROWSER::MENU-METHODS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) - &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL - CLOS-BROWSER::ITEMS CLOS-BROWSER::FIX-FLAG - CLOS-BROWSER::RECOMPUTE-FLAG) - "pops up a menu of the methods for the class representing the node." - - (IL:* IL:|;;| "If INHERITED-OR-ALL is NIL or :local only local methods are menued.") - - (IL:* IL:|;;| "If INHERITED-OR-ALL is :inherited only inherited methods are menued.") - - (IL:* IL:|;;| "If INHERITED-OR-ALL is :all all methods are menued.") - - (IL:* IL:|;;| "If items are present, the list of methods is not re-generated.") - - (IL:* IL:|;;| - "If the fix-flag is t, the user is asked to position the menu and no \"Fix menu\" item appears.") - - (IL:* IL:|;;| "The whenselectedfn can call this again to generate a fixed menu.") - - (LET* ((CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS)) - (*PACKAGE* (SYMBOL-PACKAGE (SLOT-VALUE CLOS-BROWSER::CLASS 'CLOS::NAME))) - (CLOS-BROWSER::MENU (UNLESS (OR CLOS-BROWSER::RECOMPUTE-FLAG (EQ (SLOT-VALUE - CLOS-BROWSER:CLOS-ICON - - ' - CLOS-BROWSER::MENU-CACHE-SWITCH - ) - :NONE)) - (REST (IL:* IL:\; "use the cached menu") - (ASSOC (CASE CLOS-BROWSER::INHERITED-OR-ALL - ((NIL :LOCAL) 'CLOS-BROWSER::LOCAL-METHODS-MENU) - (:INHERITED 'CLOS-BROWSER::IHHERITED-METHODS-MENU) - (:ALL 'CLOS-BROWSER::ALL-METHODS-MENU)) - (SLOT-VALUE CLOS-BROWSER::NODE - 'CLOS-BROWSER::MENU-CACHE)))))) - - (IL:* IL:|;;| "unless it was cached, make the menu") - - (UNLESS (AND CLOS-BROWSER::MENU (IL:TYPE? IL:MENU CLOS-BROWSER::MENU)) - - (IL:* IL:|;;| "unless the menu items were passed in, compute them") - - (UNLESS CLOS-BROWSER::ITEMS - (SETQ CLOS-BROWSER::ITEMS (CLOS-BROWSER::MAKE-METHOD-MENU-ITEMS - (CASE CLOS-BROWSER::INHERITED-OR-ALL - ((NIL :LOCAL) (CAR (SLOT-VALUE CLOS-BROWSER::CLASS - 'CLOS::DIRECT-METHODS))) - (:INHERITED (CLOS::COMPUTE-INHERITED-METHODS - CLOS-BROWSER::CLASS)) - (:ALL (CLOS::COMPUTE-INHERITED-METHODS - CLOS-BROWSER::CLASS :ALL))) - CLOS-BROWSER::CLASS))) - - (IL:* IL:|;;| "create the menu using whenselectedfn") - - (SETQ CLOS-BROWSER::MENU (IL:CREATE IL:MENU - IL:TITLE IL:_ (IF CLOS-BROWSER::FIX-FLAG - (CLASS-NAME CLOS-BROWSER::CLASS) - "methods") - IL:MENUFONT IL:_ (WHEN (> (LENGTH CLOS-BROWSER::ITEMS) - (SLOT-VALUE CLOS-BROWSER::NODE - - ' - CLOS-BROWSER::LARGE-MENU-SIZE - )) - (SLOT-VALUE CLOS-BROWSER::NODE - - ' - CLOS-BROWSER::LARGE-MENU-FONT - )) - IL:MENUUSERDATA IL:_ '(:ESCAPE T) - (IL:* IL:\; - "cause symbols to print in mouse process's read-table & package") - IL:WHENSELECTEDFN IL:_ ( - CLOS-BROWSER::MAKE-WHENSELECTEDFN - CLOS-BROWSER::NODE - CLOS-BROWSER::INHERITED-OR-ALL - CLOS-BROWSER::ITEMS) - IL:ITEMS IL:_ (APPEND CLOS-BROWSER::ITEMS - (UNLESS CLOS-BROWSER::FIX-FLAG - '(("Fix menu" NIL - "Place this menu on the screen. WARNING: cached menues are not kept up-to-date" - )))))) - - (IL:* IL:|;;| "cache the menu on the node") - - (CLOS-BROWSER::CACHE CLOS-BROWSER::MENU CLOS-BROWSER::NODE - CLOS-BROWSER::INHERITED-OR-ALL)) - (IF CLOS-BROWSER::FIX-FLAG - - (IL:* IL:|;;| "ask user to position menu") - - (IL:MOVEW (IL:ADDMENU CLOS-BROWSER::MENU)) - - (IL:* IL:|;;| "otherwise just pop it up") - - (IL:MENU CLOS-BROWSER::MENU)))) - -(DEFMETHOD CLOS-BROWSER::MAKE-WHENSELECTEDFN ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE - ) - &OPTIONAL CLOS-BROWSER::INHERITED-OR-ALL - CLOS-BROWSER::ITEMS) - `(LAMBDA - (CLOS-BROWSER::MENU-ITEM IGNORE CLOS-BROWSER::MOUSE-KEY) - (LET - ((CLOS-BROWSER::METHOD-NAME (FIRST CLOS-BROWSER::MENU-ITEM)) - (CLOS-BROWSER::METHOD (SECOND CLOS-BROWSER::MENU-ITEM))) - (IF (NULL CLOS-BROWSER::METHOD) - - (IL:* IL:|;;| "do the non-method items") - - (COND - ((STRING= CLOS-BROWSER::METHOD-NAME "Add method") - (CLOS-BROWSER:ADD-BROWSER-METHOD ',CLOS-BROWSER::NODE NIL)) - ((STRING= CLOS-BROWSER::METHOD-NAME "Fix menu") - - (IL:* IL:|;;| "call MENU-LOCAL-METHODS again to create fixed menu ") - - (CLOS-BROWSER::MENU-METHODS ',CLOS-BROWSER::NODE ',CLOS-BROWSER::INHERITED-OR-ALL - ',CLOS-BROWSER::ITEMS T)) - (T CLOS-BROWSER::OPERATION)) - - (IL:* IL:|;;| "got a method, lets get an operation") - - (LET ((CLOS-BROWSER::OPERATION - (CASE CLOS-BROWSER::MOUSE-KEY - (IL:LEFT 'CLOS-BROWSER::EDIT) - (IL:MIDDLE (IL:MENU (IL:CREATE - IL:MENU - IL:TITLE IL:_ CLOS-BROWSER::METHOD-NAME - IL:ITEMS IL:_ - (SLOT-VALUE ',CLOS-BROWSER::NODE - ',(CASE CLOS-BROWSER::INHERITED-OR-ALL - ((NIL :LOCAL) - ' - CLOS-BROWSER::LOCAL-METHOD-OPERATIONS) - (:INHERITED - ' - CLOS-BROWSER::INHERITED-METHOD-OPERATIONS) - (:ALL 'CLOS-BROWSER::ALL-METHOD-OPERATIONS)))) - ))))) - - (IL:* IL:|;;| "got an operation, lets use it on the method") - - (CASE CLOS-BROWSER::OPERATION - ((NIL) NIL) - ((CLOS-BROWSER::COPY CLOS-BROWSER::MOVE) (IL:* IL:\; - "need to supply destination") - (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD - - (IL:* IL:|;;| "to class") - - (PROGN (UNLESS (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::DESTINATION-BROWSER) - (ERROR "Please box a destination class, then say OK.")) - (SLOT-VALUE (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - - 'CLOS-BROWSER::DESTINATION-BROWSER - ) - `WEB:BOXED-NODE) - `CLOS-BROWSER::CLASS)) - - (IL:* IL:|;;| "from class") - - (SLOT-VALUE ',CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))) - ((DELETE) (IL:* IL:\; - "need to supply extra confirm") - (WHEN (IL:MOUSECONFIRM (FORMAT NIL - "Are you sure you wish to delete the ~A method?" - (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD))) - (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD))) - ((CLOS-BROWSER::OVERRIDE) (IL:* IL:\; "use add-method ") - (FUNCALL CLOS-BROWSER::OPERATION ',CLOS-BROWSER::NODE CLOS-BROWSER::METHOD)) - (OTHERWISE (FUNCALL CLOS-BROWSER::OPERATION CLOS-BROWSER::METHOD)))))))) - -(DEFMETHOD CLOS-BROWSER::DESCRIBE-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE)) - (CLOS::DESCRIBE-OBJECT (SLOT-VALUE CLOS-BROWSER::SELF 'CLOS-BROWSER::CLASS) - *TRACE-OUTPUT*)) - -(DEFMETHOD CLOS-BROWSER::DOCUMENTATION-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE - )) - (DOCUMENTATION (SLOT-VALUE CLOS-BROWSER::SELF 'CLOS-BROWSER::CLASS))) - -(DEFMETHOD CLOS-BROWSER::PRINT-CLASS ((CLOS-BROWSER::SELF CLOS-BROWSER::CLOS-BROWSER-NODE)) - (PPRINT (IL:GETDEF (SLOT-VALUE (SLOT-VALUE CLOS-BROWSER::SELF `CLOS-BROWSER::CLASS) - 'CLOS::NAME) - 'CLOS-BROWSER::CLASSES))) - -(DEFMETHOD CLOS-BROWSER::SPECIALIZE-CLASS ((CLOS-BROWSER::NODE CLOS-BROWSER::CLOS-BROWSER-NODE) - &OPTIONAL CLOS-BROWSER::FORM - CLOS-BROWSER::NEW-CLASS-NAME) - (CLOS-BROWSER::SPECIALIZE (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS) - CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME)) - -(DEFUN CLOS-BROWSER::COMPLETE-ADD-METHOD (CLOS-BROWSER::CONTEXT STRUCTURE &OPTIONAL ( - CLOS-BROWSER::CHANGED? - T)) - (DECLARE (IGNORE CLOS-BROWSER::CONTEXT)) - (CASE CLOS-BROWSER::CHANGED? - ((:ABORT NIL) NIL) - (OTHERWISE (EVAL (COPY-TREE (IL:* IL:\; - "to ensure the original list does not get destructively clobbered") - STRUCTURE))))) - -(DEFUN CLOS-BROWSER::COMPLETE-SPECIALIZE (IGNORE STRUCTURE CLOS-BROWSER::CHANGED?) - (DECLARE (IGNORE CLOS-BROWSER::CONTEXT)) - (CASE CLOS-BROWSER::CHANGED? - ((:ABORT NIL) NIL) - (T (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR))) - (UNWIND-PROTECT - (PROGN (IL:SETCURSOR IL:WAITINGCURSOR) - (LET ((CLOS-BROWSER::SUB-CLASS (EVAL (COPY-TREE - (IL:* IL:\; - "so original list does not get clobbered if this class's name changes") - STRUCTURE))) - CLOS-BROWSER::SUPER-CLASS) - - (IL:* IL:|;;| "check for bug") - - (WHEN (SYMBOLP CLOS-BROWSER::SUB-CLASS) - (SETQ CLOS-BROWSER::SUB-CLASS (FIND-CLASS CLOS-BROWSER::SUB-CLASS) - )) - (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::CLASS-BROWSERS)) - (DOLIST (CLOS-BROWSER::SUPER-CLASS (SLOT-VALUE - CLOS-BROWSER::SUB-CLASS - - ' - CLOS::DIRECT-SUPERCLASSES - )) - (WHEN (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUPER-CLASS - CLOS-BROWSER::BROWSER) - (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::BROWSER - CLOS-BROWSER::SUB-CLASS) - (RETURN)))))) - (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR)))))) - -(DEFUN CLOS-BROWSER::LYRIC-COMPLETE-SPECIALIZE (IGNORE STRUCTURE) - (LET ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR))) - (UNWIND-PROTECT - (PROGN (IL:SETCURSOR IL:WAITINGCURSOR) - (LET ((CLOS-BROWSER::SUB-CLASS (EVAL (COPY-TREE - (IL:* IL:\; - "so original list does not get clobbered if this class's name changes") - STRUCTURE))) - CLOS-BROWSER::SUPER-CLASS) - - (IL:* IL:|;;| "check for bug") - - (WHEN (SYMBOLP CLOS-BROWSER::SUB-CLASS) - (SETQ CLOS-BROWSER::SUB-CLASS (CLOS::SYMBOL-CLASS CLOS-BROWSER::SUB-CLASS - ))) - (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::CLASS-BROWSERS)) - (DOLIST (CLOS-BROWSER::SUPER-CLASS (SLOT-VALUE CLOS-BROWSER::SUB-CLASS - 'CLOS::LOCAL-SUPERS)) - (WHEN (CLOS-BROWSER::CONTAINS-P CLOS-BROWSER::SUPER-CLASS - CLOS-BROWSER::BROWSER) - (CLOS-BROWSER::ADD-ROOT CLOS-BROWSER::BROWSER - CLOS-BROWSER::SUB-CLASS) - (RETURN)))))) - (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR)))) - -(DEFUN CLOS-BROWSER::THIS-CLASS-NODE-P (CLOS-BROWSER::CLASS CLOS-BROWSER::NODE) - (EQ CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::NODE 'CLOS-BROWSER::CLASS))) - -(DEFUN CLOS::CLASS-DIRECT-METHODS (CLOS::CLASS) - (SLOT-VALUE CLOS::CLASS 'CLOS::DIRECT-METHODS)) - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-CLASS (directly)") - - -(DEFMETHOD CLOS::COMPUTE-INHERITED-METHODS ((CLOS::SELF STANDARD-CLASS) - &OPTIONAL CLOS::ALL-FLAG) - "Compute and return all inherited methods of a class. If all-flag eq :all then methods on t and the passed class are included." - - (IL:* IL:|;;| "The following does not use generic function dispatch-orders, discriminating-functions, or classical-method-tables.") - - (IL:* IL:|;;| "For each method in the direct-methods of each inherited class in the class-precedence-list for the class of interest, in class precedence order check to see if we have already analyzed its generic function.") - - (IL:* IL:|;;| "If it is a new gf then if there is exactly one type specifier then add the direct method to the list of inherited methods.") - - (IL:* IL:|;;| "If there is more than one type specifier then for every method in the gf for each specializer if the specializing class is equal to or later than the current class in the class precedence list, ignoring t, pushnew the method on the list of inherited methods.ÿÿ") - - (LET - ((CLOS::FILTERED-CLASSES NIL) - (CLOS::MY-GFS NIL) - (CLOS::CLASS-PRECEDENCE-LIST (SLOT-VALUE CLOS::SELF 'CLOS::CLASS-PRECEDENCE-LIST)) - (CLOS::INHERITED-METHODS NIL) - (CLOS::DIRECT-METHODS (CAR (SLOT-VALUE CLOS::SELF 'CLOS::DIRECT-METHODS))) - (CLOS::T-CLASS (FIND-CLASS 'T))) - (UNLESS (EQ CLOS::ALL-FLAG :ALL) (IL:* IL:\; - "ignore t and the bottom class ") - (PUSH CLOS::T-CLASS CLOS::FILTERED-CLASSES) - (PUSH CLOS::SELF CLOS::FILTERED-CLASSES) - (SETQ CLOS::MY-GFS (MAPCAR #'CLOS::METHOD-GENERIC-FUNCTION CLOS::DIRECT-METHODS))) - (DOLIST (CLOS::CLASS CLOS::CLASS-PRECEDENCE-LIST) - (UNLESS (MEMBER CLOS::CLASS CLOS::FILTERED-CLASSES) - (DOLIST (CLOS::DIRECT-METHOD (CAR (CLOS::CLASS-DIRECT-METHODS CLOS::CLASS))) - (LET ((CLOS::GF (CLOS::METHOD-GENERIC-FUNCTION CLOS::DIRECT-METHOD))) - (UNLESS (MEMBER CLOS::GF CLOS::MY-GFS :TEST #'EQ) - (IF (= 1 (LENGTH (SLOT-VALUE CLOS::DIRECT-METHOD 'CLOS::SPECIALIZERS)) - (IL:* IL:\; "Note: this check relies on guaranteed congruent lambda lists. There should be some way to query the gf directly.") - ) - - (IL:* IL:|;;| - "then only one specializer so this method must be inherited. ") - - (PUSH CLOS::DIRECT-METHOD CLOS::INHERITED-METHODS) - - (IL:* IL:|;;| "otherwise more than one so must look at specializers ") - - (DOLIST (CLOS::GF-METHOD (SLOT-VALUE CLOS::GF 'CLOS::METHODS)) - (DOLIST (CLOS::SPECIFIER (SLOT-VALUE CLOS::GF-METHOD - 'CLOS::SPECIALIZERS)) - (UNLESS (OR (EQ CLOS::T-CLASS CLOS::SPECIFIER) - (NOT (MEMBER CLOS::SPECIFIER - CLOS::CLASS-PRECEDENCE-LIST :TEST - #'EQ))) - (PUSHNEW CLOS::GF-METHOD CLOS::INHERITED-METHODS) - (RETURN)))))) - (PUSH CLOS::GF CLOS::MY-GFS))))) - CLOS::INHERITED-METHODS)) - -(DEFMETHOD CLOS-BROWSER::SPECIALIZE ((CLOS-BROWSER::CLASS STANDARD-CLASS) - &OPTIONAL CLOS-BROWSER::FORM CLOS-BROWSER::NEW-CLASS-NAME) - (DECLARE (SPECIAL SEDIT::BASIC-GAP)) - (LET* ((CLASS-NAME (CLASS-NAME CLOS-BROWSER::CLASS)) - CLOS-BROWSER::CONTEXT - (CLOS-BROWSER::NAME (FORMAT NIL "New sub-class of ~A" CLASS-NAME)) - (*PACKAGE* (SYMBOL-PACKAGE CLASS-NAME))) - (UNLESS CLOS-BROWSER::FORM - (SETQ CLOS-BROWSER::FORM (LIST 'DEFCLASS (OR CLOS-BROWSER::NEW-CLASS-NAME - SEDIT::BASIC-GAP) - (LIST CLASS-NAME) - (LIST SEDIT::BODY-GAP)))) - - (IL:* IL:|;;| "call sedit") - - (SEDIT:SEDIT CLOS-BROWSER::FORM (LIST :NAME CLOS-BROWSER::NAME :COMPLETION-FN - #'CLOS-BROWSER::COMPLETE-SPECIALIZE) - :DONTWAIT))) - -(DEFMETHOD CLOS-BROWSER::SUBCLASSES-OF ((CLOS-BROWSER::CLASS STANDARD-CLASS)) - (APPEND (LIST CLOS-BROWSER::CLASS) - (IL:FOR CLOS-BROWSER::SUBCLASS IL:IN (SLOT-VALUE CLOS-BROWSER::CLASS - 'CLOS::DIRECT-SUBCLASSES) - IL:JOIN (IF (SLOT-VALUE CLOS-BROWSER::SUBCLASS 'CLOS::DIRECT-SUBCLASSES) - (CLOS-BROWSER::SUBCLASSES-OF CLOS-BROWSER::SUBCLASS) - (LIST CLOS-BROWSER::SUBCLASS))))) - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;| "OPERATORS ON CLOS::STANDARD-METHOD") - - -(DEFMETHOD CLOS-BROWSER::DELETE-METHOD ((CLOS-BROWSER::METHOD STANDARD-METHOD)) - (REMOVE-METHOD (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::GENERIC-FUNCTION) - CLOS-BROWSER::METHOD)) - -(DEFMETHOD CLOS-BROWSER::COPY ((CLOS-BROWSER::METHOD STANDARD-METHOD) - (CLOS-BROWSER::TO-CLASS STANDARD-CLASS) - &OPTIONAL CLOS-BROWSER::FROM-CLASS) - (WHEN (EQ CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS) - (RETURN-FROM CLOS-BROWSER::COPY)) - - (IL:* IL:|;;| "if we have the source code, find all the references to the from class, change them to the to-class, and evaluate the new form. If from-class is not provided, if method is specialized on just one class, use it, otherwise ask the user.") - - (IL:* IL:|;;| "If we dont have source code, we could ask if you want to just move the method object, but instead we print a complaint and punt.") - - (LET ((CLOS-BROWSER::METHOD-DEFINITION (COPY-TREE (XCL:IGNORE-ERRORS (IL:GETDEF ( - CLOS::FULL-METHOD-NAME - - CLOS-BROWSER::METHOD - ) - - 'CLOS-BROWSER::METHODS - )))) - (CLOS-BROWSER::NON-T-CLASSES (MAPCAR #'(LAMBDA (CLOS-BROWSER::CLASS) - (UNLESS (EQ CLOS-BROWSER::CLASS 'T) - CLOS-BROWSER::CLASS)) - (CLOS::METHOD-SPECIALIZERS CLOS-BROWSER::METHOD)))) - (UNLESS CLOS-BROWSER::METHOD-DEFINITION - (FORMAT T "The definition for ~A is not loaded" (CLOS::FULL-METHOD-NAME - CLOS-BROWSER::METHOD NIL)) - (RETURN-FROM CLOS-BROWSER::COPY NIL)) - (IF CLOS-BROWSER::FROM-CLASS - - (IL:* IL:|;;| "method should be specialized on from-class.") - - (UNLESS (MEMBER CLOS-BROWSER::FROM-CLASS CLOS-BROWSER::NON-T-CLASSES) - (ERROR "The ~A method is not specialized on the ~A class" (CLOS::FULL-METHOD-NAME - CLOS-BROWSER::METHOD NIL) - (CLASS-NAME CLOS-BROWSER::FROM-CLASS))) - - (IL:* IL:|;;| "otherwise see if we can deduce FROM-CLASS ") - - (CASE (LENGTH CLOS-BROWSER::NON-T-CLASSES) - (0 (FORMAT T "Unspecialized methods cannot be copied. ~A" (CLOS::FULL-METHOD-NAME - CLOS-BROWSER::METHOD NIL))) - (1 (SETQ CLOS-BROWSER::FROM-CLASS (CAR CLOS-BROWSER::NON-T-CLASSES))) - (OTHERWISE (SETQ CLOS-BROWSER::FROM-CLASS (CLOS::SYMBOL-CLASS - (IL:PROMPTFORWORD (FORMAT NIL - "Which class in ~A do you wish to move from?" - ( - CLOS::FULL-METHOD-NAME - - CLOS-BROWSER::METHOD - NIL)))))))) - - (IL:* IL:|;;| "should contain from-class. If it is not the same, abort.") - - (CLOS-BROWSER::REPLACE-SPECIALIZERS CLOS-BROWSER::METHOD-DEFINITION (CLASS-NAME - CLOS-BROWSER::FROM-CLASS - ) - (CLASS-NAME CLOS-BROWSER::TO-CLASS)) - (PRINT (EVAL CLOS-BROWSER::METHOD-DEFINITION)))) - -(DEFMETHOD CLOS-BROWSER::MOVE ((CLOS-BROWSER::METHOD STANDARD-METHOD) - (CLOS-BROWSER::TO-CLASS STANDARD-CLASS) - &OPTIONAL CLOS-BROWSER::FROM-CLASS) - (WHEN (EQ CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS) - (RETURN-FROM CLOS-BROWSER::MOVE)) - (IF (CLOS-BROWSER::COPY CLOS-BROWSER::METHOD CLOS-BROWSER::TO-CLASS CLOS-BROWSER::FROM-CLASS) - (CLOS-BROWSER::DELETE-METHOD CLOS-BROWSER::METHOD) - (FORMAT T "copy of ~A to ~A failed" (XCL:IGNORE-ERRORS (CLOS::FULL-METHOD-NAME - CLOS-BROWSER::METHOD)) - (XCL:IGNORE-ERRORS (CLASS-NAME CLOS-BROWSER::TO-CLASS))))) - -(DEFMETHOD CLOS-BROWSER::PRINT-DEFINITION ((CLOS-BROWSER::SELF STANDARD-METHOD)) - (PPRINT (IL:GETDEF (CLOS::FULL-METHOD-NAME CLOS-BROWSER::SELF) - 'CLOS-BROWSER::METHODS))) - -(DEFMETHOD CLOS-BROWSER::DESCRIBE-METHOD ((CLOS-BROWSER::METHOD CLOS::METHOD)) - (CLOS::DESCRIBE-OBJECT CLOS-BROWSER::METHOD *TRACE-OUTPUT*)) - -(DEFMETHOD CLOS-BROWSER::RENAME ((CLOS-BROWSER::METHOD STANDARD-METHOD) - &OPTIONAL CLOS-BROWSER::NEW-NAME) - (UNLESS CLOS-BROWSER::NEW-NAME - (SETQ CLOS-BROWSER::NEW-NAME (READ (MAKE-STRING-INPUT-STREAM (IL:PROMPTFORWORD - (FORMAT NIL "~%New name for ~A" - (CLOS::FULL-METHOD-NAME - CLOS-BROWSER::METHOD)))) - ))) - (LET ((CLOS-BROWSER::METHOD-DEFINITION (XCL:IGNORE-ERRORS (IL:GETDEF CLOS-BROWSER::METHOD)))) - (UNLESS CLOS-BROWSER::METHOD-DEFINITION - (FORMAT T "The definition for ~A is not loaded" (CLOS::FULL-METHOD-NAME - CLOS-BROWSER::METHOD NIL)) - (RETURN-FROM CLOS-BROWSER::RENAME NIL)) - (IF (AND (SETF (SECOND CLOS-BROWSER::METHOD-DEFINITION) - CLOS-BROWSER::NEW-NAME) - (PRINT (EVAL CLOS-BROWSER::METHOD-DEFINITION))) - (DELETE CLOS-BROWSER::METHOD) - (FORMAT T "~%Rename of ~A to ~A failed" (XCL:IGNORE-ERRORS (CLOS::FULL-METHOD-NAME - CLOS-BROWSER::METHOD)) - CLOS-BROWSER::NEW-NAME)))) - -(DEFMETHOD CLOS-BROWSER::UPDATE-CACHED-MENUES ((CLOS-BROWSER::METHOD STANDARD-METHOD) - &OPTIONAL - (CLOS-BROWSER::CACHE-SWITCH (SLOT-VALUE - - CLOS-BROWSER:CLOS-ICON - - ' - CLOS-BROWSER::MENU-CACHE-SWITCH - ))) - "set cached menues for this method's class to nil" - (LET - ((CLOS-BROWSER::ORIGINALCURSOR (IL:CURSOR))) - (UNWIND-PROTECT - (PROGN (IL:SETCURSOR IL:WAITINGCURSOR) - (DOLIST (CLOS-BROWSER::BROWSER (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::CLASS-BROWSERS)) - (DOLIST (CLOS-BROWSER::CLASS (SLOT-VALUE CLOS-BROWSER::METHOD 'CLOS::SPECIALIZERS) - ) - - (IL:* IL:|;;| - "fix bug in the inconsistent way CLOS objects store T class specializers and do method lookup.") - - (WHEN (EQ CLOS-BROWSER::CLASS T) - (SETQ CLOS-BROWSER::CLASS (CLOS::SYMBOL-CLASS T))) - (LET ((CLOS-BROWSER::NODE (CLOS-BROWSER::BROWSER-CONTAINS-P - CLOS-BROWSER::CLASS CLOS-BROWSER::BROWSER))) - (WHEN CLOS-BROWSER::NODE - (CASE CLOS-BROWSER::CACHE-SWITCH - (:LAZY - (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE) - (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :ALL) - (DOLIST (CLOS-BROWSER::SUB-CLASS (CLOS-BROWSER::SUBCLASSES-OF - (SLOT-VALUE - CLOS-BROWSER::NODE - 'CLOS-BROWSER::CLASS) - )) - (WHEN (SETQ CLOS-BROWSER::NODE (CLOS-BROWSER::CONTAINS-P - CLOS-BROWSER::SUB-CLASS - CLOS-BROWSER::BROWSER)) - (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :INHERITED) - (CLOS-BROWSER::UNCACHE CLOS-BROWSER::NODE :ALL)))) - (:EAGER (PRINT ":eager method menu cacheing not yet implemented." - )) - (OTHERWISE - NIL (IL:* IL:\; "do nothing") - ))))))) - (IL:SETCURSOR CLOS-BROWSER::ORIGINALCURSOR)))) - -(DEFMETHOD CLOS-BROWSER::WHO-OWNS ((CLOS-BROWSER::METHOD STANDARD-METHOD)) - (PRINT (CLOS::FULL-METHOD-NAME CLOS-BROWSER::METHOD))) - -(DEFMETHOD ADD-METHOD :AFTER - ((CLOS-BROWSER::GENERIC-FUNCTION STANDARD-GENERIC-FUNCTION) - (CLOS-BROWSER::METHOD STANDARD-METHOD)) - "Update cached menues." - (LET (CLOS-BROWSER::CACHE-SWITCH) - (WHEN (AND CLOS-BROWSER::METHOD (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::CLASS-BROWSERS) - (IL:* IL:\; "there are some browsers") - (NOT (EQ (SETQ CLOS-BROWSER::CACHE-SWITCH (SLOT-VALUE CLOS-BROWSER:CLOS-ICON - 'CLOS-BROWSER::MENU-CACHE-SWITCH) - ) - :NONE)) (IL:* IL:\; - "we want auto cache updating") - ) - (CLOS-BROWSER::UPDATE-CACHED-MENUES CLOS-BROWSER::METHOD CLOS-BROWSER::CACHE-SWITCH)) - CLOS-BROWSER::GENERIC-FUNCTION)) - -(DEFUN CLOS-BROWSER::REPLACE-SPECIALIZERS (CLOS-BROWSER::METHOD-DEFINITION - CLOS-BROWSER::FROM-CLASS-NAME - CLOS-BROWSER::TO-CLASS-NAME &KEY - CLOS-BROWSER::IN-LAMDA-LIST-ONLY-FLAG) - (NSUBST CLOS-BROWSER::TO-CLASS-NAME CLOS-BROWSER::FROM-CLASS-NAME - (IF CLOS-BROWSER::IN-LAMDA-LIST-ONLY-FLAG - - (IL:* IL:|;;| "get the lamba list") - - (THIRD (MULTIPLE-VALUE-LIST (CLOS::PARSE-DEFMETHOD (CDR CLOS-BROWSER::METHOD-DEFINITION - )))) - (IL:* IL:\; "note this gets argument names as well as specializers. Usually not what you want. Needs to be made smarter to just get specializers.") - - (IL:* IL:|;;| "otherwise do the whole method") - - CLOS-BROWSER::METHOD-DEFINITION))) - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;;| "SETUP RELEASE INFO") - - -(IL:RPAQ CLOS-BROWSER::RELEASE-ID "0.02") - -(IL:RPAQ CLOS-BROWSER::SYSTEM-DATE (CAAR (IL:GETPROP 'IL:CLOS-BROWSER 'IL:FILEDATES))) - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;| "SETUP BACKGROUND MENU") - - -(DEFUN CLOS-BROWSER::IN-SELECT-PACKAGE () - "pops up a menu of packages" (IL:* IL:\; "Edited 18-Mar-87 13:13 by smL") - (IL:* IL:\; "") - - (IL:* IL:|;;| "kirk: 16Mar88 modified for clos-browser") - - (LET ((PACKAGE (IL:MENU - (IL:|create| - IL:MENU - IL:TITLE IL:_ "Select package" - IL:ITEMS IL:_ - (IL:SORT (IL:|for| PACKAGE IL:|in| (LIST-ALL-PACKAGES) IL:|bind| - IL:PACKAGE-NAME - IL:|collect| (IL:SETQ IL:PACKAGE-NAME (PACKAGE-NAME PACKAGE)) - `(,(IL:CONCAT (OR (CAR (PACKAGE-NICKNAMES PACKAGE)) - IL:PACKAGE-NAME) - ":") - ',IL:PACKAGE-NAME - ,(IL:CONCAT "Set the current package to " IL:PACKAGE-NAME ":" - ))) - (IL:FUNCTION (IL:LAMBDA (IL:X IL:Y) - (IL:ALPHORDER (CAR IL:X) - (CAR IL:Y))))) - IL:CENTERFLG IL:_ T)))) - (IL:|if| PACKAGE - IL:|then| (IN-PACKAGE PACKAGE)))) - -(DEFUN CLOS-BROWSER::CLASSES-IN-PACKAGE (PACKAGE &OPTIONAL CLOS-BROWSER::MAP-ON-PACKAGE) - "Retrieves a list of all the classes for a given package. When map-on-package is t this can be very slow." - - (IL:* IL:|;;| "The maphash is always fast, whereas for some strange reason map-on-package varys among packages greatly.") - - (LET ((CLOS-BROWSER::CLASSES)) - (UNLESS (TYPEP PACKAGE 'PACKAGE) - (SETQ PACKAGE (FIND-PACKAGE PACKAGE))) - (IF CLOS-BROWSER::MAP-ON-PACKAGE - (DO-SYMBOLS (CLOS-BROWSER::SYM PACKAGE) - (IF (AND (EQ (SYMBOL-PACKAGE CLOS-BROWSER::SYM) - PACKAGE) - (CLOS::SYMBOL-CLASS CLOS-BROWSER::SYM T)) - (PUSH CLOS-BROWSER::SYM CLOS-BROWSER::CLASSES))) - (MAPHASH #'(LAMBDA (CLOS-BROWSER::KEY CLOS-BROWSER::VAL) - (IF (EQ (SYMBOL-PACKAGE CLOS-BROWSER::KEY) - PACKAGE) - (PUSH CLOS-BROWSER::KEY CLOS-BROWSER::CLASSES))) - CLOS::*FIND-CLASS*)) - CLOS-BROWSER::CLASSES)) - - -(IL:* IL:|;;| "pushnew should eliminate this") - - -(SETQ IL:|BackgroundMenuCommands| (REMOVE 'IL:|BrowseClass| IL:|BackgroundMenuCommands| :KEY - #'CAR)) - -(PUSH '(IL:|BrowseClass| (CLOS-BROWSER:BROWSE-CLASS) - "Bring up a class browser." - (IL:SUBITEMS (IL:|all in a package| (CLOS-BROWSER:BROWSE-CLASS ( - CLOS-BROWSER::CLASSES-IN-PACKAGE - ( - CLOS-BROWSER::IN-SELECT-PACKAGE - ))) - - "Select a package and browse all the classes defined in that package." - ))) - IL:|BackgroundMenuCommands|) - -(SETQ IL:|BackgroundMenu| NIL) -(IL:PUTPROPS IL:NEW-CLOS-BROWSER IL:COPYRIGHT ("Venue" 1991)) -(IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL))) -IL:STOP diff --git a/obsolete/clos/2.0/WEB-EDITOR b/obsolete/clos/2.0/WEB-EDITOR deleted file mode 100644 index 581d6cf7..00000000 --- a/obsolete/clos/2.0/WEB-EDITOR +++ /dev/null @@ -1,2338 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE (LET ((*PACKAGE*)) (* ;; -"Put IN Seven EXtremely Random USEr Interface COmmands ") (CLPROVIDE "WEB-EDITOR") (CLIN-PACKAGE -"WEB" NICKNAMES (QUOTE ("WEB-EDITOR"))) (* ;; "EXPORT") (CLFLET ((XCL-USEREXPORT-FROM-WEB (&REST -XCL-USERSYMBOL-NAMES) (LET ((XCL-USERPKG (CLFIND-PACKAGE "WEB"))) (CLDOLIST (XCL-USERNAME -XCL-USERSYMBOL-NAMES) (EXPORT (CLINTERN XCL-USERNAME XCL-USERPKG) XCL-USERPKG))))) (* ;; -"Class Definitions and Slot Access") (XCL-USEREXPORT-FROM-WEB "WEB-EDITOR" "WEB-NODE" "NODE-NAME" -"NODE-LINKS" "NODE-BACK-LINKS" "LOCAL-COMMANDS" "NODE-MOVER-P" "TITLE-ITEMS" "LEFT-BUTTON-ITEMS" -"MIDDLE-BUTTON-ITEMS" "RIGHT-BUTTON-ITEMS" "BROWSE-FONT") (* ;; "For Subclassing") (XCL-USEREXPORT-FROM-WEB - "GET-LABEL" "GET-SUBS" "ICON-TITLE" "NODE-MENU-ITEMS" "REORDER-TREE" "MOVE-NODE") (* ;; "Top Level") -(XCL-USEREXPORT-FROM-WEB "MAKE-WEB-EDITOR" "INITIALIZE-EDITOR" "BROWSE" "DISPLAY-BROWSER" "DESTROY" -"ADD-NODE" "NOTICE-NODE" "REMOVE-NODE" "RENAME-NODE") (* ;; "Window Operations") (XCL-USEREXPORT-FROM-WEB - "SHRINK" "MOVE" "CLEAR" "PROMPT-PRINT" "PROMPT-READ" "PROMPT-FOR-LIST" "PROMPT-FOR-STRING" -"PROMPT-FOR-WORD") (* ;; "Recomputing and Changing parameters") (XCL-USEREXPORT-FROM-WEB "RECOMPUTE" - "RECOMPUTE-IN-PLACE" "RECOMPUTE-LABELS" "RECOMPUTE-IF-OPEN" "CLEAR-LABEL-CACHE" "CHANGE-FONT-SIZE" -"CHANGE-FORMAT" "SHAPE-TO-HOLD") (* ;; "For CLOS-BROWSER???") (XCL-USEREXPORT-FROM-WEB "BOXED-NODE" -"BOX-NODE")) (* ;; "USE") (CLUSE-PACKAGE (QUOTE ("CLOS" "LISP" "XCL")) "WEB") (* ;; "IMPORT") (CLFLET - ((XCL-USERIMPORT-FROM-PACKAGE (XCL-USERNAMES XCL-USERFROM &OPTIONAL XCL-USERSHADOW-P) (LET (( -XCL-USERFROM-PACKAGE (CLFIND-PACKAGE XCL-USERFROM))) (CLFUNCALL (CLIF XCL-USERSHADOW-P ( -CLFUNCTION CLSHADOWING-IMPORT) (CLFUNCTION IMPORT)) (CLMAPCAR (CLFUNCTION (CLLAMBDA (XCL-USERNAME -) (CLINTERN XCL-USERNAME XCL-USERFROM-PACKAGE))) XCL-USERNAMES))))) (XCL-USERIMPORT-FROM-PACKAGE - (QUOTE ("CLASSES" "METHODS")) "CLOS") (XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("FALSE")) "XCL") ( -XCL-USERIMPORT-FROM-PACKAGE (QUOTE ("FUNCTIONS" "FNS" "VARIABLES" "VARS" "BITMAPS" "COMS")) "IL")) ( -CLFIND-PACKAGE "WEB")) READTABLE "XCL" BASE 10) -(IL:FILECREATED " 5-Nov-91 08:07:23"  -IL:|{DSK}local>users>welch>lisp>clos>browser>WEB-EDITOR.;8| 132667 - - IL:|changes| IL:|to:| (IL:TYPES WEB-NODE WEB-EDITOR) - - IL:|previous| IL:|date:| "30-Sep-91 23:36:34" -IL:|{DSK}local>users>welch>lisp>clos>browser>WEB-EDITOR.;6|) - - -; Copyright (c) 1987, 1988, 1989, 1991 by Xerox Corporation. All rights reserved. - -(IL:PRETTYCOMPRINT IL:WEB-EDITORCOMS) - -(IL:RPAQQ IL:WEB-EDITORCOMS ((COMS IL:* FILE-HEADER-COMS) - - (IL:* IL:|;;| "") - - - -(IL:* IL:|;;;| "WEB EDITOR ") - - - (IL:* IL:|;;| "") - - - (IL:* IL:|;;| "Package Setup") - - (IL:DECLARE\: IL:DONTCOPY (IL:PROPS (IL:WEB-EDITOR - IL:MAKEFILE-ENVIRONMENT) - (IL:WEB-EDITOR IL:FILETYPE))) - - (IL:* IL:|;;| "Global Variables") - - - (IL:* IL:|;;| "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)") - - (VARIABLES DESTINATION-BROWSER) - (COMS (IL:* IL:\; "Client Interface") - - (IL:* IL:|;;| "Web Node Class") - - (CLASSES WEB-NODE) - - (IL:* IL:|;;| " Web Editor Class") - - (CLASSES WEB-EDITOR) - - (IL:* IL:|;;| "Top Level") - - (FUNCTIONS MAKE-WEB-EDITOR) - (METHODS (INITIALIZE-EDITOR (WEB-EDITOR)) - (DESTROY (WEB-EDITOR)) - (BROWSE (WEB-EDITOR))) - (METHODS - - (IL:* IL:|;;| "For Subclassing") - - (GET-LABEL (WEB-EDITOR WEB-NODE)) - (GET-SUBS (WEB-EDITOR WEB-NODE)) - (ICON-TITLE (WEB-EDITOR)) - - (IL:* IL:|;;| "Adding, Removing, Hiding Nodes.") - - (ADD-NODE (WEB-EDITOR WEB-NODE)) - (NOTICE-NODE (WEB-EDITOR WEB-NODE WEB-NODE)) - (REMOVE-NODE (WEB-EDITOR WEB-NODE)) - (DELETE-FROM-BROWSER (WEB-EDITOR)) - (REMOVE-FROM-BAD-LIST (WEB-EDITOR)) - - (IL:* IL:|;;| "") - - (RENAME-NODE (WEB-EDITOR WEB-NODE))) - (IL:* IL:\; "")) - (COMS (IL:* IL:\; "Window System Interface") - (METHODS (UPDATE (WEB-EDITOR)) - (CREATE-WINDOW (WEB-EDITOR)) - (SETUP-WINDOW (WEB-EDITOR)) - (DETACH-LISP-WINDOW (WEB-EDITOR)) - (SHRINK (WEB-EDITOR)) - (SET-OUTER-REGION (WEB-EDITOR)) - (SET-REGION (WEB-EDITOR)) - (MOVE (WEB-EDITOR)) - (MOVE1 (WEB-EDITOR)) - (AFTER-MOVE (WEB-EDITOR)) - (AFTER-RESHAPE (WEB-EDITOR)) - (SCROLL-WINDOW (WEB-EDITOR)) - (CLEAR (WEB-EDITOR)) - - (IL:* IL:|;;| "Prompt Window Interactions ") - - (GET-PROMPT-WINDOW (WEB-EDITOR)) - (REMOVE-PROMPT-WINDOW (WEB-EDITOR)) - (PROMPT-PRINT (WEB-EDITOR)) - (PROMPT-READ (WEB-EDITOR)) - (PROMPT-FOR-LIST (WEB-EDITOR)) - (PROMPT-FOR-STRING (WEB-EDITOR)) - (PROMPT-FOR-WORD (WEB-EDITOR))) - (FUNCTIONS MOVE-DOWN-P) - (FNS WEB-WINDOW-AFTER-MOVE-FN WEB-WINDOW-BUTTON-EVENT-FN - WEB-WINDOW-RESHAPE-FN WEB-WINDOW-CLOSE-FN IL:|PromptRead| - ) - (FNS WEB-WINDOW-EXPAND-FN) - (FUNCTIONS WEB-WINDOW-ICON-FN) - (BITMAPS *WEB-EDITOR-ICON-BM* *WEB-EDITOR-ICON-MASK*) - (VARIABLES *WEB-EDITOR-TEMPLATE*) - (VARS (IL:*D-WINDOW-DEFAULT-STREAM* IL:PROMPTWINDOW) - (WEB-STREAM IL:PROMPTWINDOW))) - (COMS (IL:* IL:\; - "Layout and Display Engine") - (VARS IL:|BrowserMargin| IL:|MaxLatticeHeight| - IL:|MaxLatticeWidth|) - (IL:SPECVARS IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|) - (VARS IL:GRAYSHADE1 IL:GRAYSHADE2 IL:GRAYSHADE3 IL:GRAYSHADE4) - (FNS TREE-ROOTS CHILD-NODES REACHABLE-NODES!) - (METHODS (DISPLAY-BROWSER (WEB-EDITOR)) - (BROWSER-OBJECTS (WEB-EDITOR)) - (GET-NODE-LIST (WEB-EDITOR)) - (OBJ-NAME-PAIR (WEB-EDITOR)) - (GRAPH-FITS (WEB-EDITOR)) - (NODE-REGION (WEB-EDITOR)) - (IL:* IL:\; "") - (RECOMPUTE (WEB-EDITOR)) - (RECOMPUTE-IN-PLACE (WEB-EDITOR)) - (RECOMPUTE-LABELS (WEB-EDITOR)) - (RECOMPUTE-IF-OPEN (WEB-EDITOR)) - (CLEAR-LABEL-CACHE (WEB-EDITOR)) - (OBJECT-FROM-LABEL (WEB-EDITOR)) - (CHANGE-FONT-SIZE (WEB-EDITOR)) - (CHANGE-FORMAT (WEB-EDITOR)) - (CHANGE-MAX-LABEL-SIZE (WEB-EDITOR)) - (SHAPE-TO-HOLD (WEB-EDITOR)) - (IL:* IL:\; "") - (IL:* IL:\; - "Node Marking and Selecting") - (GET-DISPLAY-LABEL (WEB-EDITOR)) - (BOX-NODE (WEB-EDITOR)) - (UNMARK-NODES (WEB-EDITOR)) - (HIGHLIGHT-NODE (WEB-EDITOR)) - (SHADE-NODE (WEB-EDITOR)) - (DISPLAY-NODE-HIGHTLIGHTS (WEB-EDITOR)) - (DISPLAY-NODE-SHADING (WEB-EDITOR)) - (REMOVE-HIGHLIGHTS (WEB-EDITOR)) - (REMOVE-SHADING (WEB-EDITOR)) - (FLASH-NODE (WEB-EDITOR)) - (FLIP-NODE (WEB-EDITOR)) - (POSITION-NODE (WEB-EDITOR))) - (FNS BOX-PRINT-STRING BREAK-STRING-FOR-BOXING BOX-WINDOW-NODE) - ) - (COMS (IL:* IL:\; "Button Events") - (FNS FIND-SELECTED-NODE) - (METHODS (BUTTON-EVENT-FN (WEB-EDITOR)) - (LEFT-SELECTION (WEB-EDITOR)) - (MIDDLE-SELECTION (WEB-EDITOR)) - (RIGHT-SELECTION (WEB-EDITOR)) - (TITLE-SELECTION (WEB-EDITOR)) - (NODE-SELECTION (WEB-EDITOR)) - (NODE-ACTION (WEB-EDITOR)) - (NODE-MENU-ITEMS (WEB-NODE)) - - (IL:* IL:|;;| "") - - (CHOICE-MENU (WEB-EDITOR)) - (DO-SELECTED-COMMAND (WEB-EDITOR)) - (WHEN-MENU-ITEM-HELD (WEB-EDITOR)) - (ITEM-MENU (WEB-EDITOR)) - (GET-MENU-ITEMS (WEB-EDITOR)) - (CLEAR-MENU-CACHE (WEB-EDITOR))) - (FNS WEB-MENU-WHENSELECTEDFN WINDOW-WHEN-HELD-FN) - (FNS SUB-ITEM-SELECTION DUAL-SUB-ITEMS WINDOW-WHEN-HELD-FN - DO-MENU-METHOD DUAL-MENU DUAL-SELECTION) - (IL:* IL:\; "Node Moving Protocol") - (METHODS (NODE-MOVE (WEB-EDITOR)) - (NODE-MOVE-SHALLOW (WEB-EDITOR)) - (SCIONS (WEB-NODE)) - (MAKE-REG-ASSOC (WEB-EDITOR)) - (REORDER-TREE (WEB-EDITOR)) - (MOVE-NODE (WEB-NODE)))) - (IL:* IL:\; "") - - (IL:* IL:|;;| "") - - (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY - IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) - (IL:NLAML) - (IL:LAMA WINDOW-WHEN-HELD-FN - WINDOW-WHEN-HELD-FN))))) - -(IL:RPAQQ FILE-HEADER-COMS ((IL:P (FORMAT T - "~&;WEB-EDITOR Copyright (c) 1987, VENUE Corporation. All rights reserved.~%" - ) - (PROVIDE "WEB-EDITOR")))) - -(FORMAT T "~&;WEB-EDITOR Copyright (c) 1987, VENUE Corporation. All rights reserved.~%") - -(PROVIDE "WEB-EDITOR") - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;;| "WEB EDITOR ") - - - - -(IL:* IL:|;;| "") - - - - -(IL:* IL:|;;| "Package Setup") - -(IL:DECLARE\: IL:DONTCOPY - -(IL:PUTPROPS IL:WEB-EDITOR IL:MAKEFILE-ENVIRONMENT - (:PACKAGE (LET ((*PACKAGE*)) - - (IL:* IL:|;;| "Put IN Seven EXtremely Random USEr Interface COmmands ") - - (PROVIDE "WEB-EDITOR") - (IN-PACKAGE "WEB" :NICKNAMES '("WEB-EDITOR")) - - (IL:* IL:|;;| "EXPORT") - - (FLET ((XCL-USER::EXPORT-FROM-WEB (&REST XCL-USER::SYMBOL-NAMES) - (LET ((XCL-USER::PKG (FIND-PACKAGE "WEB"))) - (DOLIST (XCL-USER::NAME XCL-USER::SYMBOL-NAMES) - (EXPORT (INTERN XCL-USER::NAME XCL-USER::PKG) - XCL-USER::PKG))))) - - (IL:* IL:|;;| "Class Definitions and Slot Access") - - (XCL-USER::EXPORT-FROM-WEB "WEB-EDITOR" "WEB-NODE" "NODE-NAME" - "NODE-LINKS" "NODE-BACK-LINKS" "LOCAL-COMMANDS" - "NODE-MOVER-P" "TITLE-ITEMS" "LEFT-BUTTON-ITEMS" - "MIDDLE-BUTTON-ITEMS" "RIGHT-BUTTON-ITEMS" "BROWSE-FONT") - - (IL:* IL:|;;| "For Subclassing") - - (XCL-USER::EXPORT-FROM-WEB "GET-LABEL" "GET-SUBS" "ICON-TITLE" - "NODE-MENU-ITEMS" "REORDER-TREE" "MOVE-NODE") - - (IL:* IL:|;;| "Top Level") - - (XCL-USER::EXPORT-FROM-WEB "MAKE-WEB-EDITOR" "INITIALIZE-EDITOR" - "BROWSE" "DISPLAY-BROWSER" "DESTROY" "ADD-NODE" - "NOTICE-NODE" "REMOVE-NODE" "RENAME-NODE") - - (IL:* IL:|;;| "Window Operations") - - (XCL-USER::EXPORT-FROM-WEB "SHRINK" "MOVE" "CLEAR" "PROMPT-PRINT" - "PROMPT-READ" "PROMPT-FOR-LIST" "PROMPT-FOR-STRING" - "PROMPT-FOR-WORD") - - (IL:* IL:|;;| "Recomputing and Changing parameters") - - (XCL-USER::EXPORT-FROM-WEB "RECOMPUTE" "RECOMPUTE-IN-PLACE" - "RECOMPUTE-LABELS" "RECOMPUTE-IF-OPEN" "CLEAR-LABEL-CACHE" - "CHANGE-FONT-SIZE" "CHANGE-FORMAT" "SHAPE-TO-HOLD") - - (IL:* IL:|;;| "For CLOS-BROWSER???") - - (XCL-USER::EXPORT-FROM-WEB "BOXED-NODE" "BOX-NODE")) - - (IL:* IL:|;;| "USE") - - (USE-PACKAGE '("CLOS" "LISP" "XCL") - "WEB") - - (IL:* IL:|;;| "IMPORT") - - (FLET ((XCL-USER::IMPORT-FROM-PACKAGE - (XCL-USER::NAMES XCL-USER::FROM &OPTIONAL XCL-USER::SHADOW-P) - (LET ((XCL-USER::FROM-PACKAGE (FIND-PACKAGE XCL-USER::FROM))) - (FUNCALL (IF XCL-USER::SHADOW-P - #'SHADOWING-IMPORT - #'IMPORT) - (MAPCAR #'(LAMBDA (XCL-USER::NAME) - (INTERN XCL-USER::NAME - XCL-USER::FROM-PACKAGE)) - XCL-USER::NAMES))))) - (XCL-USER::IMPORT-FROM-PACKAGE '("CLASSES" "METHODS") - "CLOS") - (XCL-USER::IMPORT-FROM-PACKAGE '("FALSE") - "XCL") - (XCL-USER::IMPORT-FROM-PACKAGE '("FUNCTIONS" "FNS" "VARIABLES" - "VARS" "BITMAPS" "COMS") - "IL")) - (FIND-PACKAGE "WEB")) - :READTABLE "XCL" :BASE 10)) - -(IL:PUTPROPS IL:WEB-EDITOR IL:FILETYPE :COMPILE-FILE) -) - - - -(IL:* IL:|;;| "Global Variables") - - - - -(IL:* IL:|;;| -"global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)" -) - - -(DEFGLOBALPARAMETER DESTINATION-BROWSER NIL - "global for cross-editor boxed node destination (like caret for current tty process copy and move destinations)" -) - - - -(IL:* IL:\; "Client Interface") - - - - -(IL:* IL:|;;| "Web Node Class") - - -(DEFCLASS WEB-NODE () - ((NAME :INITFORM NIL (IL:* IL:\; "Name of Node") - :ACCESSOR NODE-NAME) - (TO-LINKS :INITFORM NIL (IL:* IL:\; - "Nodes that this Node has Links TO") - :ACCESSOR GET-TO-LINKS :ACCESSOR NODE-LINKS) - (PARENT :INITFORM NIL :ACCESSOR NODE-BACK-LINKS))) - - - -(IL:* IL:|;;| " Web Editor Class") - - -(DEFCLASS WEB-EDITOR () - ( - (IL:* IL:|;;| "NODES ") - - (STARTING-LIST :INITFORM NIL (IL:* IL:\; - "list of objects used to compute this browser") - ) - (GOOD-LIST :INITFORM NIL (IL:* IL:\; - "limit choices to this set")) - (BAD-LIST :INITFORM NIL (IL:* IL:\; - "Don't put in any items on this set") - ) - - (IL:* IL:|;;| "GRAPHER FORMAT") - - (TOP-ALIGN :INITFORM NIL) - (BROWSE-FONT :INITFORM (IL:FONTCREATE '(IL:HELVETICA 10 IL:BOLD))) - (BROWSE-FONT-FAMILY :INITFORM 'IL:HELVETICA) - (BROWSE-FONT-FACE :INITFORM 'IL:BOLD) - (GRAPH-FORMAT :INITFORM '(IL:LATTICE)) - (GRAPH-FORMAT-CHOICES :ALLOCATION :CLASS :INITFORM '((IL:HORIZONTAL/LATTICE '(IL:LATTICE)) - (IL:VERTICAL/LATTICE '(IL:VERTICAL - IL:LATTICE)) - (IL:HORIZONTAL/TREE '(IL:COPIES/ONLY)) - (IL:VERTICAL/TREE '(IL:VERTICAL - IL:COPIES/ONLY))) - ) - - (IL:* IL:|;;| "WINDOW Interface") - - (WINDOW :INITFORM NIL) - (TITLE :INITFORM "Web Editor" (IL:* IL:\; - "If not NIL will be put in title of window") - ) - (LEFT :INITFORM 0 (IL:* IL:\; "left position of window") - ) - (BOTTOM :INITFORM 0 (IL:* IL:\; - "bottom position of window")) - (WIDTH :INITFORM 64) - (HEIGHT :INITFORM 32) - - (IL:* IL:|;;| "NODE Labels") - - (LABEL-CACHE :INITFORM NIL) - (LABEL-MAX-LINES :INITFORM NIL - - (IL:* IL:|;;| "the maximum number of lines to use in 'boxed' labels -- note that if the label wont fit within the LabelMaxLines and LabelMaxCharsWidth restrictions, it will be truncated") -) - (LABEL-MAX-CHARS-WIDTH :INITFORM NIL - - (IL:* IL:|;;| "the maximum width for labels -- if label is too big, it will be 'boxed'") -) - (IL:* IL:|;;| "NODE Operations") - - (LAST-SELECTED-OBJECT :INITFORM NIL (IL:* IL:\; "last object selected")) - (BOXED-NODE :INITFORM NIL (IL:* IL:\; "last item Boxed, if any") - ) - (BOX-LINE-WIDTH :ALLOCATION :CLASS - - (IL:* IL:|;;| "width to make box for BoxNode") - - :INITFORM 1) - (NODE-MOVER-P :ALLOCATION :CLASS :INITFORM NIL) - - (IL:* IL:|;;| "MENUS") - - (CACHE-MENU-P :INITFORM T) - (MENU-CACHE :INITFORM NIL (IL:* IL:\; - "Will Cache Menus only if CACHE-MENU-P is T") - ) - (LOCAL-COMMANDS :ALLOCATION :CLASS - - (IL:* IL:|;;| "messages that should be sent to browser when item seleted in menu, even if object does understand them") - - :INITFORM - '(BOX-NODE RECOMPUTE ADD-ROOT)) - (TITLE-ITEMS :ALLOCATION :CLASS - - (IL:* IL:|;;| "Items for menu of selections in title of window") - - :INITFORM - '(("Recompute" RECOMPUTE "" (IL:SUBITEMS ("Recompute" RECOMPUTE - "Recompute lattice from starting objects" - ) - ("Recompute Labels" RECOMPUTE-LABELS - "Recomputes the labels") - ("Recompute In Place" RECOMPUTE-IN-PLACE - "Recompute keeping current view in window"))) - ("Shape To Hold" SHAPE-TO-HOLD "Make window large or small enough to just hold graph") - ("Change Font Size" CHANGE-FONT-SIZE "Choose a new size Font") - ("Change Format" CHANGE-FORMAT "Change format between lattice and tree"))) - (LEFT-BUTTON-ITEMS :ALLOCATION :CLASS - - (IL:* IL:|;;| "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see LocalCommands") - - :INITFORM - '(("Box Node" BOX-NODE "Draw box around selected node. -Unboxed by another BoxNode") - ("Pretty Print" PP "Prettyprint selected item"))) - (MIDDLE-BUTTON-ITEMS :ALLOCATION :CLASS - - (IL:* IL:|;;| "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see LocalCommands") - - :INITFORM - '(("Inspect" IL:|Inspect| INSPECT "Inspect selected item") - ("Edit" EDIT-OBJECT "Edit selected item") - ("Delete From Browser" DELETE-FROM-BROWSER "Do not show item or its subs"))) - (RIGHT-BUTTON-ITEMS :ALLOCATION :CLASS :INITFORM '(("Close" (CLOSEW (("Close" CLOSEW) - ("Destroy" DESTROY)))) - ("Snap" SNAP) - ("Paint" PAINT) - ("Clear" CLEAR) - ("Bury" BURY) - ("Repaint" REPAINT) - ("Hardcopy" (HARDCOPY (("Hardcopy to File" - HARDCOPY-TO-FILE) - ("Hardcopy to Printer" - HARDCOPY-TO-PRINTER)) - )) - ("Move" MOVE) - ("Shape" SHAPE) - ("Shrink" SHRINK)) - (IL:* IL:\; - "Items to be done if Right button is selected") - ))) - - - -(IL:* IL:|;;| "Top Level") - - -(DEFUN MAKE-WEB-EDITOR () - (LET ((EDITOR (MAKE-INSTANCE 'WEB-EDITOR))) - (INITIALIZE-EDITOR EDITOR))) - -(DEFMETHOD INITIALIZE-EDITOR ((SELF WEB-EDITOR)) - (LET NIL (CREATE-WINDOW SELF) - SELF)) - -(DEFMETHOD DESTROY ((SELF WEB-EDITOR)) - (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) - (ICON-WINDOW (IL:WINDOWPROP WINDOW 'IL:ICONWINDOW))) - (IL:CLOSEW WINDOW) - (IF ICON-WINDOW (IL:CLOSEW ICON-WINDOW)) - (DETACH-LISP-WINDOW SELF))) - -(DEFMETHOD BROWSE ((SELF WEB-EDITOR) - &OPTIONAL BROWSE-LIST WINDOW-OR-TITLE GOOD-LIST POSITION) - (IL:* IL:\; "11-Sep-84 07:24") - (IL:* IL:\; - "Call Show and then shape to hold and move for first time") - (COND - ((IL:WINDOWP WINDOW-OR-TITLE) - (SETF (SLOT-VALUE SELF 'WINDOW) - WINDOW-OR-TITLE)) - (WINDOW-OR-TITLE (SETF (SLOT-VALUE SELF 'TITLE) - WINDOW-OR-TITLE))) - (COND - ((AND BROWSE-LIST (IL:NLISTP BROWSE-LIST)) - (IL:SETQ BROWSE-LIST (LIST BROWSE-LIST)))) - (SETF (SLOT-VALUE SELF 'STARTING-LIST) - BROWSE-LIST) - (SETF (SLOT-VALUE SELF 'GOOD-LIST) - GOOD-LIST) - (DISPLAY-BROWSER SELF) - (SHAPE-TO-HOLD SELF) - (MOVE SELF POSITION) - SELF) - -(DEFMETHOD GET-LABEL ((WEB-EDITOR WEB-EDITOR) - (NODE WEB-NODE)) (IL:* IL:\; - "Get a label for an object to be displayed in the browser.") - (NODE-NAME NODE)) - -(DEFMETHOD GET-SUBS ((EDITOR WEB-EDITOR) - (NODE WEB-NODE)) (IL:* IL:\; - "Gets a set of subs from an object for browsing") - (NODE-LINKS NODE)) - -(DEFMETHOD ICON-TITLE ((SELF WEB-EDITOR)) (IL:* IL:\; "18-Jan-85 15:35") - - (IL:* IL:|;;| "Compute the icont title for this browser") - - '|Web Editor|) - -(DEFMETHOD ADD-NODE ((WEB-EDITOR WEB-EDITOR) - (NEW-NODE WEB-NODE)) (IL:* IL:\; "11-Dec-86 10:23") - - (IL:* IL:|;;| "Add a new node to the browser.") - - (PUSHNEW NEW-NODE (SLOT-VALUE WEB-EDITOR 'STARTING-LIST)) - (IF (SLOT-VALUE WEB-EDITOR 'GOOD-LIST) - (PUSHNEW NEW-NODE (SLOT-VALUE WEB-EDITOR 'GOOD-LIST)))) - -(DEFMETHOD NOTICE-NODE ((WEB-EDITOR WEB-EDITOR) - (WEB-NODE WEB-NODE) - (PARENT-NODE WEB-NODE)) - (PUSH WEB-NODE (SLOT-VALUE PARENT-NODE 'TO-LINKS)) - (ADD-NODE WEB-EDITOR WEB-NODE)) - -(DEFMETHOD REMOVE-NODE ((WEB-EDITOR WEB-EDITOR) - (BYE-NODE WEB-NODE)) - (WITH-SLOTS (STARTING-LIST GOOD-LIST BAD-LIST) - WEB-EDITOR - - (IL:* IL:|;;| "") - - (SETF STARTING-LIST (DELETE BYE-NODE STARTING-LIST)) - (IF GOOD-LIST - (SETF GOOD-LIST (DELETE BYE-NODE GOOD-LIST))) - (IF BAD-LIST - (SETF BAD-LIST (DELETE BYE-NODE BAD-LIST))) - (SETF (NODE-LINKS (NODE-BACK-LINKS BYE-NODE)) - (DELETE BYE-NODE (NODE-LINKS (NODE-BACK-LINKS BYE-NODE)))))) - -(DEFMETHOD DELETE-FROM-BROWSER ((SELF WEB-EDITOR) - OBJ OBJ-NAME) (IL:* IL:\; " 5-Aug-86 16:50") - - (IL:* IL:|;;| "Place on badList for Browser") - - (PUSHNEW OBJ (SLOT-VALUE SELF 'BAD-LIST)) - (RECOMPUTE SELF)) - -(DEFMETHOD REMOVE-FROM-BAD-LIST ((SELF WEB-EDITOR)) (IL:* IL:\; "28-Dec-85 10:04") - (IL:* IL:\; - "Remove an item from BadList to allow it to be displayed once again") - (COND - ((NULL (SLOT-VALUE SELF 'BAD-LIST)) - (IL:CLRPROMPT) - (IL:PROMPTPRINT "No BadList items.")) - (T (PROG ((IL:|item| (IL:MENU (IL:|create| IL:MENU - IL:TITLE IL:_ "BadList Items" - IL:ITEMS IL:_ (SLOT-VALUE SELF 'BAD-LIST))))) - (COND - (IL:|item| (SETF (SLOT-VALUE SELF 'BAD-LIST) - '(IL:DREMOVE IL:|item| (SLOT-VALUE SELF 'BAD-LIST))) - (RECOMPUTE SELF)) - (T (IL:CLRPROMPT) - (IL:PROMPTPRINT "Nothing Selected"))))))) - -(DEFMETHOD RENAME-NODE ((WEB-EDITOR WEB-EDITOR) - (WEB-NODE WEB-NODE) - NEW-NAME) - (SETF (NODE-NAME WEB-NODE) - NEW-NAME) - (CLEAR-LABEL-CACHE WEB-EDITOR WEB-NODE)) - - - -(IL:* IL:\; "") - - - - -(IL:* IL:\; "Window System Interface") - - -(DEFMETHOD UPDATE ((SELF WEB-EDITOR)) (IL:* IL:\; "29-Sep-86 11:56") - - (IL:* IL:|;;| "make the Lisp window be consistent with ivs") - - (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) - (REGION (AND (SLOT-VALUE SELF 'WIDTH) - (SLOT-VALUE SELF 'HEIGHT) - (IL:|create| IL:REGION - IL:LEFT IL:_ (OR (SLOT-VALUE SELF 'LEFT) - (SETF (SLOT-VALUE SELF 'LEFT) - IL:LASTMOUSEX)) - IL:BOTTOM IL:_ (OR (SLOT-VALUE SELF 'BOTTOM) - (SETF (SLOT-VALUE SELF 'BOTTOM) - IL:LASTMOUSEY)) - IL:WIDTH IL:_ (SLOT-VALUE SELF 'WIDTH) - IL:HEIGHT IL:_ (SLOT-VALUE SELF 'HEIGHT))))) - (COND - ((AND REGION (NOT (IL:EQUAL REGION (IL:WINDOWPROP WINDOW 'IL:REGION)))) - (IL:* IL:\; - "The shape has changed. --- This is complicated because of ATTACHEDWINDOWS.") - (LET* ((ATTACHED-WINDOWS (IL:WINDOWPROP WINDOW 'IL:ATTACHEDWINDOWS)) - (ATTACHMENT-SPECS (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS - IL:|collect| (LIST (IL:WINDOWPROP IL:\w - 'IL:DOWINDOWCOMFN) - (IL:WINDOWPROP IL:\w - 'IL:WHEREATTACHED) - (IL:WINDOWPROP IL:\w - 'IL:PASSTOMAINCOMS))))) - (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|do| (IL:DETACHWINDOW - IL:\w)) - (IL:SHAPEW WINDOW REGION) - (IL:|for| IL:\w IL:|in| ATTACHED-WINDOWS IL:|as| IL:|spec| - IL:|in| ATTACHMENT-SPECS IL:|do| (IL:ATTACHWINDOW IL:\w WINDOW - (CAADR IL:|spec|) - (CDADR IL:|spec|)) - (IL:WINDOWPROP IL:\w 'IL:DOWINDOWCOMFN - (CAR IL:|spec|)) - (IL:WINDOWPROP IL:\w 'IL:PASSTOMAINCOMS - (CADDR IL:|spec|)))))) - (AND (NOT (IL:EQUAL (SLOT-VALUE SELF 'TITLE) - (IL:WINDOWPROP WINDOW 'IL:TITLE))) - (IL:WINDOWPROP WINDOW 'IL:TITLE (SLOT-VALUE SELF 'TITLE))))) - -(DEFMETHOD CREATE-WINDOW ((SELF WEB-EDITOR)) (IL:* IL:\; "10-Apr-86 14:32") - (IL:* IL:\; - "Create the Lisp window for this window but don't open it.") - (LET ((WINDOW (IL:CREATEW (IL:CREATEREGION IL:LASTMOUSEX IL:LASTMOUSEY 25 25) - (SLOT-VALUE SELF 'TITLE) - NIL T))) - (SETF (SLOT-VALUE SELF 'WINDOW) - WINDOW) - (SETUP-WINDOW SELF) - WINDOW)) - -(DEFMETHOD SETUP-WINDOW ((SELF WEB-EDITOR)) (IL:* IL:\; "10-Apr-86 14:32") - (IL:* IL:\; - "Create the Lisp window for this window but don't open it.") - (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW))) - (IL:WINDOWPROP WINDOW 'WEB-EDITOR SELF) - (IL:WINDOWPROP WINDOW 'IL:ICONFN 'WEB-WINDOW-ICON-FN) - (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'WEB-WINDOW-BUTTON-EVENT-FN) - (IL:WINDOWADDPROP WINDOW 'IL:AFTERMOVEFN 'WEB-WINDOW-AFTER-MOVE-FN) - (IL:WINDOWADDPROP WINDOW 'IL:RESHAPEFN 'WEB-WINDOW-RESHAPE-FN) - (IL:WINDOWADDPROP WINDOW 'IL:CLOSEFN 'WEB-WINDOW-CLOSE-FN) - (IL:WINDOWPROP WINDOW 'IL:ICONFN 'WEB-WINDOW-ICON-FN)(IL:* IL:\; - "window should be invert so that links etc. can be erased") - (IL:DSPOPERATION 'IL:INVERT WINDOW) (IL:* IL:\; - "kludge: because GRAPHER adds its own COPYBUTTONEVENTFN") - (IL:WINDOWPROP WINDOW 'IL:COPYBUTTONEVENTFN NIL) - (IL:WINDOWPROP WINDOW 'IL:TITLE (SLOT-VALUE SELF 'TITLE)) - WINDOW)) - -(DEFMETHOD DETACH-LISP-WINDOW ((SELF WEB-EDITOR)) (IL:* IL:\; " 8-Apr-87 17:25") - -(IL:* IL:|;;;| "Forget about the current lisp window") - - (LET ((VAL (SLOT-VALUE SELF 'WINDOW))) - (IL:|if| (IL:WINDOWP VAL) - IL:|then| (SETF (SLOT-VALUE SELF 'WINDOW) - NIL) - (IL:WINDOWPROP VAL 'WEB-EDITOR NIL) - (IL:WINDOWPROP VAL 'IL:RIGHTBUTTONFN NIL) - (IL:WINDOWPROP VAL 'IL:BUTTONEVENTFN NIL) - NIL - IL:|else| NIL))) - -(DEFMETHOD SHRINK ((SELF WEB-EDITOR) - &OPTIONAL TOWHAT POS EXPANDFN) - (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW))) - (IF (IL:WINDOWP WINDOW) - (IL:SHRINKW WINDOW TOWHAT POS EXPANDFN)))) - -(DEFMETHOD SET-OUTER-REGION ((SELF WEB-EDITOR) - REGION NO-UPDATE-FLG) (IL:* IL:\; "16-Apr-86 13:21") - -(IL:* IL:|;;;| "Make Loops Window have region parameters") - - (SETF (SLOT-VALUE SELF 'LEFT) - (IL:|fetch| IL:LEFT IL:|of| REGION)) - (SETF (SLOT-VALUE SELF 'BOTTOM) - (IL:|fetch| IL:BOTTOM IL:|of| REGION)) - (SETF (SLOT-VALUE SELF 'WIDTH) - (IL:|fetch| IL:WIDTH IL:|of| REGION)) - (SETF (SLOT-VALUE SELF 'HEIGHT) - (IL:|fetch| IL:HEIGHT IL:|of| REGION)) - (IL:|if| (NOT NO-UPDATE-FLG) - IL:|then| (UPDATE SELF)) - REGION) - -(DEFMETHOD SET-REGION ((SELF WEB-EDITOR) - REGION &OPTIONAL NO-UPDATE-FLG) (IL:* IL:\; "16-Apr-86 13:22") - -(IL:* IL:|;;;| "Make Loops Window have region parameters") - - (SET-OUTER-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION) - (IL:|fetch| IL:BOTTOM IL:|of| REGION) - (IL:WIDTHIFWINDOW (IL:|fetch| IL:WIDTH IL:|of| REGION) - (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) - 'IL:BORDER)) - (IL:HEIGHTIFWINDOW (IL:|fetch| IL:HEIGHT IL:|of| REGION) - (SLOT-VALUE SELF 'TITLE) - (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) - 'IL:BORDER))) - NO-UPDATE-FLG)) - -(DEFMETHOD MOVE ((SELF WEB-EDITOR) - X-OR-POS &OPTIONAL Y) (IL:* IL:\; "11-Sep-86 13:24") - -(IL:* IL:|;;;| "Move the window") - - (MOVE1 SELF (OR X-OR-POS (LET* ((ENTIRE-REGION (IL:WINDOWREGION (SLOT-VALUE SELF 'WINDOW))) - (POS (IL:GETBOXPOSITION (IL:|fetch| IL:WIDTH IL:|of| - ENTIRE-REGION) - (IL:|fetch| IL:HEIGHT IL:|of| ENTIRE-REGION) - (IL:|fetch| IL:LEFT IL:|of| ENTIRE-REGION) - (IL:|fetch| IL:BOTTOM IL:|of| ENTIRE-REGION))) - ) - (IL:|create| IL:POSITION - IL:XCOORD IL:_ (IL:PLUS (IL:|fetch| IL:XCOORD - IL:|of| POS) - (IL:DIFFERENCE (SLOT-VALUE - SELF - 'LEFT) - (IL:|fetch| IL:LEFT - IL:|of| ENTIRE-REGION))) - IL:YCOORD IL:_ (IL:PLUS (IL:|fetch| IL:YCOORD - IL:|of| POS) - (IL:DIFFERENCE (SLOT-VALUE - SELF - 'BOTTOM) - (IL:|fetch| IL:BOTTOM - IL:|of| ENTIRE-REGION))) - ))) - Y)) - -(DEFMETHOD MOVE1 ((SELF WEB-EDITOR) - X-OR-POS &OPTIONAL Y) (IL:* IL:\; "13-Aug-86 19:10") - - (IL:* IL:|;;| "Move the window") - - (LET ((NEEDS-UPDATE? (NOT (IL:SUBREGIONP (IL:CONSTANT (IL:CREATEREGION 0 0 IL:SCREENWIDTH - IL:SCREENHEIGHT)) - (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) - 'IL:REGION))))) - (PROG1 (IL:MOVEW (SLOT-VALUE SELF 'WINDOW) - X-OR-POS Y) (IL:* IL:\; - "The left and right IVs are updated by the message AfterMove") - (COND - (NEEDS-UPDATE? (UPDATE SELF)))))) - -(DEFMETHOD AFTER-MOVE ((SELF WEB-EDITOR)) (IL:* IL:\; "10-Apr-86 16:10") - -(IL:* IL:|;;;| "The window has been moved. Update the left and bottom") - - (LET ((REGION (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) - 'IL:REGION))) - (SETF (SLOT-VALUE SELF 'LEFT) - (IL:|fetch| IL:LEFT IL:|of| REGION)) - (SETF (SLOT-VALUE SELF 'BOTTOM) - (IL:|fetch| IL:BOTTOM IL:|of| REGION)))) - -(DEFMETHOD AFTER-RESHAPE ((SELF WEB-EDITOR) - OLD-BITMAP-IMAGE OLD-REGION OLD-SCREEN-REGION) - (IL:* IL:\; "10-Apr-86 16:12") - -(IL:* IL:|;;;| "The window has been reshaped") - - (LET ((REGION (IL:WINDOWPROP (SLOT-VALUE SELF 'WINDOW) - 'IL:REGION))) - (SETF (SLOT-VALUE SELF 'LEFT) - (IL:|fetch| IL:LEFT IL:|of| REGION)) - (SETF (SLOT-VALUE SELF 'BOTTOM) - (IL:|fetch| IL:BOTTOM IL:|of| REGION)) - (SETF (SLOT-VALUE SELF 'WIDTH) - (IL:|fetch| IL:WIDTH IL:|of| REGION)) - (SETF (SLOT-VALUE SELF 'HEIGHT) - (IL:|fetch| IL:HEIGHT IL:|of| REGION)) - (IL:RESHAPEBYREPAINTFN (SLOT-VALUE SELF 'WINDOW) - OLD-BITMAP-IMAGE OLD-REGION OLD-SCREEN-REGION))) - -(DEFMETHOD SCROLL-WINDOW ((SELF WEB-EDITOR) - DSP-X DSP-Y WINDOW-X WINDOW-Y) (IL:* IL:\; "10-Apr-86 14:58") - -(IL:* IL:|;;;| "scroll the window to set the point dspX,dspY in the given window position -- default is the lower left corner. If any x or y is a FIXP, it is treated as a absolute position. If FLOATP, it is treated as a relative position. Return the position of the new lower left corner.") - - (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) - (VISIBLE-REGION (IL:DSPCLIPPINGREGION NIL WINDOW)) - (EXTENT (IL:WINDOWPROP WINDOW 'IL:EXTENT))) (IL:* IL:\; - "figure out what to do with default and relative offsets") - (IL:SETQ WINDOW-X (IL:|if| (NULL WINDOW-X) - IL:|then| 0 - IL:|elseif| (IL:FLOATP WINDOW-X) - IL:|then| (IL:FIX (IL:TIMES WINDOW-X (IL:WINDOWPROP WINDOW - 'IL:WIDTH))) - IL:|else| WINDOW-X)) - (IL:SETQ WINDOW-Y (IL:|if| (NULL WINDOW-Y) - IL:|then| 0 - IL:|elseif| (IL:FLOATP WINDOW-Y) - IL:|then| (IL:FIX (IL:TIMES WINDOW-Y (IL:WINDOWPROP WINDOW - 'IL:HEIGHT))) - IL:|else| WINDOW-Y)) - (IL:SETQ DSP-X (IL:|if| (NULL DSP-X) - IL:|then| (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION) - IL:|elseif| (IL:FLOATP DSP-X) - IL:|then| (IL:FIX (IL:TIMES DSP-X (IL:|fetch| IL:WIDTH - IL:|of| EXTENT))) - IL:|else| DSP-X)) - (IL:SETQ DSP-Y (IL:|if| (NULL DSP-Y) - IL:|then| (IL:IMINUS (IL:|fetch| IL:BOTTOM IL:|of| - VISIBLE-REGION)) - IL:|elseif| (IL:FLOATP DSP-Y) - IL:|then| (IL:FIX (IL:TIMES DSP-Y (IL:|fetch| IL:HEIGHT - IL:|of| EXTENT))) - IL:|else| DSP-Y)) - (IL:SCROLLW WINDOW (IL:IPLUS WINDOW-X (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of| - VISIBLE-REGION - ) - DSP-X)) - (IL:IPLUS WINDOW-Y (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| - VISIBLE-REGION) - DSP-Y))) (IL:* IL:\; - "return the resulting position") - (IL:SETQ VISIBLE-REGION (IL:DSPCLIPPINGREGION NIL WINDOW)) - (IL:|create| IL:POSITION - IL:XCOORD IL:_ (IL:|fetch| IL:LEFT IL:|of| VISIBLE-REGION) - IL:YCOORD IL:_ (IL:|fetch| IL:BOTTOM IL:|of| VISIBLE-REGION)))) - -(DEFMETHOD CLEAR ((SELF WEB-EDITOR)) (IL:* IL:\; - "empty the window of active regions, return the window") - (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW))) - (IL:WINDOWPROP WINDOW 'IL:GRAPH NIL) - (IL:CLEARW WINDOW) - WINDOW)) - -(DEFMETHOD GET-PROMPT-WINDOW ((SELF WEB-EDITOR) - &OPTIONAL LINES FONT-DEF) (IL:* IL:\; " 8-Apr-87 15:43") - - (IL:* IL:|;;| "Return the current prompt window") - - (LET ((W (IL:GETPROMPTWINDOW (SLOT-VALUE SELF 'WINDOW) - (OR LINES 2) - (OR (IL:FONTCREATE FONT-DEF))))) - (IF FONT-DEF - (IL:DSPFONT (IL:FONTCREATE FONT-DEF) - W)) - W)) - -(DEFMETHOD REMOVE-PROMPT-WINDOW ((SELF WEB-EDITOR)) (IL:* IL:\; " 8-Apr-87 15:43") - (IL:REMOVEPROMPTWINDOW (SLOT-VALUE SELF 'WINDOW))) - -(DEFMETHOD PROMPT-PRINT ((SELF WEB-EDITOR) - PROMPT) (IL:* IL:\; "13-Aug-86 18:46") - - (IL:* IL:|;;| "Prints out a prompt in an attached prompt window") - - (IL:PRIN1 PROMPT (GET-PROMPT-WINDOW SELF))) - -(DEFMETHOD PROMPT-READ ((SELF WEB-EDITOR) - MSG) (IL:* IL:\; "13-Aug-86 19:15") - - (IL:* IL:|;;| "Prompt the user for some input, using an attached prompt window") - - (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF))) - (IL:CLEARW P-WINDOW) - (PROG1 (IL:|PromptRead| MSG P-WINDOW T) - (IL:CLEARW P-WINDOW) - (IL:DETACHWINDOW P-WINDOW) - (IL:CLOSEW P-WINDOW)))) - -(DEFMETHOD PROMPT-FOR-LIST ((SELF WEB-EDITOR) - PROMPT-STR INITIAL-STRING) (IL:* IL:\; " 8-Apr-87 16:44") - -(IL:* IL:|;;;| "Prompt user in prompt window for a list of words.") - - (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF))) - (IL:RESETFORM (IL:TTYDISPLAYSTREAM P-WINDOW) - (IL:CLEARW P-WINDOW) - (IL:TTYIN PROMPT-STR NIL NIL '(IL:NORAISE) - NIL NIL INITIAL-STRING)))) - -(DEFMETHOD PROMPT-FOR-STRING ((SELF WEB-EDITOR) - PROMPT-STR INITIAL-STR) (IL:* IL:\; "13-Aug-86 18:42") - -(IL:* IL:|;;;| "Prompt user in prompt window for a string.") - - (LET ((P-WINDOW (GET-PROMPT-WINDOW SELF)) - VALUE) - (IL:RESETFORM (IL:TTYDISPLAYSTREAM P-WINDOW) - (IL:CLEARW P-WINDOW) - (SETQ VALUE (IL:TTYIN PROMPT-STR NIL NIL '(STRING IL:NORAISE) - NIL NIL INITIAL-STR)) - (IL:CLEARW P-WINDOW)) - (REMOVE-PROMPT-WINDOW SELF) - VALUE)) - -(DEFMETHOD PROMPT-FOR-WORD ((SELF WEB-EDITOR) - &OPTIONAL PROMPT-STR INITIAL-WORD) - (IL:* IL:\; " 8-Apr-87 16:43") - -(IL:* IL:|;;;| "Prompt user in prompt window for a word.") - - (CAR (PROMPT-FOR-LIST SELF PROMPT-STR INITIAL-WORD))) - -(DEFMACRO MOVE-DOWN-P () - '(OR (IL:KEYDOWNP 'IL:MOVE) - (IL:SHIFTDOWNP 'IL:CTRL))) -(IL:DEFINEQ - -(WEB-WINDOW-AFTER-MOVE-FN - (LAMBDA (WINDOW) (IL:* IL:\; "Edited 13-Jul-87 15:59 by Rao") - (IL:* IL:\; "10-Apr-86 16:16") - -(IL:* IL:|;;;| "The SimpleWindow AFTERMOVEFN") - - (LET ((W (IL:WINDOWPROP WINDOW 'WEB-EDITOR))) - (AND W (AFTER-MOVE W))))) - -(WEB-WINDOW-BUTTON-EVENT-FN - (LAMBDA (WINDOW) (IL:* IL:\; "Edited 13-Jul-87 13:38 by Rao") - (IL:* IL:\; "11-Sep-86 13:50") - (LET ((WINDOW-FOR-MENU (IL:WINDOWPROP WINDOW 'WEB-EDITOR))) - (DECLARE (IL:SPECVARS WINDOW-FOR-MENU)) - (IL:TOTOPW WINDOW) - (BUTTON-EVENT-FN WINDOW-FOR-MENU)))) - -(WEB-WINDOW-RESHAPE-FN - (LAMBDA (WINDOW IL:|oldBitmapImage| IL:|oldRegion| IL:|oldScreenRegion|) - (IL:* IL:\; "Edited 12-Jun-87 15:56 by Rao") - (IL:* IL:\; " 9-May-86 10:07") - -(IL:* IL:|;;;| "The RESHAPEFN for a Window") - - (LET ((IL:\w (IL:WINDOWPROP WINDOW 'WEB-EDITOR))) - (AND IL:\w (AFTER-RESHAPE IL:\w IL:|oldBitmapImage| IL:|oldRegion| IL:|oldScreenRegion| - ))))) - -(WEB-WINDOW-CLOSE-FN - (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 12-Jun-87 11:42 by Rao") - (IL:* IL:\; - "Remove link back to LoopsWindow") - (IL:WINDOWPROP WINDOW 'WEB-EDITOR NIL))) - -(IL:|PromptRead| - (IL:LAMBDA (PROMPT-STRING WINDOW SAME-LINE?) (IL:* IL:\; "Edited 20-Jul-87 16:20 by Rao") - (IL:* IL:\; - "Printout promptString in promptwindow and return value of expression read there") - (PROG (NEWVALUE) - (IL:RESETLST - (IL:RESETSAVE (IL:TTYDISPLAYSTREAM (OR WINDOW IL:PROMPTWINDOW))) - (IL:RESETSAVE (IL:TTY.PROCESS (IL:THIS.PROCESS))) - (IL:CLRPROMPT) - (IL:RESETSAVE (IL:PRINTLEVEL 4 3)) - (IL:|printout| T PROMPT-STRING) - (IL:|if| SAME-LINE? - IL:|then| (IL:|printout| T "> ") - IL:|else| (IL:|printout| T T "> ")) - (IL:CLEARBUF T T) (IL:* IL:\; - "clear tty buffer because it sometimes has stuff left.") - (IL:ALLOW.BUTTON.EVENTS) - (IL:SETQ NEWVALUE (CAR (IL:ERSETQ (IL:TTYINREAD T T))))) - (RETURN NEWVALUE)))) -) -(IL:DEFINEQ - -(WEB-WINDOW-EXPAND-FN - (LAMBDA (WINDOW) (IL:* IL:\; "Edited 13-Nov-87 12:58 by Rao") - (IL:* IL:\; "19-Feb-85 13:58") - - (IL:* IL:|;;| "When a browser window is expanded, it should be recomputed") - - (LET ((SELF (IL:WINDOWPROP WINDOW 'WEB-EDITOR))) - (RECOMPUTE-IN-PLACE SELF)))) -) - -(DEFUN WEB-WINDOW-ICON-FN (WINDOW ICON DUMMY) - (LET NIL (OR ICON (IL:TITLEDICONW *WEB-EDITOR-TEMPLATE* (ICON-TITLE (IL:WINDOWPROP WINDOW - 'WEB-EDITOR)) - NIL - '(0 . 0) - T - 'IL:BOTTOM - (IL:CONSTANT (LIST (IL:CHARCODE "-") - (IL:CHARCODE IL:SPACE) - (IL:CHARCODE IL:EOL))))))) - -(IL:RPAQQ *WEB-EDITOR-ICON-BM* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@L@@@@@@@@@@AL@@@L@@@@@@@@@@AF@@@L@@@@@@@@@@AC@@@L@@@@@@@@@@AAH@@L@@@@@@@@@@A@L@@L@@@@@@@@@@A@F@@LOON@@@@@@OO@C@@LOON@@@@@@OO@AH@LOOO@@@@@@OO@@L@LOONH@@@@AOO@@F@LOOND@@@@BOOOOO@L@@@B@@@@DOOOHC@L@@@ACOOLH@@@@C@L@@@@KOOM@@@@@C@L@@@@GOON@@@@@C@L@@@@KOOM@@@@@C@L@@@ACOOLH@@@@C@LOOOB@@@@DOOOHC@LOOOD@@@@BOOOHC@LOOOH@@@@AOOOHC@LOOOD@@@@@OOOHC@LOOOB@@@@@OOOHC@L@@@ACOOO@@@@@C@L@@@@KOOO@@@@@C@L@@@@GOOO@@@@@C@L@@@@COOO@@@@@C@L@@@@COOO@@@@@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@@@@@@@@@@@@@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@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@ -) - -(IL:RPAQQ *WEB-EDITOR-ICON-MASK* #*(60 75)OOOOOOOOOOOO@@@@OOOOOOOOOOOOH@@@OOOOOOOOOOOOL@@@OOOOOOOOOOOON@@@OOOOOOOOOOOOO@@@OOOOOOOOOOOOOH@@OOOOOOOOOOOOOL@@OOOOOOOOOOOOON@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOOH@OOOOOOOOOOOOOOL@OOOOOOOOOOOOOON@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@OOOOOOOOOOOOOOO@ -) - -(DEFVAR *WEB-EDITOR-TEMPLATE* (IL:|create| IL:TITLEDICON - IL:ICON IL:_ *WEB-EDITOR-ICON-BM* - IL:MASK IL:_ *WEB-EDITOR-ICON-MASK* - IL:TITLEREG IL:_ (IL:CREATEREGION 5 2 50 30))) - -(IL:RPAQ IL:*D-WINDOW-DEFAULT-STREAM* IL:PROMPTWINDOW) - -(IL:RPAQ WEB-STREAM IL:PROMPTWINDOW) - - - -(IL:* IL:\; "Layout and Display Engine") - - -(IL:RPAQQ IL:|BrowserMargin| 0) - -(IL:RPAQQ IL:|MaxLatticeHeight| 750) - -(IL:RPAQQ IL:|MaxLatticeWidth| 900) -(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY - -(IL:SPECVARS IL:|MaxLatticeHeight| IL:|MaxLatticeWidth|) -) - -(IL:RPAQQ IL:GRAYSHADE1 1) - -(IL:RPAQQ IL:GRAYSHADE2 1025) - -(IL:RPAQQ IL:GRAYSHADE3 64510) - -(IL:RPAQQ IL:GRAYSHADE4 65534) -(IL:DEFINEQ - -(TREE-ROOTS - (IL:LAMBDA (NODE-LST) (IL:* IL:\; "Edited 10-Jul-87 19:22 by Rao") - (IL:* IL:\; "29-Sep-86 19:46") - - (IL:* IL:|;;| "Computes a minimal set of root nodes for a lattice --- those with no connections TO them in list of nodes, or a single node from a cycle of nodes.") - - (PROG ((ROOT-NODES (IL:LDIFFERENCE NODE-LST (IL:|for| IL:|node| IL:|in| NODE-LST - IL:|join| (CHILD-NODES IL:|node| NODE-LST) - ))) - REACHABLE-NODES NOT-REACHABLE-NODES) - (SETQ REACHABLE-NODES (IL:COPY ROOT-NODES)) - (SETQ NOT-REACHABLE-NODES (IL:LDIFFERENCE NODE-LST REACHABLE-NODES)) - (IL:* IL:\; - "recompute the nodes that can't be reached from the current rootNodes") - IL:|RecomputeReachableNodes| - - - (IL:* IL:|;;| "Compute the transitive closure of the set of reachableNodes --- updating the notReachableNodes at the same time") - - (IL:|for| IL:|node| IL:|in| REACHABLE-NODES - IL:|do| (IL:|for| IL:|childNode| IL:|in| (CHILD-NODES IL:|node| NODE-LST - ) - IL:|when| (IL:MEMB IL:|childNode| NOT-REACHABLE-NODES) - IL:|do| - - (IL:* IL:|;;| "put the newly found reachable node at the end of the list, so we will find it later on during this iteration") - - (IL:NCONC1 REACHABLE-NODES IL:|childNode|) - (SETQ NOT-REACHABLE-NODES (IL:DREMOVE IL:|childNode| - NOT-REACHABLE-NODES)))) - (IL:* IL:\; - "if we can reach all the nodes, fine...") - (IL:|if| (NULL NOT-REACHABLE-NODES) - IL:|then| (IL:* IL:\; - "Now need to prune down to a minimal set") - (IL:|bind| (IL:|stable?| IL:_ NIL) IL:|until| IL:|stable?| - IL:|do| (SETQ IL:|stable?| T) - (IL:|for| IL:|node| IL:|in| ROOT-NODES IL:|bind| - IL:|extraRoots| - IL:|do| (SETQ IL:|extraRoots| (IL:DREMOVE IL:|node| - (IL:INTERSECTION - ROOT-NODES - (REACHABLE-NODES! - IL:|node| NODE-LST)))) - (IL:|if| IL:|extraRoots| - IL:|then| (SETQ IL:|stable?| NIL) - (SETQ ROOT-NODES (IL:LDIFFERENCE ROOT-NODES - IL:|extraRoots|)) - (RETURN T)) IL:|finally| (RETURN NIL))) - (IL:* IL:\; - "return the node ids, not the GRAPHNODES") - (RETURN (IL:|for| IL:|node| IL:|in| ROOT-NODES - IL:|collect| (IL:|fetch| IL:NODEID IL:|of| IL:|node|))) - IL:|else| (IL:* IL:\; - "must be a cycle. Select the least prolific node in the cycle as the a new root node.") - (IL:|push| ROOT-NODES (LET ((PROLIFIC-NODE (IL:|for| IL:|node| IL:|in| - - NOT-REACHABLE-NODES - IL:|smallest| - (IL:LENGTH (IL:|fetch| - IL:TONODES - IL:|of| - IL:|node|)))) - ) - (SETQ NOT-REACHABLE-NODES (IL:DREMOVE PROLIFIC-NODE - NOT-REACHABLE-NODES - )) - PROLIFIC-NODE)) - (GO IL:|RecomputeReachableNodes|))))) - -(CHILD-NODES - (IL:LAMBDA (PARENT-NODE NODE-LIST) (IL:* IL:\; "Edited 10-Jul-87 19:23 by Rao") - (IL:* IL:\; " 8-Oct-85 14:15") - (IL:* IL:\; - "Find all GRAPHNODES that are immediatly reachable from this node") - (IL:|for| IL:|label| IL:|in| (IL:|fetch| IL:TONODES IL:|of| PARENT-NODE) - IL:|collect| (IL:|for| IL:|node| IL:|in| NODE-LIST - IL:|thereis| (EQ IL:|label| (IL:|fetch| IL:NODEID IL:|of| - IL:|node|)))))) - -(REACHABLE-NODES! - (IL:LAMBDA (IL:|root| IL:|nodeList|) (IL:* IL:\; "30-Sep-86 10:22") - (IL:* IL:\; IL:|Return| IL:\a - IL:|list| IL:|of| IL:|all| - IL:|nodes| IL:|that| IL:|are| - IL:|reachable| IL:|from| IL:|the| - IL:|root|) - (LET ((IL:|reachableNodes| (LIST IL:|root|))) - (IL:|for| IL:|node| IL:|in| IL:|reachableNodes| - IL:|do| (IL:|for| IL:|childNode| IL:|in| (CHILD-NODES IL:|node| - IL:|nodeList|) - IL:|when| (NOT (IL:MEMB IL:|childNode| IL:|reachableNodes|)) - IL:|do| - - (IL:* IL:\; IL:|put| IL:|the| IL:|newly| IL:|found| IL:|reachable| IL:|node| - IL:|at| IL:|the| IL:|end| IL:|of| IL:|the| IL:|list,| IL:|so| IL:|we| IL:|will| - IL:|find| IL:|it| IL:|later| IL:|on| IL:|during| IL:|this| IL:|iteration|) - - (IL:NCONC1 IL:|reachableNodes| IL:|childNode|))) - IL:|reachableNodes|))) -) - -(DEFMETHOD DISPLAY-BROWSER ((SELF WEB-EDITOR)) (IL:* IL:\; "29-Sep-86 12:15") - (IL:* IL:\; "New method template") - (LET ((NODELST (AND (SLOT-VALUE SELF 'STARTING-LIST) - (GET-NODE-LIST SELF (SLOT-VALUE SELF 'STARTING-LIST) - (SLOT-VALUE SELF 'GOOD-LIST))))) - (COND - (NODELST (IL:SHOWGRAPH (IL:LAYOUTGRAPH NODELST (TREE-ROOTS NODELST) - (SLOT-VALUE SELF 'GRAPH-FORMAT) - (SLOT-VALUE SELF 'BROWSE-FONT)) - (SLOT-VALUE SELF 'WINDOW) - NIL NIL (SLOT-VALUE SELF 'TOP-ALIGN)) - (IL:* IL:\; - "kludge to reset the window props") - (SETUP-WINDOW SELF)) - (T (CLEAR SELF))))) - -(DEFMETHOD BROWSER-OBJECTS ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "28-May-84 12:58") - (IL:* IL:\; - "Return a list of all the objects shown in the browser") - (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES - IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| - 'WINDOW) - 'IL:GRAPH)) - IL:|when| (IL:NLISTP (CAR IL:|node|)) IL:|collect| (CAR IL:|node|))) - -(DEFMETHOD GET-NODE-LIST ((SELF WEB-EDITOR) - BROWSE-LIST GOOD-LIST) (IL:* IL:\; "21-Mar-85 14:09") - - (IL:* IL:|;;| "Compute the node data structures of the tree starting at browseList. If goodList is given, only include elements of it. If goodList=T make it be browseList.") - - (DECLARE (IL:GLOBALVARS IL:WHITESHADE)) - (COND - ((EQ GOOD-LIST T) - (IL:SETQ GOOD-LIST BROWSE-LIST))) - (PROG (SUBS PAIR NODE (OLD-NODES (IL:|fetch| IL:GRAPHNODES IL:|of| - (IL:WINDOWPROP (SLOT-VALUE - SELF - 'WINDOW) - 'IL:GRAPH))) - (OBJ-LIST (CONS))) - - (IL:* IL:|;;| "first make objList which is a list of pairs (object . objName). objName will be used as a title for a node in the browser. This structure will be replaced by a graphNode when it is processed. The nodeID of the graphNode will be the object, and the label will be the name.") - - (IL:|for| IL:|objOrName| IL:|in| BROWSE-LIST - IL:|do| (AND (IL:SETQ PAIR (OBJ-NAME-PAIR SELF IL:|objOrName|)) - (NOT (IL:FASSOC (CAR PAIR) - (CAR OBJ-LIST))) - (IL:TCONC OBJ-LIST PAIR))) - - (IL:* IL:|;;| "Now MAP ON list so pair can be replaced by graphNode") - - (IL:|for| PAIR IL:|name| IL:|obj| IL:|subObjs| IL:|on| (CAR OBJ-LIST) - IL:|when| (IL:NLISTP (IL:SETQ IL:|name| (CDAR PAIR))) - IL:|do| (IL:SETQ IL:|subObjs| (CONS)) - (IL:|for| IL:|sub| IL:|objPair| IL:|obj1| IL:|in| (GET-SUBS SELF - (IL:SETQ IL:|obj| - (CAAR PAIR))) - IL:|do| - - (IL:* IL:|;;| "ObjNamePair returns NIL for destroyed objects. include only members of goodList in subs if given. Add to objList only once") - - (IL:SETQ IL:|obj1| (COND - ((EQ (CAR IL:|sub|) - 'IL:|Link Parameters|) - (CADR IL:|sub|)) - (T IL:|sub|))) - (COND - ((IL:SETQ IL:|objPair| (OBJ-NAME-PAIR SELF IL:|obj1|)) - (COND - ((NOT (IL:FASSOC IL:|obj1| (CAR OBJ-LIST))) - (IL:TCONC OBJ-LIST IL:|objPair|))) - (IL:TCONC IL:|subObjs| IL:|sub|)))) - (RPLACA PAIR (IL:SETQ NODE (OR (IL:FASSOC IL:|obj| OLD-NODES) - (IL:|create| IL:GRAPHNODE - IL:NODEID IL:_ IL:|obj| - IL:NODEBORDER IL:_ - (LIST (IL:ADD1 (SLOT-VALUE SELF - 'BOX-LINE-WIDTH)) - IL:WHITESHADE))))) - (IL:|replace| IL:TONODES IL:|of| NODE IL:|with| (CAR IL:|subObjs|)) - (IL:|replace| IL:NODELABEL IL:|of| NODE IL:|with| IL:|name|) - (IL:|replace| IL:NODEFONT IL:|of| NODE IL:|with| (SLOT-VALUE - SELF - 'BROWSE-FONT)) - (IL:|replace| IL:NODEWIDTH IL:|of| NODE IL:|with| NIL) - (IL:|replace| IL:NODEHEIGHT IL:|of| NODE IL:|with| NIL)) - (RETURN (CAR OBJ-LIST)))) - -(DEFMETHOD OBJ-NAME-PAIR ((IL:|self| WEB-EDITOR) - IL:|obj|) - - (IL:* IL:|;;| "Make a pair (object . objName) where objName is label to be used in browser") - - (LET NIL (IL:|if| (NULL IL:|obj|) - IL:|then| NIL - IL:|elseif| (AND (SLOT-VALUE IL:|self| 'GOOD-LIST) - (NOT (IL:FMEMB IL:|obj| (SLOT-VALUE IL:|self| 'GOOD-LIST)))) - IL:|then| NIL - IL:|elseif| (IL:FMEMB IL:|obj| (SLOT-VALUE IL:|self| 'BAD-LIST)) - IL:|then| NIL - IL:|else| (CONS IL:|obj| (GET-DISPLAY-LABEL IL:|self| IL:|obj|))))) - -(DEFMETHOD GRAPH-FITS ((|self| WEB-EDITOR)) (IL:* IL:\; "24-Apr-86 15:00") - -(IL:* IL:|;;;| "Tests if graph fits in region") - - (LET ((|window| (SLOT-VALUE |self| 'WINDOW))) - (LET ((|width| 0) - (|height| 0) - (|region| (IL:WINDOWPROP |window| 'IL:REGION)) - (|nodes| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP |window| 'IL:GRAPH))) - ) - (COND - (|nodes| (IL:SETQ |width| (IL:WIDTHIFWINDOW (IL:IDIFFERENCE (IL:MAX/RIGHT |nodes|) - (IL:MIN/LEFT |nodes|)) - (IL:WINDOWPROP |window| 'IL:BORDER))) - (IL:SETQ |height| (IL:HEIGHTIFWINDOW (IL:IDIFFERENCE (IL:MAX/TOP |nodes|) - (IL:MIN/BOTTOM |nodes|)) - (IL:WINDOWPROP |window| 'IL:TITLE) - (IL:WINDOWPROP |window| 'IL:BORDER))))) - (NOT (OR (IL:IGREATERP |width| (IL:|fetch| IL:WIDTH IL:|of| |region|)) - (IL:IGREATERP |height| (IL:|fetch| IL:HEIGHT IL:|of| |region|))))))) - -(DEFMETHOD NODE-REGION ((IL:|self| WEB-EDITOR) - IL:|object|) (IL:* IL:\; "10-Dec-84 18:26") - - (IL:* IL:|;;| "what region does the object occupy in the display stream?") - - (LET ((IL:|node| (IL:FASSOC (COND - ((IL:LITATOM IL:|object|) - (IL:SETQ IL:|object| (IL:|GetObjectRec| IL:|object|))) - (T IL:|object|)) - (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP - (SLOT-VALUE IL:|self| - 'WINDOW) - 'IL:GRAPH))))) - (IL:|if| IL:|node| - IL:|then| (IL:|create| IL:REGION - IL:LEFT IL:_ (IL:IDIFFERENCE (IL:|fetch| IL:XCOORD - IL:|of| (IL:|fetch| - IL:NODEPOSITION - IL:|of| IL:|node| - )) - (IL:IQUOTIENT (IL:|fetch| IL:NODEWIDTH - IL:|of| IL:|node|) - 2)) - IL:BOTTOM IL:_ (IL:IDIFFERENCE (IL:|fetch| IL:YCOORD - IL:|of| (IL:|fetch| - IL:NODEPOSITION - IL:|of| - IL:|node|)) - (IL:IQUOTIENT (IL:|fetch| IL:NODEHEIGHT - IL:|of| IL:|node|) - 2)) - IL:WIDTH IL:_ (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|) - IL:HEIGHT IL:_ (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|)) - ))) - -(DEFMETHOD RECOMPUTE ((SELF WEB-EDITOR) - &OPTIONAL DONT-RESHAPE-FLG) (IL:* IL:\; " 8-Apr-87 14:42") - (IL:* IL:\; - "Recompute the browseGraph in the same window") - (PROG ((GRAPH-FITS (GRAPH-FITS SELF))) - (DISPLAY-BROWSER SELF) - (COND - ((OR DONT-RESHAPE-FLG (NULL GRAPH-FITS)) (IL:* IL:\; - "Dont Reshape or rescroll. Assume window wants to stay the same size") - ) - (T (SHAPE-TO-HOLD SELF)))) - SELF) - -(DEFMETHOD RECOMPUTE-IN-PLACE ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "10-Dec-84 18:27") - -(IL:* IL:|;;;| "recompute the graph, maintaining the current position") - - (LET* ((IL:|visibleRegion| (IL:DSPCLIPPINGREGION NIL (SLOT-VALUE IL:|self| 'WINDOW))) - (IL:\x (IL:|fetch| IL:LEFT IL:|of| IL:|visibleRegion|)) - (IL:\y (IL:|fetch| IL:BOTTOM IL:|of| IL:|visibleRegion|))) - (IL:* IL:\; - "if we want to RecomputeInPlace, we must want the window to be kept the same") - (RECOMPUTE IL:|self| T) (IL:* IL:\; - "we had to save x and y because visibleRegion gets clobbered by Recompute! Suprise!") - (SCROLL-WINDOW IL:|self| IL:\x IL:\y))) - -(DEFMETHOD RECOMPUTE-LABELS ((|self| WEB-EDITOR)) (IL:* IL:\; "27-Feb-85 11:27") - (IL:* IL:\; - "recompute the graph, including the labels") - (CLEAR-LABEL-CACHE |self| T) - (RECOMPUTE |self|)) - -(DEFMETHOD RECOMPUTE-IF-OPEN ((WEB-EDITOR WEB-EDITOR)) (IL:* IL:\; "27-Aug-86 12:37") - (IF (IL:OPENWP (SLOT-VALUE WEB-EDITOR 'WINDOW)) - (RECOMPUTE WEB-EDITOR))) - -(DEFMETHOD CLEAR-LABEL-CACHE ((WEB-EDITOR WEB-EDITOR) - OBJECTS) (IL:* IL:\; " 5-Dec-85 12:02") - (LET (CACHED-LABEL) - - (IL:* IL:|;;| "Delete the cached label for these items") - - (COND - ((EQ OBJECTS T) - (SETF (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE) - NIL)) - (T (IF (ATOM OBJECTS) - (SETQ OBJECTS (CONS OBJECTS))) - (DOLIST (OBJ OBJECTS) - (IF (SETQ CACHED-LABEL (IL:ASSOC OBJ (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE))) - (SETF (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE) - (IL:DREMOVE CACHED-LABEL (SLOT-VALUE WEB-EDITOR 'LABEL-CACHE))))))))) - -(DEFMETHOD OBJECT-FROM-LABEL ((SELF WEB-EDITOR) - LABEL) (IL:* IL:\; " 4-Jan-85 18:20") - - (IL:* IL:|;;| "What object has this label?") - - (LET ((OBJECT-NODE (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES - IL:|of| (IL:WINDOWPROP - (SLOT-VALUE SELF - 'WINDOW) - 'IL:GRAPH)) - IL:|thereis| (IL:EQUAL LABEL (IL:|fetch| IL:NODELABEL IL:|of| - IL:|node|))))) - (IL:|if| (IL:NLISTP (CAR OBJECT-NODE)) - IL:|then| (CAR OBJECT-NODE) - IL:|else| NIL))) - -(DEFMETHOD CHANGE-FONT-SIZE ((WEB-EDITOR WEB-EDITOR) - &OPTIONAL SIZE) (IL:* IL:\; "13-Dec-84 13:04") - (IL:* IL:\; - "Change the font size from whatever it is to size") - (WHEN (OR SIZE (SETQ SIZE (IL:MENU (IL:|create| IL:MENU - IL:TITLE IL:_ "Select Desired Size" - IL:CHANGEOFFSETFLG IL:_ T - IL:ITEMS IL:_ '(("Abort" NIL) - 8 10 12 16))))) - (SETF (SLOT-VALUE WEB-EDITOR 'BROWSE-FONT) - (IL:FONTCREATE `(,(SLOT-VALUE WEB-EDITOR 'BROWSE-FONT-FAMILY) - ,SIZE - ,(SLOT-VALUE WEB-EDITOR 'BROWSE-FONT-FACE)))) - (IL:* IL:\; - "clear out the label cache!") - (RECOMPUTE-LABELS WEB-EDITOR))) - -(DEFMETHOD CHANGE-FORMAT ((|self| WEB-EDITOR) - &OPTIONAL |format|) (IL:* IL:\; "21-Apr-84 19:52") - (IL:* IL:\; - "Change format between Lattice and Tree") - (COND - ((IL:LISTP |format|) - (SETF (SLOT-VALUE |self| 'GRAPH-FORMAT) - |format|)) - ((SETQ |format| (IL:MENU (IL:|create| IL:MENU - IL:ITEMS IL:_ (SLOT-VALUE |self| 'GRAPH-FORMAT-CHOICES)))) - (SETF (SLOT-VALUE |self| 'GRAPH-FORMAT) - |format|))) - (RECOMPUTE |self|)) - -(DEFMETHOD CHANGE-MAX-LABEL-SIZE ((SELF WEB-EDITOR) - NEW-MAX-WIDTH NEW-MAX-LINES) - (IL:* IL:\; "13-Dec-84 13:05") - (IL:* IL:\; - "change the max label dimensions and redisplay the nodes -- if new size is NULL, don't change") - (IL:|if| NEW-MAX-LINES - IL:|then| (SETF (SLOT-VALUE SELF 'LABEL-MAX-LINES) - NEW-MAX-LINES)) - (IL:|if| NEW-MAX-WIDTH - IL:|then| (SETF (SLOT-VALUE SELF 'LABEL-MAX-CHARS-WIDTH) - NEW-MAX-WIDTH)) (IL:* IL:\; - "clear out the label cache") - (RECOMPUTE-LABELS SELF)) - -(DEFMETHOD SHAPE-TO-HOLD ((SELF WEB-EDITOR)) (IL:* IL:\; "13-Jan-87 16:52") - - (IL:* IL:|;;| "Shape the browse window to just hold the nodes with BrowserMargin to spare") - - (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) - (REGION (IL:WINDOWPROP WINDOW 'IL:REGION)) - (NODES (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP WINDOW 'IL:GRAPH))) - (MIN-WIDTH (IL:IPLUS 5 (IL:STRINGWIDTH (SLOT-VALUE SELF 'TITLE) - (IL:DSPFONT NIL IL:|WindowTitleDisplayStream|)))) - (MIN-HEIGHT (IL:FONTHEIGHT (IL:DSPFONT NIL WINDOW))) - LEFT BOTTOM HEIGHT WIDTH RIGHT TOP) - (IF NODES - (PROGN (SETQ LEFT (IL:MIN/LEFT NODES)) - (SETQ BOTTOM (IL:MIN/BOTTOM NODES)) - (SETQ RIGHT (IL:MAX/RIGHT NODES)) - (SETQ TOP (IL:MAX/TOP NODES)) - (SETQ WIDTH (IL:IMAX MIN-WIDTH (IL:IMIN IL:|MaxLatticeWidth| - (IL:WIDTHIFWINDOW (IL:PLUS - IL:|BrowserMargin| - (IL:IDIFFERENCE - RIGHT LEFT)) - (IL:WINDOWPROP WINDOW 'IL:BORDER)))) - ) - (SETQ HEIGHT (IL:IMAX MIN-HEIGHT (IL:IMIN IL:|MaxLatticeHeight| - (IL:PLUS IL:|BrowserMargin| - (IL:IDIFFERENCE TOP BOTTOM))))) - (UNLESS (AND (IL:EQP WIDTH (IL:|fetch| IL:WIDTH IL:|of| REGION)) - (IL:EQP (IL:HEIGHTIFWINDOW HEIGHT (IL:WINDOWPROP WINDOW 'IL:TITLE) - (IL:WINDOWPROP WINDOW 'IL:BORDER)) - (IL:|fetch| IL:HEIGHT IL:|of| REGION))) - (SET-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION) - (IL:|fetch| IL:BOTTOM IL:|of| REGION) - WIDTH HEIGHT) - NIL))) - - (IL:* IL:|;;| "ELSE") - - (SET-REGION SELF (IL:CREATEREGION (IL:|fetch| IL:LEFT IL:|of| REGION) - (IL:|fetch| IL:BOTTOM IL:|of| REGION) - MIN-WIDTH MIN-HEIGHT))))) - -(DEFMETHOD GET-DISPLAY-LABEL ((SELF WEB-EDITOR) - OBJECT) - -(IL:* IL:|;;;| "get the display label. use the cache if it provides the answer; if not, and maxLabelWidth is set, use it to compute the appropriate bit map and then cache the result.") - - (LET ((CACHED-LABEL (IL:ASSOC OBJECT (SLOT-VALUE SELF 'LABEL-CACHE)))) - (IF CACHED-LABEL - (CDR CACHED-LABEL) - (LET ((NEW-LABEL (BOX-PRINT-STRING (GET-LABEL SELF OBJECT) - (SLOT-VALUE SELF 'LABEL-MAX-CHARS-WIDTH) - (SLOT-VALUE SELF 'LABEL-MAX-LINES) - (SLOT-VALUE SELF 'BROWSE-FONT)))) - (IL:|if| (IL:LISTP NEW-LABEL) - IL:|then| (IL:* IL:\; - "GRAPHER dies if the label is a list") - (IL:SETQ NEW-LABEL (IL:MKSTRING NEW-LABEL))) - (PUSH (CONS OBJECT NEW-LABEL) - (SLOT-VALUE SELF 'LABEL-CACHE)) - NEW-LABEL)))) - -(DEFMETHOD BOX-NODE ((SELF WEB-EDITOR) - OBJECT &OPTIONAL KEEP-PREVIOUS-BOX) (IL:* IL:\; " 8-Apr-87 18:34") - "Puts a box around the node in the graph representing the object" - - (IL:* IL:|;;| - "If there was a previously boxed node, remove the box from around it and set it to nil") - - (WHEN (AND (NOT KEEP-PREVIOUS-BOX) - DESTINATION-BROWSER - (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE)) - (HIGHLIGHT-NODE DESTINATION-BROWSER (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE) - (SLOT-VALUE SELF 'BOX-LINE-WIDTH) - IL:WHITESHADE) - (SETF (SLOT-VALUE DESTINATION-BROWSER 'BOXED-NODE) - NIL)) - (SETQ DESTINATION-BROWSER SELF) (IL:* IL:\; "update the global") - (HIGHLIGHT-NODE SELF OBJECT (SLOT-VALUE SELF 'BOX-LINE-WIDTH) - IL:BLACKSHADE) - (SETF (SLOT-VALUE SELF 'BOXED-NODE) - OBJECT)) - -(DEFMETHOD UNMARK-NODES ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "10-Dec-84 12:27") - (IL:* IL:\; - "clear the graph nodes, removing all shading and highlighting") - (REMOVE-HIGHLIGHTS IL:|self|) - (REMOVE-SHADING IL:|self|)) - -(DEFMETHOD HIGHLIGHT-NODE ((SELF WEB-EDITOR) - OBJECT WIDTH SHADE) (IL:* IL:\; "13-Dec-85 15:16") - -(IL:* IL:|;;;| "highlight a node by surronding it with a shaded box") - - (LET ((NODE (IL:FASSOC OBJECT (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP - (SLOT-VALUE SELF - 'WINDOW) - 'IL:GRAPH))))) - (AND NODE (DISPLAY-NODE-HIGHTLIGHTS SELF NODE SHADE WIDTH)))) - -(DEFMETHOD SHADE-NODE ((IL:|self| WEB-EDITOR) - IL:|object| IL:|shade|) (IL:* IL:\; "15-Jan-87 18:34") - - (IL:* IL:|;;| "shade the background of a node") - - (LET ((IL:|node| (IL:FASSOC (COND - ((IL:LITATOM IL:|object|) - (IL:SETQ IL:|object| (IL:|GetObjectRec| IL:|object|))) - (T IL:|object|)) - (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP - (SLOT-VALUE IL:|self| - 'WINDOW) - 'IL:GRAPH))))) - (IL:|if| IL:|node| - IL:|then| (IL:|if| (IL:BITMAPP (IL:|fetch| IL:NODELABEL IL:|of| IL:|node| - )) - IL:|then| - - (IL:* IL:|;;| "Need to forget the old bitmap, in case it already has a shade blt'ed into it. This will fail if the GetDisplayLabel msg returns something different from the previous value, but what can you do?") - - (CLEAR-LABEL-CACHE IL:|self| IL:|object|) - (LET ((IL:|newLabel| (GET-DISPLAY-LABEL IL:|self| IL:|object|))) - (IL:|replace| IL:NODELABEL IL:|of| IL:|node| - IL:|with| IL:|newLabel|) - (IL:|if| (AND IL:|shade| (IL:BITMAPP IL:|newLabel|)) - IL:|then| (IL:BITBLT NIL NIL NIL IL:|newLabel| NIL - NIL NIL NIL 'IL:TEXTURE - 'IL:PAINT IL:|shade|)))) - (DISPLAY-NODE-SHADING IL:|self| IL:|node| IL:|shade|)))) - -(DEFMETHOD DISPLAY-NODE-HIGHTLIGHTS ((SELF WEB-EDITOR) - NODE SHADE BOX-WIDTH) - (IL:RESET/NODE/BORDER NODE (COND - (SHADE (LIST BOX-WIDTH SHADE)) - (T BOX-WIDTH)) - (SLOT-VALUE SELF 'WINDOW))) - -(DEFMETHOD DISPLAY-NODE-SHADING ((SELF WEB-EDITOR) - NODE SHADE) (IL:* IL:\; "13-Dec-85 15:13") - (IL:* IL:\; "New method template") - (IL:RESET/NODE/LABELSHADE NODE (OR SHADE IL:WHITESHADE) - (SLOT-VALUE SELF 'WINDOW))) - -(DEFMETHOD REMOVE-HIGHLIGHTS ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "13-Dec-85 15:16") - -(IL:* IL:|;;;| "gets rid of all highlighting in the lattice") - - (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES - IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| - 'WINDOW) - 'IL:GRAPH)) - IL:|do| (DISPLAY-NODE-HIGHTLIGHTS IL:|self| IL:|node| NIL)) - (SETF (SLOT-VALUE IL:|self| 'BOXED-NODE) - NIL)) - -(DEFMETHOD REMOVE-SHADING ((IL:|self| WEB-EDITOR)) (IL:* IL:\; "13-Dec-85 15:14") - -(IL:* IL:|;;;| "gets rid of all shading in the lattice") - - (IL:|for| IL:|node| IL:|in| (IL:|fetch| IL:GRAPHNODES - IL:|of| (IL:WINDOWPROP (SLOT-VALUE IL:|self| - 'WINDOW) - 'IL:GRAPH)) - IL:|do| (DISPLAY-NODE-SHADING IL:|self| IL:|node| IL:WHITESHADE))) - -(DEFMETHOD FLASH-NODE ((IL:|self| WEB-EDITOR) - IL:|node| IL:N IL:|flashTime| IL:|leaveFlipped?|) - (IL:* IL:\; "12-Dec-84 16:09") - (IL:* IL:\; "Flip node N times") - (IL:SETQ IL:|node| (IL:FASSOC (COND - ((IL:LITATOM IL:|node|) - (IL:SETQ IL:|node| (IL:|GetObjectRec| IL:|node|))) - (T IL:|node|)) - (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP - (SLOT-VALUE IL:|self| - 'WINDOW) - 'IL:GRAPH)))) - (IL:|if| IL:|node| - IL:|then| (IL:|for| IL:\i IL:|from| 1 IL:|to| (OR IL:N 3) - IL:|do| (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW)) - (IL:DISMISS (OR IL:|flashTime| 300)) - (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW)) - (IL:DISMISS (OR IL:|flashTime| 300))) - (IL:|if| IL:|leaveFlipped?| - IL:|then| (IL:FLIPNODE IL:|node| (SLOT-VALUE IL:|self| 'WINDOW))))) - -(DEFMETHOD FLIP-NODE ((SELF WEB-EDITOR) - OBJECT) (IL:* IL:\; "13-Dec-85 15:18") - (IL:* IL:\; - "Inverts the video around the node in the graph representing the object") - (LET ((NODE (IL:FASSOC OBJECT (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP - (SLOT-VALUE SELF - 'WINDOW) - 'IL:GRAPH))))) - (AND NODE (DISPLAY-NODE-SHADING SELF NODE (IL:INVERTED/SHADE/FOR/GRAPHER (IL:|fetch| - IL:NODELABELSHADE - IL:|of| - NODE)))))) - -(DEFMETHOD POSITION-NODE ((SELF WEB-EDITOR) - OBJECT WINDOW-X WINDOW-Y) (IL:* IL:\; "10-Dec-84 18:24") - -(IL:* IL:|;;;| "scrolls the window so that the node is in the given position of the window. If windowX or windowY is a FLOATP, it it taken to be a window-relative postion; if a FIXP, it is a window-absolute position.") - - (LET ((REGION (NODE-REGION SELF OBJECT))) - (IL:|if| REGION - IL:|then| (SCROLL-WINDOW SELF (IL:|fetch| IL:LEFT IL:|of| REGION) - (IL:|fetch| IL:BOTTOM IL:|of| REGION) - WINDOW-X WINDOW-Y)))) -(IL:DEFINEQ - -(BOX-PRINT-STRING - (IL:LAMBDA (STRING MAX-CHARS-WIDTH MAX-LINES FONT OLD-BITMAP) - (IL:* IL:\; "Edited 29-Jan-88 15:06 by Rao") - - (IL:* IL:|;;| - "return a bitmap containing the string, in the given font, with MAX-WIDTH at most width") - (IL:* IL:\; - "sizes of NULL or 0 mean no max size") - (IL:SETQ MAX-CHARS-WIDTH (OR MAX-CHARS-WIDTH 0)) - (IL:SETQ MAX-LINES (OR MAX-LINES 0)) - (IL:|if| (IL:ZEROP MAX-CHARS-WIDTH) - IL:|then| (IL:* IL:\; - "no max width, then just return the STRING") - STRING - IL:|else| - (PROG ((MAX-WIDTH (IL:ITIMES MAX-CHARS-WIDTH (IL:STRINGWIDTH "A" FONT))) - (NCHARS (IL:NCHARS STRING)) - (NLINES 0) - (SPOS 0) - (REGION (IL:CONSTANT (IL:|create| IL:REGION))) - (TRUE-MAX-WIDTH 0) - NEXTPOS DSP SUBSTR) - (IL:SETQ STRING (IL:MKSTRING STRING)) (IL:* IL:\; - "we need to find the size of the resultant bitmap") - IL:NEXTBREAK - (IL:|if| (IL:ILESSP SPOS NCHARS) - IL:|then| (IL:|add| NLINES 1) (IL:* IL:\; - "at least one character, even if exceed MAX-WIDTH") - (IL:SETQ NEXTPOS (IL:IMAX 1 (CAR (BREAK-STRING-FOR-BOXING - (IL:SUBSTRING STRING (IL:ADD1 SPOS) - -1) - MAX-WIDTH FONT)))) - (IL:SETQ TRUE-MAX-WIDTH (IL:IMAX TRUE-MAX-WIDTH (IL:STRINGWIDTH - (IL:SUBSTRING STRING - (IL:ADD1 SPOS) - (IL:IPLUS SPOS NEXTPOS) - ) - FONT))) - (IL:|add| SPOS NEXTPOS) - (GO IL:NEXTBREAK)) - (IL:|if| (NOT (IL:ZEROP MAX-LINES)) - IL:|then| (IL:SETQ NLINES (IL:IMIN MAX-LINES NLINES))) - (IL:* IL:\; - "that we have the size, lets build it") - (IL:SETQ DSP (IL:DSPCREATE - (IL:|if| (AND OLD-BITMAP - (NOT (OR (IL:GREATERP TRUE-MAX-WIDTH (IL:BITMAPWIDTH - OLD-BITMAP)) - (IL:GREATERP (IL:ITIMES NLINES - (IL:FONTPROP FONT - 'IL:HEIGHT)) - (IL:BITMAPHEIGHT OLD-BITMAP))))) - IL:|then| OLD-BITMAP - IL:|else| (IL:BITMAPCREATE TRUE-MAX-WIDTH (IL:ITIMES - NLINES - (IL:FONTPROP FONT - 'IL:HEIGHT)))))) - (IL:DSPFONT FONT DSP) - (IL:DSPRESET DSP) - (IL:SETQ SPOS 0) - (IL:|replace| IL:LEFT IL:|of| REGION IL:|with| 0) - (IL:|replace| IL:WIDTH IL:|of| REGION IL:|with| TRUE-MAX-WIDTH) - (IL:|replace| IL:HEIGHT IL:|of| REGION IL:|with| (IL:FONTPROP FONT - 'IL:HEIGHT)) - (IL:|replace| IL:BOTTOM IL:|of| REGION IL:|with| (IL:ITIMES - NLINES - (IL:FONTPROP FONT - 'IL:HEIGHT))) - IL:NEXTPIECE - (IL:|add| NLINES -1) - (IL:|if| (IL:ILESSP SPOS NCHARS) - IL:|then| (IL:SETQ NEXTPOS (IL:IMAX 1 (CAR (BREAK-STRING-FOR-BOXING - (IL:SUBSTRING STRING (IL:ADD1 SPOS) - -1) - TRUE-MAX-WIDTH FONT)))) - (IL:SETQ SUBSTR (IL:SUBSTRING STRING (IL:ADD1 SPOS) - (IL:IPLUS NEXTPOS SPOS))) - (IL:|replace| IL:BOTTOM IL:|of| REGION - IL:|with| (IL:IDIFFERENCE (IL:|fetch| IL:BOTTOM IL:|of| REGION) - (IL:|fetch| IL:HEIGHT IL:|of| REGION))) - (IL:|if| (AND (IL:ZEROP NLINES) - (IL:ILESSP (IL:IPLUS NEXTPOS SPOS) - NCHARS)) - IL:|then| (IL:* IL:\; "we need to abbreviate!") - (IL:CENTERPRINTINREGION (IL:CONCAT (IL:SUBSTRING SUBSTR 1 -3) - "...") - REGION DSP) - (GO IL:ALLDONE) - IL:|else| (IL:* IL:\; "out this piece") - (IL:CENTERPRINTINREGION SUBSTR REGION DSP) - (IL:|add| SPOS NEXTPOS) - (GO IL:NEXTPIECE))) - IL:ALLDONE - (RETURN (IL:DSPDESTINATION NIL DSP)))))) - -(BREAK-STRING-FOR-BOXING - (IL:LAMBDA (IL:MSG IL:WIDTH IL:FONT) (IL:* IL:\; "11-Dec-84 10:29") - - (IL:* IL:\; IL:|Stolen| IL:|from| IL:|the| IL:|function| IL:ICONW.FORMATLINE - IL:-- IL:|modified| IL:|to| IL:|try| IL:|to| IL:|break| IL:|at| "word" - IL:|boundaries,| IL:|whatever| IL:|they| IL:|are|) - - (IL:* IL:\; IL:\a IL:|list| IL:|of| IL:|the| IL:|char#| IL:|relative| IL:|to| - IL:|char| 1 IL:|of| IL:|where| IL:|to| IL:|break| IL:|next| IL:|line,| IL:|and| - IL:|how| IL:|much| IL:|space| IL:|was| LEFT IL:|over| - (IL:|for| IL:|centering| IL:&\c)) - - (COND - (IL:MSG (IL:* IL:\; IL:|there| IL:|really| - IL:|is| IL:\a IL:|title,| IL:|go| - IL:|ahead| IL:|and| IL:|format| - IL:|the| IL:|next| IL:|line.|) - (IL:|bind| (IL:TX IL:_ 0) - (IL:LASTB IL:_ 0) - (IL:CH IL:_ 0) - (IL:TMSG IL:_ (IL:OPENSTRINGSTREAM IL:MSG)) - (IL:MSGLEN IL:_ (IL:NCHARS IL:MSG)) IL:|for| IL:I IL:|from| 1 - IL:|by| 1 - IL:|do| (IL:* IL:\; IL:|thru| IL:|the| - IL:|characters| IL:|one| IL:|by| - IL:|one.|) - (COND - ((IL:IGREATERP IL:TX IL:WIDTH) (IL:* IL:\; IL:|past| IL:|the| - IL:|right| IL:|margin.| - IL:|Time| IL:|to| IL:|stop.|) - (IL:CLOSEF? IL:TMSG) - (RETURN (COND - ((IL:LISTP IL:LASTB) (IL:* IL:\; IL:|is| IL:\a IL:|space| - IL:|we| IL:|can| IL:|break| IL:|the| - IL:|line| IL:|at.| - IL:|Break| IL:|there.|) - IL:LASTB) - (T - - (IL:* IL:\; IL:|were| IL:|no| IL:|spaces| IL:|on| IL:|this| IL:|line.| - IL:|Break| IL:|after| IL:|the| IL:|last| IL:|character| IL:|that| IL:|did| - IL:|fit.|) - - (CONS (IL:IDIFFERENCE IL:I 2) - (IL:IDIFFERENCE IL:WIDTH (IL:IDIFFERENCE IL:TX - (IL:CHARWIDTH IL:CH - IL:FONT)))))))) - ((IL:EOFP IL:TMSG) (IL:* IL:\; IL:|was| IL:|the| - IL:|last| IL:|character.|) - (IL:CLOSEF? IL:TMSG) - (RETURN (CONS (IL:SUB1 IL:I) - (IL:IDIFFERENCE IL:WIDTH IL:TX)))) - (T (IL:* IL:\; IL:|at| IL:|the| - IL:|next| IL:|character.|) - (IL:SETQ IL:CH (IL:BIN IL:TMSG)) - (IL:SELCHARQ IL:CH - ((IL:SPACE IL:\. IL:\: IL:\; IL:\, / IL:\\ IL:* - IL:\#) - - (IL:* IL:\; IL:|where| IL:|word| IL:|breaks| IL:|are,| IL:|so| IL:|we| IL:|can| - IL:|back| IL:|up| IL:|and| IL:|split| IL:|lines| IL:|there| IL:|if| - IL:|possible.|) - - (IL:SETQ IL:LASTB (CONS IL:I (IL:IDIFFERENCE IL:WIDTH IL:TX - )))) - (IL:CR (IL:* IL:\; IL:|forces| IL:\a - IL:|new| IL:|line.|) - (RETURN (CONS (IL:IMINUS IL:I) - (IL:IDIFFERENCE IL:WIDTH IL:TX)))) - (IL:|if| (AND (NOT (IL:U-CASEP (IL:CHARACTER IL:CH))) - (NOT (IL:EOFP IL:TMSG)) - (IL:U-CASEP (IL:PEEKC IL:TMSG))) - IL:|then| (IL:* IL:\; IL:|from| IL:|upper| - IL:|to| IL:|lower| IL:|case| IL:|is| - IL:|also| IL:\a IL:|word| IL:|break|) - (IL:SETQ IL:LASTB (CONS IL:I (IL:IDIFFERENCE IL:WIDTH - IL:TX))))) - (IL:SETQ IL:TX (IL:IPLUS IL:TX (IL:CHARWIDTH IL:CH IL:FONT))))))) - (T (IL:* IL:\; IL:|isn't| IL:\a - IL:|title;| IL:|return| IL:\a - IL:|dummy| IL:|entry| IL:|for| - IL:|the| IL:|line| IL:|formatter.|) - (CONS 0 IL:WIDTH))))) - -(BOX-WINDOW-NODE - (IL:LAMBDA (IL:|nodeLabel| WINDOW) (IL:* IL:\; "Edited 29-Jan-88 11:31 by Rao") - (IL:* IL:\; " 7-Sep-84 14:36") - - (IL:* IL:|;;| "a box around the node with nodeLabel in the graph. A nodeLabel in browsers is an object. Does nothing if node not found.") - - (PROG (IL:|node| IL:|nodes|) - (COND - ((AND (IL:WINDOWP WINDOW) - (IL:SETQ IL:|nodes| (IL:|fetch| IL:GRAPHNODES IL:|of| (IL:WINDOWPROP - WINDOW - 'IL:GRAPH))) - (IL:SETQ IL:|node| (IL:FASSOC IL:|nodeLabel| IL:|nodes|))) - (IL:DRAWAREABOX (IL:GN/LEFT IL:|node|) - (IL:GN/BOTTOM IL:|node|) - (IL:|fetch| IL:NODEWIDTH IL:|of| IL:|node|) - (IL:|fetch| IL:NODEHEIGHT IL:|of| IL:|node|) - 1 - 'IL:INVERT WINDOW)))))) -) - - - -(IL:* IL:\; "Button Events") - -(IL:DEFINEQ - -(FIND-SELECTED-NODE - (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 12-Nov-87 01:30 by Rao") - (IL:* IL:\; "10-Dec-84 17:53") - - (IL:* IL:|;;| "Used in BUTTONEVENTFN and gets called whenever cursor moves or button is down. Adapted from APPLYTOSELECTEDNODE in GRAPHER package; returns the selected item rather than applying a function on the inside of the button event fn.") - - (IL:* IL:|;;| - "Also this was modified to pop up the middle button menu on button down rather than button up.") - - (PROG ((LOOPS-WINDOW (IL:WINDOWPROP WINDOW 'WEB-EDITOR)) - (NODELST (IL:|fetch| (IL:GRAPH IL:GRAPHNODES) IL:|of| (IL:WINDOWPROP WINDOW - 'IL:GRAPH))) - (DS (IL:WINDOWPROP WINDOW 'IL:DSP)) - BUTTON OLDPOS REG NOW NEAR) (IL:* IL:\; - "note which button is down.") - (IL:* IL:\; - "get the region of this window.") - (IL:SETQ REG (IL:WINDOWPROP WINDOW 'IL:REGION)) - (IL:|until| (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE)) IL:|do| (IL:GETMOUSESTATE)) - (IL:SETQ NEAR (IL:NODELST/AS/MENU NODELST (IL:SETQ OLDPOS (IL:CURSORPOSITION NIL DS)))) - IL:FLIP - - - (IL:* IL:|;;| "This is kirk's quick hack to get middle button to bring up immediately.") - - (WHEN (IL:LASTMOUSESTATE IL:MIDDLE) - (RETURN (IL:|fetch| IL:NODEID IL:|of| NEAR))) - (AND NOW (IL:FLIPNODE NOW DS)) - (AND NEAR (IL:FLIPNODE NEAR DS)) - (IL:SETQ NOW NEAR) - IL:LP - (IL:* IL:\; - "wait for a button up or move out of region") - (IL:GETMOUSESTATE) - (COND - ((IL:LASTMOUSESTATE (AND (NOT IL:LEFT) - (NOT IL:MIDDLE))) (IL:* IL:\; - "left button up, process it.") - (AND NOW (IL:FLIPNODE NOW DS)) (IL:* IL:\; - "NOW node has been selected.") - (RETURN (IL:|fetch| IL:NODEID IL:|of| NOW))) - ((NOT (IL:INSIDE? (IL:WINDOWPROP WINDOW 'IL:REGION) - IL:LASTMOUSEX IL:LASTMOUSEY)) (IL:* IL:\; - "outside of region, return") - (AND NOW (IL:FLIPNODE NOW DS)) - (RETURN)) - ((EQ NOW (IL:SETQ NEAR (IL:NODELST/AS/MENU NODELST (IL:CURSORPOSITION NIL DS OLDPOS)))) - (GO IL:LP)) - (T (GO IL:FLIP)))))) -) - -(DEFMETHOD BUTTON-EVENT-FN ((SELF WEB-EDITOR)) (IL:* IL:\; " 2-Jan-86 16:41") - (IL:* IL:\; - "Called when there is a button event in a Loops Window") - (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW))) - (OR (IL:ERSETQ (COND - ((NULL (IL:INSIDEP (IL:DSPCLIPPINGREGION NIL WINDOW) - (IL:LASTMOUSEX WINDOW) - (IL:LASTMOUSEY WINDOW))) - (TITLE-SELECTION SELF)) - ((IL:MOUSESTATE IL:LEFT) - (LEFT-SELECTION SELF)) - ((IL:MOUSESTATE IL:MIDDLE) - (MIDDLE-SELECTION SELF)) - ((IL:MOUSESTATE IL:RIGHT) - (RIGHT-SELECTION SELF))))))) - -(DEFMETHOD LEFT-SELECTION ((SELF WEB-EDITOR)) - (IF (MOVE-DOWN-P) - (IF (SLOT-VALUE SELF 'NODE-MOVER-P) - (NODE-MOVE SELF) - (NODE-MOVE-SHALLOW SELF)) - (NODE-SELECTION SELF 'IL:LEFT))) - -(DEFMETHOD MIDDLE-SELECTION ((SELF WEB-EDITOR)) (IL:* IL:\; "15-May-85 19:04") - - (IL:* IL:|;;| "This function called from the GRAPHER package when a node is selected with the middle mouse button. If no node is selected then just returns.") - - (PROG (SELECTION OBJECT (WINDOW (SLOT-VALUE SELF 'WINDOW)) - (WEB-EDITOR SELF)) - (DECLARE (IL:SPECVARS OBJECT WEB-EDITOR)) - (COND - ((NULL (IL:SETQ OBJECT (FIND-SELECTED-NODE WINDOW))) - (RETURN))) - (SETF (SLOT-VALUE WEB-EDITOR 'LAST-SELECTED-OBJECT) - OBJECT) - (IL:GETMOUSESTATE) - (FLIP-NODE SELF OBJECT) - (IL:SETQ SELECTION (OR (NODE-ACTION SELF OBJECT 'IL:MIDDLE) - (PROGN (FLIP-NODE SELF OBJECT) - (RETURN NIL)))) - (FLIP-NODE SELF OBJECT) - (DO-SELECTED-COMMAND WEB-EDITOR SELECTION OBJECT))) - -(DEFMETHOD RIGHT-SELECTION ((SELF WEB-EDITOR)) (IL:* IL:\; "17-Apr-84 15:46") - (IL:* IL:\; - "Do RightButtonItems on selection.") - (LET* ((CHOICE (CHOICE-MENU SELF 'RIGHT-BUTTON-ITEMS))) - (IF CHOICE (FUNCALL CHOICE SELF)))) - -(DEFMETHOD TITLE-SELECTION ((SELF WEB-EDITOR)) (IL:* IL:\; "17-Apr-84 15:35") - - (IL:* IL:|;;| " Do TitleItems if selected in title area. Replaces TitleSelection in Window because this one does evaluation in TTY process, and saves events on history") - - (LET* ((CHOICE (CHOICE-MENU SELF 'TITLE-ITEMS))) - (IF CHOICE (FUNCALL CHOICE SELF)))) - -(DEFMETHOD NODE-SELECTION ((SELF WEB-EDITOR) - BUTTON) - (LET* ((WINDOW (SLOT-VALUE SELF 'WINDOW)) - (OBJECT (FIND-SELECTED-NODE WINDOW))) - (DECLARE (IL:SPECVARS OBJECT)) (IL:* IL:\; "SPECVARS for whenHeldFn") - (IF (LISTP OBJECT) - (SETQ OBJECT (CAR OBJECT))) - (COND - ((NOT (NULL OBJECT)) - (SETF (SLOT-VALUE SELF 'LAST-SELECTED-OBJECT) - OBJECT))) - (IL:GETMOUSESTATE) - (WHEN OBJECT - (LET ((SELECTOR (NODE-ACTION SELF OBJECT BUTTON))) - (COND - (SELECTOR (DO-SELECTED-COMMAND SELF SELECTOR OBJECT))))))) - -(DEFMETHOD NODE-ACTION ((SELF WEB-EDITOR) - NODE BUTTON) (IL:* IL:\; " 8-Apr-87 17:11") - (DECLARE (IL:SPECVARS WINDOW-FOR-MENU)) - (LET ((WINDOW-FOR-MENU SELF)) - (IL:GETMOUSESTATE) - (CHOICE-MENU SELF - - (IL:* IL:|;;| " A Hook for letting nodes tailor menu items.") - - (NODE-MENU-ITEMS NODE BUTTON)))) - -(DEFMETHOD NODE-MENU-ITEMS ((NODE WEB-NODE) - BUTTON) - (CASE BUTTON - (IL:LEFT 'LEFT-BUTTON-ITEMS) - (IL:MIDDLE 'MIDDLE-BUTTON-ITEMS))) - -(DEFMETHOD CHOICE-MENU ((SELF WEB-EDITOR) - ITEM-CV) (IL:* IL:\; "29-Dec-85 13:54") - - (IL:* IL:|;;| - "Create a menu which allows subitems to be displayed. Cache it in the web-editor ") - - (LET (ITEMS MENU) - (SETQ MENU (REST (ASSOC ITEM-CV (SLOT-VALUE SELF 'MENU-CACHE)))) - (COND - ((AND MENU (IL:TYPE? IL:MENU MENU)) - (IL:MENU MENU)) - ((NOT (LISTP (SETQ ITEMS (GET-MENU-ITEMS SELF ITEM-CV)))) - ITEMS) - (T (IL:SETQ MENU (IL:CREATE IL:MENU - IL:ITEMS IL:_ ITEMS - IL:MENUOFFSET IL:_ (IL:CREATEPOSITION -1 0) - IL:WHENSELECTEDFN IL:_ 'WEB-MENU-WHENSELECTEDFN - IL:WHENHELDFN IL:_ 'WINDOW-WHEN-HELD-FN - IL:CHANGEOFFSETFLG IL:_ T - IL:CENTERFLG IL:_ T)) (IL:* IL:\; "Cache menu if menus is T") - (IF (SLOT-VALUE SELF 'CACHE-MENU-P) - (SETF (SLOT-VALUE SELF 'MENU-CACHE) - (ACONS ITEM-CV MENU (SLOT-VALUE SELF 'MENU-CACHE)))) - (IL:MENU MENU))))) - -(DEFMETHOD DO-SELECTED-COMMAND ((WEB-EDITOR WEB-EDITOR) - COMMAND OBJ &OPTIONAL NODE) - (IL:* IL:\; "17-Sep-86 17:49") - - (IL:* IL:|;;| "Do the selected command or forwards it to the object") - - (IF COMMAND - - (IL:* IL:|;;| "Take care of being passed in a dummy node from browser in Lattice mode. --- Dummy nodes are indicated by having the object in a list") - - (LET ((ARGS (IF (IL:LISTP COMMAND) - (CDR COMMAND) - NIL)) - (COMMAND (IF (IL:LISTP COMMAND) - (CAR COMMAND) - COMMAND)) - (OBJ (IF (IL:LISTP OBJ) - (CAR OBJ) - OBJ))) - (WHEN (IL:FMEMB COMMAND (SLOT-VALUE WEB-EDITOR 'LOCAL-COMMANDS)) - (SETQ ARGS (CONS OBJ ARGS)) - (SETQ OBJ WEB-EDITOR)) - - (IL:* IL:|;;| - "Grays out the node at the beginning of the command, and ungrays it when the command completes.") - - (SETQ NODE OBJ) - (IF NODE - (PROGN (SHADE-NODE WEB-EDITOR NODE IL:GRAYSHADE2) - (IL:BLOCK 500) - (SHADE-NODE WEB-EDITOR NODE IL:WHITESHADE) - (APPLY COMMAND OBJ ARGS)) - (APPLY COMMAND OBJ ARGS))))) - -(DEFMETHOD WHEN-MENU-ITEM-HELD ((SELF WEB-EDITOR) - ITEM MENU KEY) (IL:* IL:\; " 8-Apr-87 17:13") - -(IL:* IL:|;;;| "What to do when the menu item is held") - - (IL:PROMPTPRINT (OR (COND - ((IL:NLISTP ITEM) - NIL) - (T (CADDR ITEM))) - "When released this item will be selected"))) - -(DEFMETHOD ITEM-MENU ((SELF WEB-EDITOR) - ITEMS TITLE) (IL:* IL:\; "21-Apr-84 09:31") - (IL:* IL:\; - "Create a simnple (one level) menu which will not overflow height of screen") - (IL:|create| IL:MENU - IL:ITEMS IL:_ ITEMS - IL:MENUCOLUMNS IL:_ (IL:ADD1 (IL:IQUOTIENT (IL:ITIMES (IL:FONTHEIGHT IL:MENUFONT) - (IL:LENGTH ITEMS)) - 750)) - IL:TITLE IL:_ TITLE - IL:CHANGEOFFSETFLG IL:_ T)) - -(DEFMETHOD GET-MENU-ITEMS ((SELF WEB-EDITOR) - ITEM-CV) (IL:* IL:\; "23-Oct-84 12:36") - (IL:* IL:\; "Get item list for menu") - (SLOT-VALUE SELF ITEM-CV)) - -(DEFMETHOD CLEAR-MENU-CACHE ((SELF WEB-EDITOR)) (IL:* IL:\; "11-Apr-86 14:46") - (IL:* IL:\; - "Delete Menus saved on menus") - (SETF (SLOT-VALUE SELF 'MENU-CACHE) - NIL) - SELF) -(IL:DEFINEQ - -(WEB-MENU-WHENSELECTEDFN - (IL:LAMBDA (ITEM MENU BUTTON) (IL:* IL:\; "Edited 14-Jul-87 17:43 by Rao") - (IL:* IL:\; "13-DEC-83 21:03") - (PROG (SECOND-ELEMENT) - (RETURN (COND - ((IL:NLISTP ITEM) - ITEM) - ((IL:NLISTP (IL:SETQ SECOND-ELEMENT (CADR ITEM))) - SECOND-ELEMENT) - ((EQ (CAR SECOND-ELEMENT) - 'PROGN) - (IL:EVAL SECOND-ELEMENT)) - (T SECOND-ELEMENT)))))) - -(WINDOW-WHEN-HELD-FN - (LAMBDA (ITEM MENU KEY) (IL:* IL:\; "Edited 9-Jul-87 11:58 by Rao") - (IL:* IL:\; "29-Dec-85 15:28") - (IL:* IL:\; - "Send to window the message to respond to time out on menu") - (DECLARE (IL:SPECVARS WINDOW-FOR-MENU)) - (WHEN-MENU-ITEM-HELD WINDOW-FOR-MENU ITEM MENU KEY))) -) -(IL:DEFINEQ - -(SUB-ITEM-SELECTION - (IL:LAMBDA (ITEM MENU BUTTON) (IL:* IL:\; "Edited 14-Jul-87 17:13 by Rao") - (IL:* IL:\; "13-DEC-83 21:03") - - (IL:* IL:|;;| "menu WHENSELECTEDFN which allows differential selection on LEFT and middle button. For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu") - - (PROG (IT IT1) - (RETURN (COND - ((IL:NLISTP ITEM) - ITEM) - ((IL:NLISTP (IL:SETQ IT (CADR ITEM))) - IT) - ((EQ (IL:SETQ IT1 (CAR IT)) - 'QUOTE) - (CADR IT)) - ((EQ IT1 'PROGN) - (IL:EVAL IT)) - ((IL:LISTP IT1) - (IL:EVAL IT1)) - (T IT1)))))) - -(DUAL-SUB-ITEMS - (IL:LAMBDA (MENU ITEM) (IL:* IL:\; "Edited 14-Jul-87 17:14 by Rao") - (IL:* IL:\; "13-DEC-83 21:07") - - (IL:* IL:|;;| "menu WHENSELECTEDFN which allows differential selection on LEFT and middle button. For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu") - - (PROG (IT IT1) - (RETURN (COND - ((OR (IL:NLISTP ITEM) - (IL:NLISTP (IL:SETQ IT (CADR ITEM))) - (EQ (IL:SETQ IT1 (CAR IT)) - 'QUOTE) - (EQ IT1 'PROGN) - (IL:NLISTP (IL:SETQ IT1 (CADR IT)))) - NIL) - (T IT1)))))) - -(WINDOW-WHEN-HELD-FN - (LAMBDA (ITEM MENU KEY) (IL:* IL:\; "Edited 9-Jul-87 11:58 by Rao") - (IL:* IL:\; "29-Dec-85 15:28") - (IL:* IL:\; - "Send to window the message to respond to time out on menu") - (DECLARE (IL:SPECVARS WINDOW-FOR-MENU)) - (WHEN-MENU-ITEM-HELD WINDOW-FOR-MENU ITEM MENU KEY))) - -(DO-MENU-METHOD - (IL:LAMBDA (OBJECT ITEMS) (IL:* IL:\; "Edited 14-Jul-87 17:15 by Rao") - (IL:* IL:\; "13-NOV-83 16:20") - (PROG ((SELECTOR (AND ITEMS (DUAL-MENU ITEMS)))) - (AND SELECTOR (RETURN (FUNCALL SELECTOR OBJECT)))))) - -(DUAL-MENU - (IL:LAMBDA (ITEMS WHEN-HELD-FN) (IL:* IL:\; "Edited 14-Jul-87 17:16 by Rao") - (IL:* IL:\; " 9-FEB-84 16:17") - (IL:* IL:\; - "and pops up a menu which allows differential selection on LEFT an middle buttons") - (IL:MENU (IL:|create| IL:MENU - IL:ITEMS IL:_ ITEMS - IL:WHENSELECTEDFN IL:_ 'SUB-ITEM-SELECTION - IL:SUBITEMFN IL:_ 'DUAL-SUB-ITEMS - IL:WHENHELDFN IL:_ WHEN-HELD-FN - IL:CHANGEOFFSETFLG IL:_ T)))) - -(DUAL-SELECTION - (IL:LAMBDA (ITEM MENU BUTTON) (IL:* IL:\; "Edited 14-Jul-87 17:28 by Rao") - (IL:* IL:\; "29-MAR-83 17:57") - - (IL:* IL:|;;| "MENU WHENSELECTEDFN which allows differential selection on LEFT and middle button. For such differential selection ITEM should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when ITEM is selected with middle, or midValue can be an itemList, which will be displayed in a subselection MENU") - - (PROG (IT IT1) - (RETURN (COND - ((IL:NLISTP ITEM) - ITEM) - ((IL:NLISTP (IL:SETQ IT (CADR ITEM))) - IT) - ((EQ (IL:SETQ IT1 (CAR IT)) - 'QUOTE) - (CADR IT)) - ((EQ IT1 'PROGN) - (IL:EVAL IT)) - ((EQ BUTTON 'IL:LEFT) - (COND - ((IL:LISTP IT1) - (IL:EVAL IT1)) - (T IT1))) - ((IL:NLISTP (IL:SETQ IT1 (CADR IT))) - IT1) - (T (DUAL-MENU IT1))))))) -) - - - -(IL:* IL:\; "Node Moving Protocol") - - -(DEFMETHOD NODE-MOVE ((SELF WEB-EDITOR)) - (LET ((OLD-REGIONS (MAKE-REG-ASSOC SELF)) - NEW-REGIONS MOVED-PAIR NEW-FATHER CLOSEST-PAIR) - (NODE-MOVE-SHALLOW SELF) - (SETQ NEW-REGIONS (MAKE-REG-ASSOC SELF)) - (SETQ MOVED-PAIR (IL:|for| |npair| IL:|in| NEW-REGIONS IL:|as| |opair| - IL:|in| OLD-REGIONS IL:|thereis| (NOT (IL:EQUAL (CAR |opair|) - (CAR |npair|))))) - (WHEN (AND MOVED-PAIR - - (IL:* IL:|;;| "The moved guy has a parent") - - (SLOT-VALUE (CDR MOVED-PAIR) - 'PARENT)) - (IL:DREMOVE MOVED-PAIR NEW-REGIONS) - (SETQ NEW-REGIONS - - (IL:* IL:|;;| "Collect the pairs that havn't changed.") - - (IL:|bind| (SCIONS-OF-MOVED IL:_ (SCIONS (CDR MOVED-PAIR))) IL:|for| PAIR - IL:|in| NEW-REGIONS IL:|unless| (IL:MEMBER (CDR PAIR) - SCIONS-OF-MOVED) IL:|collect| - PAIR)) - (SETQ CLOSEST-PAIR (IL:|bind| (\b IL:_ (IL:|fetch| IL:BOTTOM IL:|of| - (CAR MOVED-PAIR))) - (\l IL:_ (IL:|fetch| IL:LEFT IL:|of| (CAR MOVED-PAIR))) - IL:|for| |pair| IL:|in| NEW-REGIONS - IL:|smallest| (IL:PLUS (ABS (IL:IDIFFERENCE (IL:|fetch| - IL:BOTTOM - IL:|of| - (CAR |pair|)) - \b)) - (ABS (IL:IDIFFERENCE (IL:|fetch| - IL:LEFT - IL:|of| - (CAR |pair|)) - \l))))) - - (IL:* IL:|;;| - "Either make moved node a sibling or a child of the node it is now closest to.") - - (IL:|if| (IL:IGREATERP (IL:IDIFFERENCE (IL:|fetch| IL:LEFT IL:|of| - (CAR MOVED-PAIR)) - (IL:|fetch| IL:LEFT IL:|of| (CAR CLOSEST-PAIR)) - ) - 15) - IL:|then| (IL:SETQ NEW-FATHER (CDR CLOSEST-PAIR)) - IL:|else| (IL:SETQ NEW-FATHER (OR (SLOT-VALUE (CDR CLOSEST-PAIR) - 'PARENT) - (CDR CLOSEST-PAIR)))) - (MOVE-NODE (CDR MOVED-PAIR) - NEW-FATHER) - (REORDER-TREE SELF NEW-FATHER)) - (RECOMPUTE SELF))) - -(DEFMETHOD NODE-MOVE-SHALLOW ((SELF WEB-EDITOR)) - - (IL:* IL:|;;| "Just moves the node graphically with no deep impact") - - (LET ((WINDOW (SLOT-VALUE SELF 'WINDOW))) - (IL:RESETLST - (IL:RESETSAVE NIL (LIST (IL:FUNCTION IL:DSPOPERATION) - (IL:DSPOPERATION 'IL:INVERT WINDOW) - WINDOW)) - (IL:GETMOUSESTATE) (IL:* IL:\; "Here to move a node.") - (IL:DSPOPERATION 'IL:INVERT WINDOW) - (IL:EDITMOVENODE WINDOW)))) - -(DEFMETHOD SCIONS ((SELF WEB-NODE)) (IL:* IL:\; "14-Nov-86 03:01") - (IL:* IL:\; "Used by the Node Mover") - (LET ((TO-LINKS (GET-TO-LINKS SELF))) - (APPEND TO-LINKS (IL:|for| IL:|child| IL:|in| TO-LINKS IL:|join| (SCIONS - IL:|child| - ))))) - -(DEFMETHOD MAKE-REG-ASSOC ((SELF WEB-EDITOR)) (IL:* IL:\; "14-Nov-86 02:08") - (IL:* IL:\; "Ho hum") - (IL:|for| X IL:|in| (SLOT-VALUE SELF 'STARTING-LIST) IL:|collect| (CONS (NODE-REGION - SELF X) - X))) - -(DEFMETHOD REORDER-TREE ((SELF WEB-EDITOR) - ROOT) (IL:* IL:\; "14-Nov-86 02:35") - (LET ((CHILDREN (GET-TO-LINKS ROOT))) - (IF CHILDREN - (IL:SORT CHILDREN #'(IL:LAMBDA (C1 C2) - (LET ((R1 (NODE-REGION SELF C1)) - (R2 (NODE-REGION SELF C2))) - (IL:LESSP (IL:|fetch| IL:BOTTOM IL:|of| R1) - (IL:|fetch| IL:BOTTOM IL:|of| R2)))))))) - -(DEFMETHOD MOVE-NODE ((SELF WEB-NODE) - NEW-PARENT) (IL:* IL:\; "29-Jan-87 17:55") - (LET ((OLD-PARENT (SLOT-VALUE SELF 'PARENT))) - (UNLESS (EQ OLD-PARENT NEW-PARENT) - (SETF (SLOT-VALUE SELF 'PARENT) - NEW-PARENT) - (SETF (SLOT-VALUE OLD-PARENT 'TO-LINKS) - (IL:DREMOVE SELF (SLOT-VALUE OLD-PARENT 'TO-LINKS))) - (SETF (SLOT-VALUE NEW-PARENT 'TO-LINKS) - (IL:NCONC1 (SLOT-VALUE NEW-PARENT 'TO-LINKS) - SELF)) - T))) - - - -(IL:* IL:\; "") - - - - -(IL:* IL:|;;| "") - -(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS - -(IL:ADDTOVAR IL:NLAMA ) - -(IL:ADDTOVAR IL:NLAML ) - -(IL:ADDTOVAR IL:LAMA WINDOW-WHEN-HELD-FN WINDOW-WHEN-HELD-FN) -) -(IL:PUTPROPS IL:WEB-EDITOR IL:COPYRIGHT ("Xerox Corporation" 1987 1988 1989 1991)) -(IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL (50310 53152 (WEB-WINDOW-AFTER-MOVE-FN 50323 . 50701) (WEB-WINDOW-BUTTON-EVENT-FN -50703 . 51146) (WEB-WINDOW-RESHAPE-FN 51148 . 51704) (WEB-WINDOW-CLOSE-FN 51706 . 52056) ( -IL:|PromptRead| 52058 . 53150)) (53153 53586 (WEB-WINDOW-EXPAND-FN 53166 . 53584)) (57488 65032 ( -TREE-ROOTS 57501 . 62883) (CHILD-NODES 62885 . 63646) (REACHABLE-NODES! 63648 . 65030)) (94827 108235 -(BOX-PRINT-STRING 94840 . 101302) (BREAK-STRING-FOR-BOXING 101304 . 107100) (BOX-WINDOW-NODE 107102 . -108233)) (108273 111315 (FIND-SELECTED-NODE 108286 . 111313)) (119862 121033 (WEB-MENU-WHENSELECTEDFN -119875 . 120505) (WINDOW-WHEN-HELD-FN 120507 . 121031)) (121034 126038 (SUB-ITEM-SELECTION 121047 . -122147) (DUAL-SUB-ITEMS 122149 . 123158) (WINDOW-WHEN-HELD-FN 123160 . 123684) (DO-MENU-METHOD 123686 - . 124026) (DUAL-MENU 124028 . 124723) (DUAL-SELECTION 124725 . 126036))))) -IL:STOP diff --git a/obsolete/clos/2.0/boot.lisp b/obsolete/clos/2.0/boot.lisp deleted file mode 100644 index 5385f6ff..00000000 --- a/obsolete/clos/2.0/boot.lisp +++ /dev/null @@ -1,1297 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;; File converted on 2-Apr-91 16:40:32 from source bood - - - -(in-package "CLOS") - -;;; Shadow, Export, Require, Use-package, and Import forms should follow here - - - -;;; ************************************************************************* Copyright (c) 1985, -;;; 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this -;;; software and preparation of derivative works based upon this software are permitted. Any -;;; distribution of this software or derivative works must comply with all applicable United States -;;; export control laws. This software is made available AS IS, and Xerox Corporation makes no -;;; warranty about the software, its performance or its conformity to any specification. Any person -;;; obtaining a copy of this software is requested to send their name and post office or electronic -;;; mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or -;;; send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests -;;; for improvements are also welcome. -;;; ************************************************************************* - - -#| - -The CommonLoops evaluator is meta-circular. - -Most of the code in CLOS is methods on generic functions, including most of -the code that actually implements generic functions and method lookup. - -So, we have a classic bootstrapping problem. The solution to this is to -first get a cheap implementation of generic functions running, these are -called early generic functions. These early generic functions and the -corresponding early methods and early method lookup are used to get enough -of the system running that it is possible to create real generic functions -and methods and implement real method lookup. At that point (done in the -file FIXUP) the function fix-early-generic-functions is called to convert -all the early generic functions to real generic functions. - -The cheap generic functions are built using the same funcallable-instance -objects real generic-functions are made out of. This means that as CLOS -is being bootstrapped, the cheap generic function objects which are being -created are the same objects which will later be real generic functions. -This is good because: - - we don't cons garbage structure - - we can keep pointers to the cheap generic function objects - during booting because those pointers will still point to - the right object after the generic functions are all fixed - up - - - -This file defines the defmethod macro and the mechanism used to expand it. -This includes the mechanism for processing the body of a method. defmethod -basically expands into a call to load-defmethod, which basically calls -add-method to add the method to the generic-function. These expansions can -be loaded either during bootstrapping or when CLOS is fully up and running. - -An important effect of this structure is it means we can compile files with -defmethod forms in them in a completely running CLOS, but then load those files -back in during bootstrapping. This makes development easier. It also means -there is only one set of code for processing defmethod. Bootstrapping works -by being sure to have load-method be careful to call only primitives which -work during bootstrapping. - -|# - -(proclaim '(notinline make-a-method add-named-method ensure-generic-function-using-class add-method - remove-method)) - -(defvar *early-functions* '((make-a-method early-make-a-method real-make-a-method) - (add-named-method early-add-named-method real-add-named-method))) - - -;;; For each of the early functions, arrange to have it point to its early definition. Do this in a -;;; way that makes sure that if we redefine one of the early definitions the redefinition will take -;;; effect. This makes development easier. The function which generates the redirection closure is -;;; pulled out into a separate piece of code because of a bug in ExCL which causes this not to work -;;; if it is inlined. - - -(eval-when (load eval) - (defun redirect-early-function-internal (to) - #'(lambda (&rest args) - (apply (symbol-function to) - args))) - (dolist (fns *early-functions*) - (let ((name (car fns)) - (early-name (cadr fns))) - (setf (symbol-function name) - (redirect-early-function-internal early-name)))) -) - - -;;; *generic-function-fixups* is used by fix-early-generic-functions to convert the few functions in -;;; the bootstrap which are supposed to be generic functions but can't be early on. - - -(defvar *generic-function-fixups* '((add-method ((generic-function method) - ; lambda-list - (standard-generic-function method) - ; specializers - real-add-method)) - ; method-function - (remove-method ((generic-function method) - (standard-generic-function method) - real-remove-method)) - (get-method ((generic-function qualifiers specializers &optional - (errorp t)) - (standard-generic-function t t) - real-get-method)) - (ensure-generic-function-using-class ((generic-function - function-specifier - &key - generic-function-class - environment - &allow-other-keys) - (generic-function t) - - real-ensure-gf-using-class--generic-function - ) - ((generic-function function-specifier &key - generic-function-class environment - &allow-other-keys) - (null t) - real-ensure-gf-using-class--null)))) - - -;;; - - -(defmacro defgeneric (function-specifier lambda-list &body options) - (expand-defgeneric function-specifier lambda-list options)) - -(defun expand-defgeneric (function-specifier lambda-list options) - (when (listp function-specifier) - (do-standard-defsetf-1 (cadr function-specifier))) - (let ((initargs nil)) - (flet ((duplicate-option (name) - (error "The option ~S appears more than once." name))) - - ;; INITARG takes this screwy new argument to get around a bad interaction between - ;; lexical macros and setf in the Lucid compiler. - (macrolet ((initarg (key &optional new) - (if new - `(setf (getf initargs ,key) - ,new) - `(getf initargs ,key)))) - (dolist (option options) - (ecase (car option) - (:argument-precedence-order - (if (initarg :argument-precedence-order) - (duplicate-option :argument-precedence-order) - (initarg :argument-precedence-order - `',(cdr option)))) - (declare (initarg :declarations (append (cdr option) - (initarg :declarations)))) - (:documentation (if (initarg :documentation) - (duplicate-option :documentation) - (initarg :documentation - `',(cadr option)))) - (:method-combination - (if (initarg :method-combination) - (duplicate-option :method-combination) - (initarg :method-combination - `',(cdr option)))) - (:generic-function-class - (if (initarg :generic-function-class) - (duplicate-option :generic-function-class) - (initarg :generic-function-class - `',(cadr option)))) - (:method-class (if (initarg :method-class) - (duplicate-option :method-class) - (initarg :method-class - `',(cadr option)))) - (:method (error "DEFGENERIC doesn't support the :METHOD option yet." - )))) - (let ((declarations (initarg :declarations))) - (when declarations - (initarg :declarations `',declarations))))) - (make-top-level-form `(defgeneric ,function-specifier) - *defgeneric-times* - `(load-defgeneric ',function-specifier ',lambda-list ,@initargs)))) - -(defun load-defgeneric (function-specifier lambda-list &rest initargs) - (when (listp function-specifier) - (do-standard-defsetf-1 (cadr function-specifier))) - (apply #'ensure-generic-function function-specifier :lambda-list lambda-list - :definition-source `((defgeneric ,function-specifier) - ,(load-truename)) - initargs)) - - -;;; - - -(defmacro defmethod (&rest args &environment env) - (declare (arglist name {method-qualifier}* specialized-lambda-list &body body)) - (multiple-value-bind (name qualifiers lambda-list body) - (parse-defmethod args) - (let ((proto-method (method-prototype-for-gf name))) - (expand-defmethod proto-method name qualifiers lambda-list body env)))) - - -;;; takes a name which is either a generic function name or a list specifying a setf generic -;;; function (like: (SETF )). Returns the prototype instance of the -;;; method-class for that generic function. If there is no generic function by that name, this -;;; returns the default value, the prototype instance of the class STANDARD-METHOD. This default -;;; value is also returned if the spec names an ordinary function or even a macro. In effect, this -;;; leaves the signalling of the appropriate error until load time. NOTE that during bootstrapping, -;;; this function is allowed to return NIL. - - -(defun method-prototype-for-gf (name) - (let ((gf? (and (gboundp name) - (gdefinition name)))) - (cond ((neq *boot-state* 'complete) - nil) - ((or (null gf?) - (not (generic-function-p gf?))) - ; Someone else MIGHT error at load - ; time. - (class-prototype (find-class 'standard-method))) - (t (class-prototype (or (generic-function-method-class gf?) - (find-class 'standard-method))))))) - -(defun expand-defmethod (proto-method name qualifiers lambda-list body env) - (when (listp name) (do-standard-defsetf-1 (cadr name))) - (multiple-value-bind (fn-form specializers doc plist) - (expand-defmethod-internal name qualifiers lambda-list body env) - `(load-defmethod - ',(if proto-method - (class-name (class-of proto-method)) - 'standard-method) - ',name - ',qualifiers - (list ,@(mapcar #'(lambda (specializer) - (if (and (consp specializer) - (eq (car specializer) 'eql)) - ``(eql ,,(cadr specializer)) - `',specializer)) - specializers)) - ',(specialized-lambda-list-lambda-list lambda-list) - ',doc - ',(getf plist :isl-cache-symbol) ;Paper over a bug in KCL by - ;passing the cache-symbol - ;here in addition to in the - ;plist. - ',plist - ,fn-form))) - -(defun - expand-defmethod-internal - (generic-function-name qualifiers specialized-lambda-list body env) - (declare (values fn-form specializers doc) - (ignore qualifiers)) - (when (listp generic-function-name) - (do-standard-defsetf-1 (cadr generic-function-name))) - (multiple-value-bind - (documentation declarations real-body) - (extract-declarations body) - (multiple-value-bind - (parameters lambda-list specializers) - (parse-specialized-lambda-list specialized-lambda-list) - (let* - ((required-parameters (mapcar #'(lambda (r s) - (declare (ignore s)) - r) - parameters specializers)) - (parameters-to-reference (make-parameter-references specialized-lambda-list required-parameters - declarations generic-function-name specializers)) - (class-declarations - `(declare ,@(remove nil (mapcar #'(lambda (a s) - (and (symbolp s) - (neq s 't) - `(class ,a ,s))) - parameters specializers)))) - (method-lambda - - ;; Remove the documentation string and insert the appropriate class declarations. The - ;; documentation string is removed to make it easy for us to insert new declarations - ;; later, they will just go after the cadr of the method lambda. The class declarations - ;; are inserted to communicate the class of the method's arguments to the code walk. - (let nil `(lambda ,lambda-list ,class-declarations ,@declarations (progn - ,@ - parameters-to-reference - ) - (block ,(if (listp generic-function-name) - (cadr generic-function-name) - generic-function-name) - ,@real-body)))) - (call-next-method-p nil) - ; flag indicating that call-next-method - ; should be in the method definition - (closurep nil) - ; flag indicating that - ; #'call-next-method was seen in the - ; body of a method - (next-method-p-p nil) - ; flag indicating that next-method-p - ; should be in the method definition - (save-original-args nil) - ; flag indicating whether or not the - ; original arguments to the method must - ; be preserved. This happens for two - ; reasons: - the method takes &mumble - ; args, so one of the lexical functions - ; might be used in a default value form - ; - call-next-method is used without - ; arguments at least once in the body - ; of the method - (original-args nil) - (applyp nil) - ; flag indicating whether or not the - ; method takes &mumble arguments. If it - ; does, it means call-next-method - ; without arguments must be APPLY'd to - ; original-args. If this gets set - ; true, save-original-args is set so as - ; well - (aux-bindings nil) - ; Suffice to say that &aux is one of - ; damndest things to have put in a - ; language. - (slots (mapcar #'list required-parameters)) - (plist nil) - (walked-lambda nil)) - (flet ((walk-function (form context env) - (cond ((not (eq context ':eval)) - form) - ((not (listp form)) - form) - ((eq (car form) - 'call-next-method) - (setq call-next-method-p 't) - (unless (cdr form) - (setq save-original-args t)) - form) - ((eq (car form) - 'next-method-p) - (setq next-method-p-p 't) - form) - ((and (eq (car form) - 'function) - (cond ((eq (cadr form) - 'call-next-method) - (setq call-next-method-p 't) - (setq save-original-args 't) - (setq closurep t) - form) - ((eq (cadr form) - 'next-method-p) - (setq next-method-p-p 't) - (setq closurep t) - form) - (t nil)))) - ((and (or (eq (car form) - 'slot-value) - (eq (car form) - 'set-slot-value)) - (symbolp (cadr form)) - (constantp (caddr form))) - (let ((parameter (can-optimize-access (cadr form) - required-parameters env))) - (if (null parameter) - form - (ecase (car form) - (slot-value (optimize-slot-value slots parameter form)) - (set-slot-value (optimize-set-slot-value slots parameter form))) -))) - (t form)))) - (setq walked-lambda (walk-form method-lambda env #'walk-function)) - - ;; Add &allow-other-keys to the lambda list as an interim way of implementing lambda list - ;; congruence rules. - (when (and (memq '&key lambda-list) - (not (memq '&allow-other-keys lambda-list))) - (let* ((rll (reverse lambda-list)) - (aux (memq '&aux rll))) - (setq lambda-list (if aux - (progn (setf (cdr aux) - (cons '&allow-other-keys (cdr aux))) - (nreverse rll)) - (nconc (nreverse rll) - (list '&allow-other-keys)))))) - - ;; Scan the lambda list to determine whether this method takes &mumble arguments. If it - ;; does, we set applyp and save-original-args true. This is also the place where we - ;; construct the original arguments lambda list if there has to be one. - (dolist (p lambda-list) - (if (memq p lambda-list-keywords) - (if (eq p '&aux) - (progn (setq aux-bindings (cdr (memq '&aux lambda-list))) - (return nil)) - (progn (setq applyp t save-original-args t) - (push '&rest original-args) - (push (make-symbol "AMPERSAND-ARGS") - original-args) - (return nil))) - (push (make-symbol (symbol-name p)) - original-args))) - (setq original-args (if save-original-args - (nreverse original-args) - nil)) - (multiple-value-bind (ignore walked-declarations walked-lambda-body) - (extract-declarations (cddr walked-lambda)) - (declare (ignore ignore)) - (when (some #'cdr slots) - (setq slots (slot-name-lists-from-slots slots)) - (setq plist (list* :isl slots plist)) - (setq walked-lambda-body (add-pv-binding walked-lambda-body plist - required-parameters))) - (when (or next-method-p-p call-next-method-p) - (setq plist (list* :needs-next-methods-p 't plist))) - - -;;; changes are here... (mt) - - (let ((fn-body (if (or call-next-method-p next-method-p-p) - (add-lexical-functions-to-method-lambda - walked-declarations walked-lambda-body - `(lambda ,lambda-list ,@walked-declarations - ,.walked-lambda-body) - original-args lambda-list save-original-args applyp aux-bindings - call-next-method-p next-method-p-p closurep) - `(lambda ,lambda-list ,@walked-declarations ,.walked-lambda-body)) - )) - (values `#',fn-body specializers documentation plist)))))))) - -(defun - add-lexical-functions-to-method-lambda - (walked-declarations walked-lambda-body walked-lambda original-args lambda-list save-original-args - applyp aux-bindings call-next-method-p next-method-p-p closurep) - (cond - ((and (null closurep) - (null applyp) - (null save-original-args)) - - ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and all args are mandatory - ;; (else APPLYP would be true). - `(lambda ,lambda-list ,@walked-declarations - (let ((.next-method. (car *next-methods*)) - (.next-methods. (cdr *next-methods*))) - (macrolet ((call-next-method ,lambda-list '(if .next-method. - (let ((*next-methods* .next-methods.)) - (funcall .next-method. - ,@lambda-list)) - (error "No next method."))) - (next-method-p nil `(not (null .next-method.)))) - ,@walked-lambda-body)))) - ((and (null closurep) - (null applyp) - save-original-args) - - ;; OK to use MACROLET. CALL-NEXT-METHOD is sometimes called in the body with zero args, so we - ;; have to save the original args. - (if save-original-args - - ;; CALL-NEXT-METHOD is sometimes called with no args - `(lambda ,original-args - (let ((.next-method. (car *next-methods*)) - (.next-methods. (cdr *next-methods*))) - (macrolet ((call-next-method - (&rest cnm-args) - `(if .next-method. - (let ((*next-methods* .next-methods.)) - (funcall .next-method. ,@(if cnm-args - cnm-args - ',original-args))) - (error "No next method."))) - (next-method-p nil `(not (null .next-method.)))) - (let* (,@(mapcar #'list lambda-list original-args) - ,@aux-bindings) - ,@walked-declarations - ,@walked-lambda-body)))))) - ((and (null save-original-args) - (null applyp)) - - ;; We don't have to save the original arguments. In addition, this method doesn't take any - ;; &mumble arguments (this means that there is no way the lexical functions can be used inside of - ;; the default value form for an &mumble argument). We can expand this into a simple lambda - ;; expression with an FLET to define the lexical functions. - `(lambda ,lambda-list ,@walked-declarations - (let ((.next-method. (car *next-methods*)) - (.next-methods. (cdr *next-methods*))) - (flet (,@(and call-next-method-p '((call-next-method (&rest cnm-args) - (if .next-method. - (let ((*next-methods* .next-methods.)) - (apply .next-method. cnm-args)) - (error "No next method."))))) - ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.)))))) - ,@walked-lambda-body)))) - ((null applyp) - - ;; This method doesn't accept any &mumble arguments. But we do have to save the original - ;; arguments (this is because call-next-method is being called with no arguments). Have to be - ;; careful though, there may be multiple calls to call-next-method, all we know is that at least - ;; one of them is with no arguments. - `(lambda ,original-args - (let ((.next-method. (car *next-methods*)) - (.next-methods. (cdr *next-methods*))) - (flet (,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - (if .next-method. - (let ((*next-methods* .next-methods.)) - (if cnm-args - (apply .next-method. cnm-args) - (funcall .next-method. ,@original-args))) - (error "No next method."))))) - ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.)))))) - (let* (,@(mapcar #'list (remtail lambda-list (memq '&aux lambda-list)) - original-args) - ,@aux-bindings) - ,@walked-declarations - ,@walked-lambda-body))))) - (t - - ;; This is the fully general case. We must allow for the lexical functions being used inside the - ;; default value forms of &mumble arguments, and if must allow for call-next-method being called - ;; with no arguments. - `(lambda - ,original-args - (let - ((.next-method. (car *next-methods*)) - (.next-methods. (cdr *next-methods*))) - (flet (,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - (if .next-method. - (let ((*next-methods* .next-methods.)) - (if cnm-args - (apply .next-method. cnm-args) - (apply .next-method. ,@(remove '&rest original-args)))) - (error "No next method."))))) - ,@(and next-method-p-p '((next-method-p nil (not (null .next-method.)))))) - (apply #',walked-lambda ,@(remove '&rest original-args)))))))) - -(defun make-parameter-references (specialized-lambda-list required-parameters declarations - generic-function-name specializers) - (flet ((ignoredp (symbol) - (dolist (decl (cdar declarations)) - (when (and (eq (car decl) - 'ignore) - (memq symbol (cdr decl))) - (return t))))) - (gathering ((references (collecting))) - (iterate ((s (list-elements specialized-lambda-list)) - (p (list-elements required-parameters))) - (progn p) - (cond ((not (listp s))) - ((ignoredp (car s)) - (warn "In defmethod ~S ~S, there is a~%~ - redundant ignore declaration for the parameter ~S." generic-function-name - specializers (car s))) - (t (gather (car s) - references))))))) - -(defvar *method-function-plist* (make-hash-table :test #'eq)) - -(defun method-function-plist (method-function) - (gethash method-function *method-function-plist*)) - -(defun |SETF CLOS METHOD-FUNCTION-PLIST| (val method-function) - (setf (gethash method-function *method-function-plist*) - val)) - -(defun method-function-get (method-function key) - (getf (method-function-plist method-function) - key)) - -(defun |SETF CLOS METHOD-FUNCTION-GET| (val method-function key) - (setf (getf (method-function-plist method-function) - key) - val)) - -(defun method-function-isl (method-function) - (method-function-get method-function :isl)) - -(defun method-function-needs-next-methods-p (method-function) - (method-function-get method-function :needs-next-methods-p)) - -(defun load-defmethod (class name quals specls ll doc isl-cache-symbol plist fn) - (when (listp name) - (do-standard-defsetf-1 (cadr name))) - (let ((method-spec (make-method-spec name quals specls))) - (record-definition 'method method-spec) - (setq fn (set-function-name fn method-spec)) - (load-defmethod-internal name quals specls ll doc isl-cache-symbol plist fn class))) - -(defun load-defmethod-internal (gf-spec qualifiers specializers lambda-list doc isl-cache-symbol - plist fn method-class) - (when (listp gf-spec) - (do-standard-defsetf-1 (cadr gf-spec))) - (when plist - (setq plist (copy-list plist)) - ; Do this to keep from affecting the - ; plist that is about to be dumped when - ; we are compiling. - (let ((uisl (getf plist :isl)) - (isl nil)) - (when uisl - (setq isl (intern-slot-name-lists uisl)) - (setf (getf plist :isl) - isl)) - (when isl-cache-symbol - (setf (getf plist :isl-cache-symbol) - isl-cache-symbol) - (set isl-cache-symbol isl))) - (setf (method-function-plist fn) - plist)) - (let ((method (add-named-method gf-spec qualifiers specializers lambda-list fn :documentation - doc :definition-source `((defmethod ,gf-spec ,@qualifiers ,specializers) - ,(load-truename))))) - (unless (or (eq method-class 'standard-method) - (eq (find-class method-class nil) - (class-of method))) - (format *error-output* "At the time the method with qualifiers ~:~S and~%~ - specializers ~:S on the generic function ~S~%~ - was compiled, the method-class for that generic function was~%~ - ~S. But, the method class is now ~S, this~%~ - may mean that this method was compiled improperly." qualifiers specializers gf-spec - method-class (class-name (class-of method)))) - method)) - -(defun make-method-spec (gf-spec qualifiers unparsed-specializers) - `(method ,gf-spec ,@qualifiers ,unparsed-specializers)) - - ; Early generic-function support - - - -;;; - - -(defvar *early-generic-functions* nil) - -(defun ensure-generic-function (function-specifier &rest all-keys &key environment &allow-other-keys) - (declare (ignore environment)) - (let ((existing (and (gboundp function-specifier) - (gdefinition function-specifier)))) - (if (and existing (eq *boot-state* 'complete) - (null (generic-function-p existing))) - (generic-clobbers-function function-specifier) - (apply #'ensure-generic-function-using-class existing function-specifier all-keys)))) - -(defun generic-clobbers-function (function-specifier) - (error "~S already names an ordinary function or a macro,~%~ - you may want to replace it with a generic function, but doing so~%~ - will require that you decide what to do with the existing function~%~ - definition.~%~ - The CLOS-specific function MAKE-SPECIALIZABLE may be useful to you." - function-specifier)) - - -;;; This is the early definition of ensure-generic-function-using-class. The static-slots field of -;;; the funcallable instances used as early generic functions is used to store the early methods and -;;; early discriminator code for the early generic function. The static slots field of the fins -;;; contains a list whose: CAR - a list of the early methods on this early gf CADR - the -;;; early discriminator code for this method - - -(defun ensure-generic-function-using-class (existing spec &rest keys) - (declare (ignore keys)) - (if* existing existing (pushnew spec *early-generic-functions* :test #'equal) - (let ((fin (allocate-funcallable-instance-1))) - (setf (gdefinition spec) - fin) - (setf (fsc-instance-slots fin) - (list nil nil)) - fin))) - -(defun early-gf-p (x) - (and (fsc-instance-p x) - (listp (fsc-instance-slots x)))) - -(defmacro early-gf-methods (early-gf) - ; These are macros so that - `(car (fsc-instance-slots ,early-gf))) - - ; they can be setf'd. - - -(defmacro early-gf-discriminator-code (early-gf) - ; - `(cadr (fsc-instance-slots ,early-gf))) - - ; - - -(defmacro real-ensure-gf-internal (gf-class all-keys env) - `(progn (cond ((symbolp ,gf-class) - (setq ,gf-class (find-class ,gf-class t ,env))) - ((classp ,gf-class)) - (t (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ - class nor a symbol that names a class." ,gf-class))) - (remf ,all-keys :generic-function-class) - (remf ,all-keys :environment) - (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) - (unless (eq combin '.shes-not-there.) - (setf (getf ,all-keys :method-combination) - (find-method-combination (class-prototype ,gf-class) - (car combin) - (cdr combin))))))) - -(defun real-ensure-gf-using-class--generic-function (existing function-specifier &rest all-keys &key - environment (generic-function-class - 'standard-generic-function - gf-class-p) - &allow-other-keys) - (declare (ignore function-specifier)) - (real-ensure-gf-internal generic-function-class all-keys environment) - (unless (or (null gf-class-p) - (eq (class-of existing) - generic-function-class)) - (change-class existing generic-function-class)) - (apply #'reinitialize-instance existing all-keys)) - -(defun real-ensure-gf-using-class--null (existing function-specifier &rest all-keys &key environment - (generic-function-class 'standard-generic-function) - &allow-other-keys) - (declare (ignore existing)) - (real-ensure-gf-internal generic-function-class all-keys environment) - (setf (gdefinition function-specifier) - (apply #'make-instance generic-function-class :name function-specifier all-keys))) - -(defun early-make-a-method (class qualifiers arglist specializers function doc &optional slot-name) - (let ((parsed nil) - (unparsed nil)) - - ;; Figure out whether we got class objects or class names as the specializers and set - ;; parsed and unparsed appropriately. If we got class objects, then we can compute - ;; unparsed, but if we got class names we don't try to compute parsed. Note that the use - ;; of not symbolp in this call to every should be read as 'classp' we can't use classp - ;; itself because it doesn't exist yet. - (if (every #'(lambda (s) - (not (symbolp s))) - specializers) - (setq parsed specializers unparsed (mapcar #'(lambda (s) - (if (eq s 't) - 't - (class-name s))) - specializers)) - (setq unparsed specializers parsed nil)) - (list :early-method ; This is an early method dammit! - function - ; Function is here for the benefit of - ; early-lookup-method. - parsed - ; The parsed specializers. This is - ; used by early-method-specializers to - ; cache the parse. Note that this only - ; comes into play when there is more - ; than one early method on an early gf. - (list class ; A list to which real-make-a-method - qualifiers - ; can be applied to make a real method - arglist - ; corresponding to this early one. - unparsed function doc slot-name)))) - -(defun real-make-a-method (class qualifiers lambda-list specializers function doc &optional slot-name - ) - - ;; Hmm what is this use of when buying me?? - (when (some #'(lambda (x) - (and (neq x 't) - (symbolp x))) - specializers) - (setq specializers (parse-specializers specializers))) - (make-instance class :qualifiers qualifiers :lambda-list lambda-list :specializers - specializers :function function :documentation doc :slot-name slot-name - :allow-other-keys t)) - -(defun early-method-function (early-method) - (cadr early-method)) - - -;;; Fetch the specializers of an early method. This is basically just a simple accessor except that -;;; when the second argument is t, this converts the specializers from symbols into class objects. -;;; The class objects are cached in the early method, this makes bootstrapping faster because the -;;; class objects only have to be computed once. NOTE: the second argument should only be passed as -;;; T by early-lookup-method. this is to implement the rule that only when there is more than one -;;; early method on a generic function is the conversion from class names to class objects done. the -;;; corresponds to the fact that we are only allowed to have one method on any generic function up -;;; until the time classes exist. - - -(defun early-method-specializers (early-method &optional objectsp) - (if (and (listp early-method) - (eq (car early-method) - :early-method)) - (cond ((eq objectsp 't) - (or (caddr early-method) - (setf (caddr early-method) - (mapcar #'find-class (cadddr (cadddr early-method)))))) - (t (cadddr (cadddr early-method)))) - (error "~S is not an early-method." early-method))) - -(defun early-method-qualifiers (early-method) - (cadr (cadddr early-method))) - -(defun early-add-named-method (generic-function-name qualifiers specializers arglist function &rest - options) - (declare (ignore options)) - (let* ((gf (ensure-generic-function generic-function-name)) - (existing (dolist (m (early-gf-methods gf)) - (when (and (equal (early-method-specializers m) - specializers) - (equal (early-method-qualifiers m) - qualifiers)) - (return m)))) - (new (make-a-method 'standard-method qualifiers arglist specializers function nil))) - (when existing (remove-method gf existing)) - (add-method gf new))) - - -;;; This is the early version of add-method. Later this will become a generic function. See -;;; fix-early-generic-functions which has special knowledge about add-method. - - -(defun add-method (generic-function method) - (when (not (fsc-instance-p generic-function)) - (error "Early add-method didn't get a funcallable instance.")) - (when (not (and (listp method) - (eq (car method) - :early-method))) - (error "Early add-method didn't get an early method.")) - (push method (early-gf-methods generic-function)) - (early-update-discriminator-code generic-function)) - - -;;; This is the early version of remove method. - - -(defun remove-method (generic-function method) - (when (not (fsc-instance-p generic-function)) - (error "Early remove-method didn't get a funcallable instance.")) - (when (not (and (listp method) - (eq (car method) - :early-method))) - (error "Early remove-method didn't get an early method.")) - (setf (early-gf-methods generic-function) - (remove method (early-gf-methods generic-function))) - (early-update-discriminator-code generic-function)) - - -;;; And the early version of get-method. - - -(defun get-method (generic-function qualifiers specializers &optional (errorp t)) - (if (early-gf-p generic-function) - (or (dolist (m (early-gf-methods generic-function)) - (when (and (or (equal (early-method-specializers m nil) - specializers) - (equal (early-method-specializers m 't) - specializers)) - (equal (early-method-qualifiers m) - qualifiers)) - (return m))) - (if errorp - (error "Can't get early method.") - nil)) - (real-get-method generic-function qualifiers specializers errorp))) - -(defun early-update-discriminator-code (generic-function) - (let* ((methods (early-gf-methods generic-function)) - (early-dfun (cond ((null methods) - #'(lambda (&rest ignore) - (declare (ignore ignore)) - (error - "Called an early generic-function that ~ - has no methods?"))) - ((null (cdr methods)) - - ;; If there is only one method, just use that method's function. - ;; This corresponds to the important fact that early - ;; generic-functions with only one method always call that method - ;; when they are called. If there is more than one method, we have - ;; to install a simple little discriminator-code for this generic - ;; function. - (cadr (car methods))) - (t #'(lambda (&rest args) - (early-dfun methods args)))))) - (set-funcallable-instance-function generic-function early-dfun) - (setf (early-gf-discriminator-code generic-function) - early-dfun))) - -(defun early-get-cpl (object) - (bootstrap-get-slot 'std-class ; HMMM? should be CLOS-CLASS - (class-of object) - 'class-precedence-list)) - -(defun early-sort-methods (list args) - (if (null (cdr list)) - list - (sort list #'(lambda (specls-1 specls-2) - (iterate ((s1 (list-elements specls-1)) - (s2 (list-elements specls-2)) - (a (list-elements args))) - (cond ((eq s1 s2)) - ((eq s2 *the-class-t*) - (return t)) - ((eq s1 *the-class-t*) - (return nil)) - (t (return (memq s2 (memq s1 (early-get-cpl a)))))))) - :key - #'(lambda (em) - (early-method-specializers em t))))) - -(defun early-dfun (methods args) - (let ((primary nil) - (before nil) - (after nil) - (around nil)) - (dolist (method methods) - (let* ((specializers (early-method-specializers method t)) - (qualifiers (early-method-qualifiers method)) - (args args) - (specs specializers)) - (when (loop (when (or (null args) - (null specs)) - - - ;; If we are out of specs, then we must be in the optional, rest or - ;; keywords arguments. This method is applicable to these - ;; arguments. Return T. - (return t)) - (let ((arg (pop args)) - (spec (pop specs))) - (unless (or (eq spec *the-class-t*) - (memq spec (early-get-cpl arg))) - (return nil)))) - (cond ((null qualifiers) - (push method primary)) - ((equal qualifiers '(:before)) - (push method before)) - ((equal qualifiers '(:after)) - (push method after)) - ((equal qualifiers '(:around)) - (push method around)) - (t (error "Unrecognized qualifer in early method.")))))) - (setq primary (early-sort-methods primary args) - before - (early-sort-methods before args) - after - (early-sort-methods after args) - around - (early-sort-methods around args)) - (flet ((do-main-combined-method (arguments) - (dolist (m before) - (apply (cadr m) - arguments)) - (multiple-value-prog1 (let ((*next-methods* (mapcar #'car (cdr primary)))) - (apply (cadar primary) - arguments)) - (dolist (m after) - (apply (cadr m) - arguments))))) - (if (null around) - (do-main-combined-method args) - (let ((*next-methods* (append (mapcar #'cadr (cdr around)) - #'do-main-combined-method))) - (apply (caar around) - args)))))) - -(defun - fix-early-generic-functions - (&optional noisyp) - (allocate-instance (find-class 'standard-generic-function)) - ; Be sure this class has an instance. - (let* ((class (find-class 'standard-generic-function)) - (wrapper (class-wrapper class)) - (n-static-slots (class-no-of-instance-slots class)) - (default-initargs (default-initargs class nil)) - (*invalidate-discriminating-function-force-p* t)) - (flet ((fix-structure (gf) - (let ((static-slots (%allocate-static-slot-storage--class n-static-slots))) - (setf (fsc-instance-wrapper gf) - wrapper - (fsc-instance-slots gf) - static-slots)))) - (dolist (early-gf-spec *early-generic-functions*) - (when noisyp (format t "~&~S..." early-gf-spec)) - (let* ((early-gf (gdefinition early-gf-spec)) - (early-static-slots (fsc-instance-slots early-gf)) - (early-discriminator-code nil) - (early-methods nil) - (methods nil) - (aborted t)) - (flet ((trampoline (&rest args) - (apply early-discriminator-code args))) - (if (not (listp early-static-slots)) - (when noisyp (format t "already fixed?")) - (unwind-protect - (progn (setq early-discriminator-code ( - early-gf-discriminator-code - early-gf)) - (setq early-methods (early-gf-methods early-gf)) - (setf (gdefinition early-gf-spec) - #'trampoline) - (when noisyp (format t "trampoline...")) - (fix-structure early-gf) - (when noisyp (format t "fixed...")) - (apply #'initialize-instance early-gf :name early-gf-spec - default-initargs) - (dolist (early-method early-methods) - (destructuring-bind (class quals lambda-list specs fn - doc slot-name) - (cadddr early-method) - (setq specs (early-method-specializers - early-method t)) - (let ((method (real-make-a-method class quals - lambda-list specs fn doc - slot-name))) - (real-add-method early-gf method) - (push method methods) - (when noisyp (format t "m"))))) - (setf (slot-value early-gf 'name) - early-gf-spec) - (fixup-magic-generic-function early-gf-spec early-methods - early-gf (reverse methods)) - (setq aborted nil)) - (setf (gdefinition early-gf-spec) - early-gf) - (when noisyp (format t ".")) - (when aborted - (setf (fsc-instance-slots early-gf) - early-static-slots))))))) - (dolist (fns *early-functions*) - (setf (symbol-function (car fns)) - (symbol-function (caddr fns)))) - (dolist (fixup *generic-function-fixups*) - (let ((fspec (car fixup)) - (methods (cdr fixup)) - (gf (make-instance 'standard-generic-function))) - (set-function-name gf fspec) - (setf (generic-function-name gf) - fspec) - (dolist (method methods) - (destructuring-bind (lambda-list specializers method-fn-name) - method - (let* ((fn (if method-fn-name - (symbol-function method-fn-name) - (symbol-function fspec))) - (method (make-a-method 'standard-method nil lambda-list - specializers fn nil))) - (real-add-method gf method)))) - (setf (gdefinition fspec) - gf)))))) - - -;;; parse-defmethod is used by defmethod to parse the &rest argument into the 'real' arguments. -;;; This is where the syntax of defmethod is really implemented. - - -(defun parse-defmethod (cdr-of-form) - (declare (values name qualifiers specialized-lambda-list body)) - (let ((name (pop cdr-of-form)) - (qualifiers nil) - (spec-ll nil)) - (loop (if (and (car cdr-of-form) - (atom (car cdr-of-form))) - (push (pop cdr-of-form) - qualifiers) - (return (setq qualifiers (nreverse qualifiers))))) - (setq spec-ll (pop cdr-of-form)) - (values name qualifiers spec-ll cdr-of-form))) - -(defun parse-specializers (specializers) - (flet ((parse (spec) - (cond ((symbolp spec) - (or (find-class spec nil) - (error - "~S used as a specializer,~%~ - but is not the name of a class." spec))) - ((and (listp spec) - (eq (car spec) - 'eql) - (null (cddr spec))) - (make-instance 'eql-specializer :object (cadr spec)) - ; *EQL* spec - ) - (t (error "~S is not a legal specializer." spec))))) - (mapcar #'parse specializers))) - -(defun unparse-specializers (specializers-or-method) - (if (listp specializers-or-method) - (flet ((unparse (spec) - (cond ((classp spec) - (or (class-name spec) - spec)) - ((eql-specializer-p spec) - ; *EQL* - (eql-specializer-object spec) - ; (and (listp spec) (eq (car spec) - ; 'eql)) spec - ) - (t (error "~S is not a legal specializer." spec))))) - (mapcar #'unparse specializers-or-method)) - (unparse-specializers (method-specializers specializers-or-method)))) - -(defun parse-method-or-spec (spec &optional (errorp t)) - (declare (values generic-function method method-name)) - (let (gf method name temp) - (if (method-p spec) - (setq method spec gf (method-generic-function method) - temp - (and gf (generic-function-name gf)) - name - (if temp - (intern-function-name (make-method-spec temp (method-qualifiers method) - (unparse-specializers (method-specializers - method)))) - (make-symbol (format nil "~S" method)))) - (multiple-value-bind (gf-spec quals specls) - (parse-defmethod spec) - (and (setq gf (and (or errorp (gboundp gf-spec)) - (gdefinition gf-spec))) - (let ((nreq (compute-discriminating-function-arglist-info gf))) - (setq specls (append (parse-specializers specls) - (make-list (- nreq (length specls)) - :initial-element *the-class-t*))) - (and (setq method (get-method gf quals specls errorp)) - (setq name (intern-function-name (make-method-spec gf-spec - quals specls)))))))) - (values gf method name))) - -(defun specialized-lambda-list-parameters (specialized-lambda-list) - (multiple-value-bind (parameters ignore1 ignore2) - (parse-specialized-lambda-list specialized-lambda-list) - (declare (ignore ignore1 ignore2)) - parameters)) - -(defun specialized-lambda-list-lambda-list (specialized-lambda-list) - (multiple-value-bind (ignore1 lambda-list ignore2) - (parse-specialized-lambda-list specialized-lambda-list) - (declare (ignore ignore1 ignore2)) - lambda-list)) - -(defun specialized-lambda-list-specializers (specialized-lambda-list) - (multiple-value-bind (ignore1 ignore2 specializers) - (parse-specialized-lambda-list specialized-lambda-list) - (declare (ignore ignore1 ignore2)) - specializers)) - -(defun specialized-lambda-list-required-parameters (specialized-lambda-list) - (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters) - (parse-specialized-lambda-list specialized-lambda-list) - (declare (ignore ignore1 ignore2 ignore3)) - required-parameters)) - -(defun parse-specialized-lambda-list (arglist &optional post-keyword) - (declare (values parameters lambda-list specializers required-parameters)) - (let ((arg (car arglist))) - (cond ((null arglist) - (values nil nil nil nil)) - ((eq arg '&aux) - (values nil arglist nil)) - ((memq arg lambda-list-keywords) - (unless (memq arg '(&optional &rest &key &allow-other-keys &aux)) - - ;; Warn about non-standard lambda-list-keywords, but then go on to treat them - ;; like a standard lambda-list-keyword what with the warning its probably ok. - (warn "Unrecognized lambda-list keyword ~S in arglist.~%~ - Assuming that the symbols following it are parameters,~%~ - and not allowing any parameter specializers to follow~%~ - to follow it." arg)) - - ;; When we are at a lambda-list-keyword, the parameters don't include the - ;; lambda-list-keyword; the lambda-list does include the lambda-list-keyword; and - ;; no specializers are allowed to follow the lambda-list-keywords (at least for - ;; now). - (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) - t) - (values parameters (cons arg lambda-list) - nil nil))) - (post-keyword - - ;; After a lambda-list-keyword there can be no specializers. - (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) - t) - (values (cons (if (listp arg) - (car arg) - arg) - parameters) - (cons arg lambda-list) - nil nil))) - (t (multiple-value-bind (parameters lambda-list specializers required) - (parse-specialized-lambda-list (cdr arglist)) - (values (cons (if (listp arg) - (car arg) - arg) - parameters) - (cons (if (listp arg) - (car arg) - arg) - lambda-list) - (cons (if (listp arg) - (cadr arg) - 't) - specializers) - (cons (if (listp arg) - (car arg) - arg) - required))))))) - -(eval-when (load eval) - (setq *boot-state* 'early)) - -(defmacro with-slots (slots instance &body body &environment env) - (let ((gensym (gensym)) - (specs (mapcar #'(lambda (ss) - (if (consp ss) - (list (car ss) - (variable-lexical-p (car ss) - env) - (cadr ss)) - (list ss (variable-lexical-p ss env) - ss))) - slots))) - (expand-with-slots specs body env gensym instance - #'(lambda (s) - `(slot-value ,gensym ',s))))) - -(defmacro with-accessors (slot-accessor-pairs instance &body body &environment env) - (let ((gensym (gensym)) - (specs (mapcar #'(lambda (ss) - (list (car ss) - (variable-lexical-p (car ss) - env) - (cadr ss))) - slot-accessor-pairs))) - (expand-with-slots specs body env gensym instance #'(lambda (a) - `(,a ,gensym))))) - -(defun expand-with-slots (specs body env gensym instance translate-fn) - `(let ((,gensym ,instance)) - ,@(and (symbolp instance) - `((declare (variable-rebinding ,gensym ,instance)))) - ,gensym - ,@(cdr (walk-form `(progn ,@body) - env - #'(lambda (f c e) - (expand-with-slots-internal specs f c translate-fn e)))))) - -(defun expand-with-slots-internal (specs form context translate-fn env) - (let ((entry nil)) - (cond ((not (eq context :eval)) - form) - ((symbolp form) - (if (and (setq entry (assoc form specs)) - (eq (cadr entry) - (variable-lexical-p form env))) - (funcall translate-fn (caddr entry)) - form)) - ((not (listp form)) - form) - ((member (car form) - '(setq setf)) - - ;; Have to be careful. We must only convert the form to a SETF form when we - ;; convert one of the 'logical' variables to a form Otherwise we will get looping - ;; in implementations where setf is a macro which expands into setq. - (let ((kind (car form))) - (labels ((scan-setf (tail) - (if (null tail) - nil - (walker::relist* tail - (if (and (setq entry (assoc (car tail) - specs)) - (eq (cadr entry) - (variable-lexical-p (car tail) - env))) - (progn (setq kind 'setf) - (funcall translate-fn (caddr entry))) - (car tail)) - (cadr tail) - (scan-setf (cddr tail)))))) - (let (new-tail) - (setq new-tail (scan-setf (cdr form))) - (walker::recons form kind new-tail))))) - ((eq (car form) - 'multiple-value-setq) - (let* ((vars (cadr form)) - (gensyms (mapcar #'(lambda (i) - (declare (ignore i)) - (gensym)) - vars))) - `(multiple-value-bind ,gensyms ,(caddr form) - . ,(reverse (mapcar #'(lambda (v g) - `(setf ,v ,g)) - vars gensyms))))) - (t form)))) diff --git a/obsolete/clos/2.0/braid.lisp b/obsolete/clos/2.0/braid.lisp deleted file mode 100644 index 80424b6a..00000000 --- a/obsolete/clos/2.0/braid.lisp +++ /dev/null @@ -1,503 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; Bootstrapping the meta-braid. -;;; -;;; The code in this file takes the early definitions that have been saved -;;; up and actually builds those class objects. This work is largely driven -;;; off of those class definitions, but the fact that STANDARD-CLASS is the -;;; class of all metaclasses in the braid is built into this code pretty -;;; deeply. -;;; -;;; - -(in-package 'clos) - -(defun early-class-definition (class-name) - (or (find class-name *early-class-definitions* :key #'ecd-class-name) - (error "~S is not a class in *early-class-definitions*." class-name))) - -(defun canonical-slot-name (canonical-slot) - (getf canonical-slot :name)) - -(defun early-collect-inheritance (class-name) - (declare (values slots cpl default-initargs direct-subclasses)) - (let ((cpl (early-collect-cpl class-name))) - (values (early-collect-slots cpl) - cpl - (early-collect-default-initargs cpl) - (gathering1 (collecting) - (dolist (definition *early-class-definitions*) - (when (memq class-name (ecd-superclass-names definition)) - (gather1 (ecd-class-name definition)))))))) - -(defun early-collect-cpl (class-name) - (labels ((walk (c) - (let* ((definition (early-class-definition c)) - (supers (ecd-superclass-names definition))) - (cons c - (apply #'append (mapcar #'early-collect-cpl supers)))))) - (remove-duplicates (walk class-name) :from-end nil :test #'eq))) - -(defun early-collect-slots (cpl) - (let* ((definitions (mapcar #'early-class-definition cpl)) - (super-slots (mapcar #'ecd-canonical-slots definitions)) - (slots (apply #'append (reverse super-slots)))) - (dolist (s1 slots) - (let ((name1 (canonical-slot-name s1))) - (dolist (s2 (cdr (memq s1 slots))) - (when (eq name1 (canonical-slot-name s2)) - (error "More than one early class defines a slot with the~%~ - name ~S. This can't work because the bootstrap~%~ - object system doesn't know how to compute effective~%~ - slots." - name1))))) - slots)) - -(defun early-collect-default-initargs (cpl) - (let ((default-initargs ())) - (dolist (class-name cpl) - (let ((definition (early-class-definition class-name))) - (dolist (option (ecd-other-initargs definition)) - (unless (eq (car option) :default-initargs) - (error "The defclass option ~S is not supported by the bootstrap~%~ - object system." - (car option))) - (setq default-initargs - (nconc default-initargs (reverse (cdr option))))))) - (reverse default-initargs))) - - -;;; -;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change -;;; the values of slots during bootstrapping. During bootstrapping, there -;;; are only two kinds of objects whose slots we need to access, CLASSes -;;; and SLOTDs. The first argument to these functions tells whether the -;;; object is a CLASS or a SLOTD. -;;; -;;; Note that the way this works it stores the slot in the same place in -;;; memory that the full object system will expect to find it later. This -;;; is critical to the bootstrapping process, the whole changeover to the -;;; full object system is predicated on this. -;;; -;;; One important point is that the layout of standard classes and standard -;;; slots must be computed the same way in this file as it is by the full -;;; object system later. -;;; -(defun bootstrap-get-slot (type object slot-name) - (let ((index (bootstrap-slot-index type slot-name))) - (svref (std-instance-slots object) index))) - -(defun bootstrap-set-slot (type object slot-name new-value) - (let ((index (bootstrap-slot-index type slot-name))) - (setf (svref (std-instance-slots object) index) new-value))) - -(defvar *std-class-slots* - (mapcar #'canonical-slot-name - (early-collect-inheritance 'standard-class))) - -(defvar *bin-class-slots* - (mapcar #'canonical-slot-name - (early-collect-inheritance 'built-in-class))) - -(defvar *std-slotd-slots* - (mapcar #'canonical-slot-name - (early-collect-inheritance 'standard-slot-definition))) - -(defun bootstrap-slot-index (type slot-name) - (or (position slot-name (ecase type - (std-class *std-class-slots*) - (bin-class *bin-class-slots*) - (std-slotd *std-slotd-slots*))) - (error "~S not found" slot-name))) - - -;;; -;;; bootstrap-meta-braid -;;; -;;; This function builds the base metabraid from the early class definitions. -;;; -(defun bootstrap-meta-braid () - (let* ((std-class-size (length *std-class-slots*)) - (std-class (%allocate-instance--class std-class-size)) - (std-class-wrapper (make-wrapper std-class)) - (built-in-class (%allocate-instance--class std-class-size)) - (built-in-class-wrapper (make-wrapper built-in-class)) - (direct-slotd (%allocate-instance--class std-class-size)) - (effective-slotd (%allocate-instance--class std-class-size)) - (direct-slotd-wrapper (make-wrapper direct-slotd)) - (effective-slotd-wrapper (make-wrapper effective-slotd))) - ;; - ;; First, make a class metaobject for each of the early classes. For - ;; each metaobject we also set its wrapper. Except for the class T, - ;; the wrapper is always that of STANDARD-CLASS. - ;; - (dolist (definition *early-class-definitions*) - (let* ((name (ecd-class-name definition)) - (meta (ecd-metaclass definition)) - (class (case name - (standard-class std-class) - (standard-direct-slot-definition direct-slotd) - (standard-effective-slot-definition effective-slotd) - (built-in-class built-in-class) - (otherwise - (%allocate-instance--class std-class-size))))) - (unless (eq name t) - (inform-type-system-about-class class name)) - (setf (std-instance-wrapper class) - (ecase meta - (standard-class std-class-wrapper) - (built-in-class built-in-class-wrapper))) - (setf (find-class name) class))) - ;; - ;; - ;; - (dolist (definition *early-class-definitions*) - (let ((name (ecd-class-name definition)) - (source (ecd-source definition)) - (direct-supers (ecd-superclass-names definition)) - (direct-slots (ecd-canonical-slots definition)) - (other-initargs (ecd-other-initargs definition))) - (let ((direct-default-initargs - (getf other-initargs :default-initargs))) - (multiple-value-bind (slots cpl default-initargs direct-subclasses) - (early-collect-inheritance name) - (let* ((class (find-class name)) - (wrapper - (cond - ((eq class std-class) std-class-wrapper) - ((eq class direct-slotd) direct-slotd-wrapper) - ((eq class effective-slotd) effective-slotd-wrapper) - ((eq class built-in-class) built-in-class-wrapper) - (t (make-wrapper class)))) - (proto nil)) - (cond ((eq name 't) - (setq *the-wrapper-of-t* wrapper - *the-class-t* class)) - ((memq name '(standard-object - standard-class - standard-effective-slot-definition)) - (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name)) - *the-clos-package*) - class))) - (dolist (slot slots) - (unless (eq (getf slot :allocation :instance) :instance) - (error "Slot allocation ~S not supported in bootstrap."))) - - (setf (wrapper-instance-slots-layout wrapper) - (mapcar #'canonical-slot-name slots)) - (setf (wrapper-class-slots wrapper) - ()) - - (setq proto (%allocate-instance--class (length slots))) - (setf (std-instance-wrapper proto) wrapper) - - (setq direct-slots - (bootstrap-make-slot-definitions name direct-slots - direct-slotd-wrapper nil)) - (setq slots - (bootstrap-make-slot-definitions name slots - effective-slotd-wrapper t)) - - (bootstrap-initialize-std-class - class name source - direct-supers direct-subclasses cpl wrapper - direct-slots slots direct-default-initargs default-initargs - proto) - - (dolist (slotd direct-slots) - (bootstrap-accessor-definitions - name - (bootstrap-get-slot 'std-slotd slotd 'name) - (bootstrap-get-slot 'std-slotd slotd 'readers) - (bootstrap-get-slot 'std-slotd slotd 'writers)))))))))) - -(defun bootstrap-accessor-definitions (class-name slot-name readers writers) - (flet ((do-reader-definition (reader) - (add-method - (ensure-generic-function reader) - (make-a-method - 'standard-reader-method - () - (list class-name) - (list class-name) - (make-std-reader-method-function slot-name) - "automatically generated reader method" - slot-name))) - (do-writer-definition (writer) - (add-method - (ensure-generic-function writer) - (make-a-method - 'standard-writer-method - () - (list 'new-value class-name) - (list 't class-name) - (make-std-writer-method-function slot-name) - "automatically generated writer method" - slot-name)))) - (dolist (reader readers) (do-reader-definition reader)) - (dolist (writer writers) (do-writer-definition writer)))) - -;;; -;;; Initialize a standard class metaobject. -;;; -(defun bootstrap-initialize-std-class - (class - name definition-source direct-supers direct-subclasses cpl wrapper - direct-slots slots direct-default-initargs default-initargs proto) - (flet ((classes (names) (mapcar #'find-class names)) - (set-slot (slot-name value) - (bootstrap-set-slot 'std-class class slot-name value))) - - (set-slot 'name name) - (set-slot 'source definition-source) - (set-slot 'class-precedence-list (classes cpl)) - (set-slot 'direct-superclasses (classes direct-supers)) - (set-slot 'direct-slots direct-slots) - (set-slot 'direct-subclasses (classes direct-subclasses)) - (set-slot 'direct-methods (cons nil nil)) - (set-slot 'no-of-instance-slots (length slots)) - (set-slot 'slots slots) - (set-slot 'wrapper wrapper) - (set-slot 'prototype proto) - (set-slot 'plist - `(,@(and direct-default-initargs - `(direct-default-initargs ,direct-default-initargs)) - ,@(and default-initargs - `(default-initargs ,default-initargs)))) - )) - -;;; -;;; Initialize a built-in-class metaobject. -;;; -(defun bootstrap-initialize-bin-class - (class - name definition-source direct-supers direct-subclasses cpl wrapper) - (flet ((classes (names) (mapcar #'find-class names)) - (set-slot (slot-name value) - (bootstrap-set-slot 'bin-class class slot-name value))) - - (set-slot 'name name) - (set-slot 'source definition-source) - (set-slot 'direct-superclasses (classes direct-supers)) - (set-slot 'direct-subclasses (classes direct-subclasses)) - (set-slot 'direct-methods (cons nil nil)) - (set-slot 'class-precedence-list (classes cpl)) - (set-slot 'wrapper wrapper))) - -(defun bootstrap-make-slot-definitions (name slots wrapper e-p) - (mapcar #'(lambda (slot) (bootstrap-make-slot-definition name slot wrapper e-p)) - slots)) - -(defun bootstrap-make-slot-definition (name slot wrapper e-p) - (let ((slotd (%allocate-instance--class (length *std-slotd-slots*)))) - (setf (std-instance-wrapper slotd) wrapper) - (flet ((get-val (name) (getf slot name)) - (set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val))) - (set-val 'name (get-val :name)) - (set-val 'initform (get-val :initform)) - (set-val 'initfunction (get-val :initfunction)) - (set-val 'initargs (get-val :initargs)) - (set-val 'readers (get-val :readers)) - (set-val 'writers (get-val :writers)) - (set-val 'allocation :instance) - (set-val 'type (get-val :type)) - (set-val 'class nil) - (set-val 'instance-index nil) - (when (and (eq name 'standard-class) (eq (get-val :name) 'slots) e-p) - (setq *the-eslotd-standard-class-slots* slotd)) - slotd))) - -(defun bootstrap-built-in-classes () - ;; - ;; First make sure that all the supers listed in *built-in-class-lattice* - ;; are themselves defined by *built-in-class-lattice*. This is just to - ;; check for typos and other sorts of brainos. - ;; - (dolist (e *built-in-classes*) - (dolist (super (cadr e)) - (unless (or (eq super 't) - (assq super *built-in-classes*)) - (error "In *built-in-classes*: ~S has ~S as a super,~%~ - but ~S is not itself a class in *built-in-classes*." - (car e) super super)))) - - ;; - ;; In the first pass, we create a skeletal object to be bound to the - ;; class name. - ;; - (let* ((built-in-class (find-class 'built-in-class)) - (built-in-class-wrapper (class-wrapper built-in-class)) - (bin-class-size (length *bin-class-slots*))) - (dolist (e *built-in-classes*) - (let ((class (%allocate-instance--class bin-class-size))) - (setf (std-instance-wrapper class) built-in-class-wrapper) - (setf (find-class (car e)) class)))) - - ;; - ;; In the second pass, we initialize the class objects. - ;; - (dolist (e *built-in-classes*) - (destructuring-bind (name supers subs cpl) e - (let* ((class (find-class name)) - (wrapper (make-wrapper class))) - (set (get-built-in-class-symbol name) class) - (set (get-built-in-wrapper-symbol name) wrapper) - - (setf (wrapper-instance-slots-layout wrapper) () - (wrapper-class-slots wrapper) ()) - - (bootstrap-initialize-bin-class class - name nil - supers subs - (cons name cpl) wrapper) - )))) - - -;;; -;;; -;;; - -(defun class-of (x) (wrapper-class (wrapper-of x))) - -(defun wrapper-of (x) - (or (and (std-instance-p x) - (std-instance-wrapper x)) - (and (fsc-instance-p x) - (fsc-instance-wrapper x)) - (built-in-wrapper-of x) - (error "Can't determine wrapper of ~S" x))) - - -(eval-when (compile eval) - -(defun make-built-in-class-subs () - (mapcar #'(lambda (e) - (let ((class (car e)) - (class-subs ())) - (dolist (s *built-in-classes*) - (when (memq class (cadr s)) (pushnew (car s) class-subs))) - (cons class class-subs))) - (cons '(t) *built-in-classes*))) - -(defun make-built-in-class-tree () - (let ((subs (make-built-in-class-subs))) - (labels ((descend (class) - (cons class (mapcar #'descend (cdr (assq class subs)))))) - (descend 't)))) - -(defun make-built-in-wrapper-of-body () - (make-built-in-wrapper-of-body-1 (make-built-in-class-tree) - 'x - #'get-built-in-wrapper-symbol)) - -(defun make-built-in-wrapper-of-body-1 (tree var get-symbol) - (let ((*specials* ())) - (declare (special *specials*)) - (let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol))) - `(locally (declare (special .,*specials*)) ,inner)))) - -(defun make-built-in-wrapper-of-body-2 (tree var get-symbol) - (declare (special *specials*)) - (let ((symbol (funcall get-symbol (car tree)))) - (push symbol *specials*) - (let ((sub-tests - (mapcar #'(lambda (x) - (make-built-in-wrapper-of-body-2 x var get-symbol)) - (cdr tree)))) - `(and (typep ,var ',(car tree)) - ,(if sub-tests - `(or ,.sub-tests ,symbol) - symbol))))) -) - -(defun built-in-wrapper-of (x) - #.(make-built-in-wrapper-of-body)) - - - - -(eval-when (load eval) - (clrhash *find-class*) - (bootstrap-meta-braid) - (bootstrap-built-in-classes) - (setq *boot-state* 'braid) - (setf (symbol-function 'load-defclass) #'real-load-defclass) - ) - - -;;; -;;; All of these method definitions must appear here because the bootstrap -;;; only allows one method per generic function until the braid is fully -;;; built. -;;; -(defmethod print-object (instance stream) - (printing-random-thing (instance stream) - (let ((name (class-name (class-of instance)))) - (if name - (format stream "~S" name) - (format stream "Instance"))))) - -(defmethod print-object ((class class) stream) - (named-object-print-function class stream)) - -(defmethod print-object ((slotd standard-slot-definition) stream) - (named-object-print-function slotd stream)) - -(defun named-object-print-function (instance stream - &optional (extra nil extra-p)) - (printing-random-thing (instance stream) - (if extra-p - (format stream "~A ~S ~:S" - (capitalize-words (class-name (class-of instance))) - (slot-value-or-default instance 'name) - extra) - (format stream "~A ~S" - (capitalize-words (class-name (class-of instance))) - (slot-value-or-default instance 'name))))) - - -;;; -;;; -;;; -;(defmethod shared-initialize :after ((class class) slot-names &key name) -; (declare (ignore slot-names)) -; (setf (slot-value class 'name) name)) -; -; -;(defmethod shared-initialize :after ((class std-class) -; slot-names -; &key direct-superclasses -; direct-slots) -; (declare (ignore slot-names)) -; (setf (slot-value class 'direct-superclasses) direct-superclasses -; (slot-value class 'direct-slots) direct-slots)) - -;;; -;;; -;;; -(defmethod shared-initialize :after ((slotd standard-slot-definition) - slot-names - &key class - name - initform - initfunction - initargs - (allocation :instance) - (type t) - readers - writers) - (declare (ignore slot-names)) - (setf (slot-value slotd 'name) name - (slot-value slotd 'initform) initform - (slot-value slotd 'initfunction) initfunction - (slot-value slotd 'initargs) initargs - (slot-value slotd 'allocation) (if (eq allocation :class) class allocation) - (slot-value slotd 'type) type - (slot-value slotd 'readers) readers - (slot-value slotd 'writers) writers)) - diff --git a/obsolete/clos/2.0/cache.lisp b/obsolete/clos/2.0/cache.lisp deleted file mode 100644 index 068ab817..00000000 --- a/obsolete/clos/2.0/cache.lisp +++ /dev/null @@ -1,1089 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; The basics of the CLOS wrapper cache mechanism. -;;; - -(in-package 'clos) -;;; -;;; The caching algorithm implemented: -;;; -;;; << put a paper here >> -;;; -;;; For now, understand that as far as most of this code goes, a cache has -;;; two important properties. The first is the number of wrappers used as -;;; keys in each cache line. Throughout this code, this value is always -;;; called NKEYS. The second is whether or not the cache lines of a cache -;;; store a value. Throughout this code, this always called VALUEP. -;;; -;;; Depending on these values, there are three kinds of caches. -;;; -;;; NKEYS = 1, VALUEP = NIL -;;; -;;; In this kind of cache, each line is 1 word long. No cache locking is -;;; needed since all read's in the cache are a single value. Nevertheless -;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will -;;; not get a first probe hit. -;;; -;;; To keep the code simpler, a cache lock count does appear in location 0 -;;; of these caches, that count is incremented whenever data is written to -;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to -;;; do locking when reading the cache. -;;; -;;; -;;; NKEYS = 1, VALUEP = T -;;; -;;; In this kind of cache, each line is 2 words long. Cache locking must -;;; be done to ensure the synchronization of cache reads. Line 0 of the -;;; cache (location 0) is reserved for the cache lock count. Location 1 -;;; of the cache is unused (in effect wasted). -;;; -;;; NKEYS > 1 -;;; -;;; In this kind of cache, the 0 word of the cache holds the lock count. -;;; The 1 word of the cache is line 0. Line 0 of these caches is not -;;; reserved. -;;; -;;; This is done because in this sort of cache, the overhead of doing the -;;; cache probe is high enough that the 1+ required to offset the location -;;; is not a significant cost. In addition, because of the larger line -;;; sizes, the space that would be wasted by reserving line 0 to hold the -;;; lock count is more significant. -;;; - - -;;; -;;; Caches -;;; -;;; A cache is essentially just a vector. The use of the individual `words' -;;; in the vector depends on particular properties of the cache as described -;;; above. -;;; -;;; This defines an abstraction for caches in terms of their most obvious -;;; implementation as simple vectors. But, please notice that part of the -;;; implementation of this abstraction, is the function lap-out-cache-ref. -;;; This means that most port-specific modifications to the implementation -;;; of caches will require corresponding port-specific modifications to the -;;; lap code assembler. -;;; -(defmacro cache-ref (cache location) - `(svref (the simple-vector ,cache) (the fixnum ,location))) - -(defun emit-cache-ref (cache-operand location-operand) - (operand :iref cache-operand location-operand)) - - -(defun cache-size (cache) - (array-dimension (the simple-vector cache) 0)) - -(defun allocate-cache (size) - (make-array size :adjustable nil)) - -(defmacro cache-lock-count (cache) - `(cache-ref ,cache 0)) - -(defun flush-cache-internal (cache) - (without-interrupts - (fill (the simple-vector cache) nil) - (setf (cache-lock-count cache) 0)) - cache) - -(defmacro modify-cache (cache &body body) - `(without-interrupts - (multiple-value-prog1 - (progn ,@body) - (let ((old-count (cache-lock-count ,cache))) - (setf (cache-lock-count ,cache) - (if (= old-count most-positive-fixnum) 1 (1+ old-count))))))) - - - -;;; -;;; Some facilities for allocation and freeing caches as they are needed. -;;; This is done on the assumption that a better port of CLOS will arrange -;;; to cons these all the same static area. Given that, the fact that -;;; CLOS tries to reuse them should be a win. -;;; -(defvar *free-caches* (make-hash-table :size 16)) - -;;; -;;; Return a cache that has had flush-cache-internal called on it. This -;;; returns a cache of exactly the size requested, it won't ever return a -;;; larger cache. -;;; -(defun get-cache (size) - (let ((entry (gethash size *free-caches*))) - (without-interrupts - (cond ((null entry) - (setf (gethash size *free-caches*) (cons 0 nil)) - (get-cache size)) - ((null (cdr entry)) - (incf (car entry)) - (flush-cache-internal (allocate-cache size))) - (t - (let ((cache (cdr entry))) - (setf (cdr entry) (cache-ref cache 0)) - (flush-cache-internal cache))))))) - -(defun free-cache (cache) - (let ((entry (gethash (cache-size cache) *free-caches*))) - (without-interrupts - (if (null entry) - (error "Attempt to free a cache not allocated by GET-CACHE.") - (let ((thread (cdr entry))) - (loop (unless thread (return)) - (when (eq thread cache) (error "Freeing a cache twice.")) - (setq thread (cache-ref thread 0))) - (flush-cache-internal cache) ;Help the GC - (setf (cache-ref cache 0) (cdr entry)) - (setf (cdr entry) cache) - nil))))) - -;;; -;;; This is just for debugging and analysis. It shows the state of the free -;;; cache resource. -;;; -(defun show-free-caches () - (let ((elements ())) - (maphash #'(lambda (s e) (push (list s e) elements)) *free-caches*) - (setq elements (sort elements #'< :key #'car)) - (dolist (e elements) - (let* ((size (car e)) - (entry (cadr e)) - (allocated (car entry)) - (head (cdr entry)) - (free 0)) - (loop (when (null head) (return t)) - (setq head (cache-ref head 0)) - (incf free)) - (format t - "~&There ~4D are caches of size ~4D. (~D free ~3D%)" - allocated - size - free - (floor (* 100 (/ free (float allocated))))))))) - - -;;; -;;; Wrapper cache numbers -;;; - -;;; -;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero -;;; bits wrapper cache numbers will have. -;;; -;;; The value of this constant is the number of wrapper cache numbers which -;;; can be added and still be certain the result will be a fixnum. This is -;;; used by all the code that computes primary cache locations from multiple -;;; wrappers. -;;; -;;; The value of this constant is used to derive the next two which are the -;;; forms of this constant which it is more convenient for the runtime code -;;; to use. -;;; -(eval-when (compile load eval) - -(defconstant wrapper-cache-number-adds-ok 4) - -(defconstant wrapper-cache-number-length - (- (integer-length most-positive-fixnum) - wrapper-cache-number-adds-ok)) - -(defconstant wrapper-cache-number-mask - (1- (expt 2 wrapper-cache-number-length))) - - -(defvar *get-wrapper-cache-number* (make-random-state)) - -(defun get-wrapper-cache-number () - (let ((n 0)) - (loop - (setq n - (logand wrapper-cache-number-mask - (random most-positive-fixnum *get-wrapper-cache-number*))) - (unless (zerop n) (return n))))) - - -(unless (> wrapper-cache-number-length 8) - (error "In this implementation of Common Lisp, fixnums are so small that~@ - wrapper cache numbers end up being only ~D bits long. This does~@ - not actually keep CLOS from running, but it may degrade cache~@ - performance.~@ - You may want to consider changing the value of the constant~@ - WRAPPER-CACHE-NUMBER-ADDS-OK."))) - - -;;; -;;; wrappers themselves -;;; -;;; This caching algorithm requires that wrappers have more than one wrapper -;;; cache number. You should think of these multiple numbers as being in -;;; columns. That is, for a given cache, the same column of wrapper cache -;;; numbers will be used. -;;; -;;; If at some point the cache distribution of a cache gets bad, the cache -;;; can be rehashed by switching to a different column. -;;; -;;; The columns are referred to by field number which is that number which, -;;; when used as a second argument to wrapper-ref, will return that column -;;; of wrapper cache number. -;;; -;;; This code is written to allow flexibility as to how many wrapper cache -;;; numbers will be in each wrapper, and where they will be located. It is -;;; also set up to allow port specific modifications to `pack' the wrapper -;;; cache numbers on machines where the addressing modes make that a good -;;; idea. -;;; -(eval-when (compile load eval) -(defconstant wrapper-layout - '(number - number - number - number - number - number - number - number - state - instance-slots-layout - class-slots - class)) -) - -(eval-when (compile load eval) - -(defun wrapper-field (type) - (position type wrapper-layout)) - -(defun next-wrapper-field (field-number) - (position (nth field-number wrapper-layout) - wrapper-layout - :start (1+ field-number))) - -);eval-when - -(defmacro wrapper-ref (wrapper n) - `(svref ,wrapper ,n)) - -(defun emit-wrapper-ref (wrapper-operand field-operand) - (operand :iref wrapper-operand field-operand)) - - -(defmacro wrapper-state (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'state))) - -(defmacro wrapper-instance-slots-layout (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'instance-slots-layout))) - -(defmacro wrapper-class-slots (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'class-slots))) - -(defmacro wrapper-class (wrapper) - `(wrapper-ref ,wrapper ,(wrapper-field 'class))) - - -(defmacro make-wrapper-internal () - `(let ((wrapper (make-array ,(length wrapper-layout) :adjustable nil))) - ,@(gathering1 (collecting) - (iterate ((i (interval :from 0)) - (desc (list-elements wrapper-layout))) - (ecase desc - (number - (gather1 `(setf (wrapper-ref wrapper ,i) - (get-wrapper-cache-number)))) - ((state instance-slots-layout class-slots class))))) - (setf (wrapper-state wrapper) 't) - wrapper)) - -(defun make-wrapper (class) - (let ((wrapper (make-wrapper-internal))) - (setf (wrapper-class wrapper) class) - wrapper)) - -;;; -;;; The wrapper cache machinery provides general mechanism for trapping on -;;; the next access to any instance of a given class. This mechanism is -;;; used to implement the updating of instances when the class is redefined -;;; (make-instances-obsolete). The same mechanism is also used to update -;;; generic function caches when there is a change to the supers of a class. -;;; -;;; Basically, a given wrapper can be valid or invalid. If it is invalid, -;;; it means that any attempt to do a wrapper cache lookup using the wrapper -;;; should trap. Also, methods on slot-value-using-class check the wrapper -;;; validity as well. This is done by calling check-wrapper-validity. -;;; - -(defun invalid-wrapper-p (wrapper) - (neq (wrapper-state wrapper) 't)) - -(defvar *previous-nwrappers* (make-hash-table)) - -(defun invalidate-wrapper (owrapper state nwrapper) - (ecase state - ((flush obsolete) - (let ((new-previous ())) - ;; - ;; First off, a previous call to invalidate-wrapper may have recorded - ;; owrapper as an nwrapper to update to. Since owrapper is about to - ;; be invalid, it no longer makes sense to update to it. - ;; - ;; We go back and change the previously invalidated wrappers so that - ;; they will now update directly to nwrapper. This corresponds to a - ;; kind of transitivity of wrapper updates. - ;; - (dolist (previous (gethash owrapper *previous-nwrappers*)) - (when (eq state 'obsolete) - (setf (car previous) 'obsolete)) - (setf (cadr previous) nwrapper) - (push previous new-previous)) - - (iterate ((type (list-elements wrapper-layout)) - (i (interval :from 0))) - (when (eq type 'number) (setf (wrapper-ref owrapper i) 0))) - (push (setf (wrapper-state owrapper) (list state nwrapper)) - new-previous) - - (setf (gethash owrapper *previous-nwrappers*) () - (gethash nwrapper *previous-nwrappers*) new-previous))))) - -(defun check-wrapper-validity (instance) - (let* ((owrapper (wrapper-of instance)) - (state (wrapper-state owrapper))) - (if (eq state 't) - owrapper - (let ((nwrapper - (ecase (car state) - (flush - (flush-cache-trap owrapper (cadr state) instance)) - (obsolete - (obsolete-instance-trap owrapper (cadr state) instance))))) - ;; - ;; This little bit of error checking is superfluous. It only - ;; checks to see whether the person who implemented the trap - ;; handling screwed up. Since that person is hacking internal - ;; CLOS code, and is not a user, this should be needless. Also, - ;; since this directly slows down instance update and generic - ;; function cache refilling, feel free to take it out sometime - ;; soon. - ;; - (cond ((neq nwrapper (wrapper-of instance)) - (error "Wrapper returned from trap not wrapper of instance.")) - ((invalid-wrapper-p nwrapper) - (error "Wrapper returned from trap invalid."))) - nwrapper)))) - - - -(defun compute-line-size (nelements) (expt 2 (ceiling (log nelements 2)))) - -(defun compute-cache-parameters (nkeys valuep nlines-or-cache) - (declare (values cache-mask actual-size line-size nlines)) - (flet ((compute-mask (cache-size line-size) - (logxor (1- cache-size) (1- line-size)))) - (if (= nkeys 1) - (let* ((line-size (if valuep 2 1)) - (cache-size (if (numberp nlines-or-cache) - (* line-size - (expt 2 (ceiling (log nlines-or-cache 2)))) - (cache-size nlines-or-cache)))) - (values (compute-mask cache-size line-size) - cache-size - line-size - (/ cache-size line-size))) - (let* ((line-size (compute-line-size (+ nkeys (if valuep 1 0)))) - (cache-size (if (numberp nlines-or-cache) - (* line-size - (expt 2 (ceiling (log nlines-or-cache 2)))) - (1- (cache-size nlines-or-cache))))) - (values (compute-mask cache-size line-size) - (1+ cache-size) - line-size - (/ cache-size line-size)))))) - - - -;;; -;;; The various implementations of computing a primary cache location from -;;; wrappers. Because some implementations of this must run fast there are -;;; several implementations of the same algorithm. -;;; -;;; The algorithm is: -;;; -;;; SUM over the wrapper cache numbers, -;;; ENSURING that the result is a fixnum -;;; MASK the result against the mask argument. -;;; -;;; - -;;; -;;; COMPUTE-PRIMARY-CACHE-LOCATION -;;; -;;; The basic functional version. This is used by the cache miss code to -;;; compute the primary location of an entry. -;;; -(defun compute-primary-cache-location (field mask wrappers) - (if (not (consp wrappers)) - (logand mask (wrapper-ref wrappers field)) - (let ((location 0)) - (iterate ((wrapper (list-elements wrappers)) - (i (interval :from 0))) - ;; - ;; First add the cache number of this wrapper to location. - ;; - (let ((wrapper-cache-number (wrapper-ref wrapper field))) - (if (zerop wrapper-cache-number) - (return-from compute-primary-cache-location 0) - (setq location (+ location wrapper-cache-number)))) - ;; - ;; Then, if we are working with lots of wrappers, deal with - ;; the wrapper-cache-number-mask stuff. - ;; - (when (and (not (zerop i)) - (zerop (mod i wrapper-cache-number-adds-ok))) - (setq location - (logand location wrapper-cache-number-mask)))) - (1+ (logand mask location))))) - -;;; -;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION -;;; -;;; This version is called on a cache line. It fetches the wrappers from -;;; the cache line and determines the primary location. Various parts of -;;; the cache filling code call this to determine whether it is appropriate -;;; to displace a given cache entry. -;;; -;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol -;;; invalid to suggest to its caller that it would be provident to blow away -;;; the cache line in question. -;;; -(defun compute-primary-cache-location-from-location (field cache location mask nkeys) - (let ((result 0)) - (dotimes (i nkeys) - (let* ((wrapper (cache-ref cache (+ i location))) - (wcn (wrapper-ref wrapper field))) - (setq result (+ result wcn))) - (when (and (not (zerop i)) - (zerop (mod i wrapper-cache-number-adds-ok))) - (setq result (logand result wrapper-cache-number-mask))) - ) - (if (= nkeys 1) - (logand mask result) - (1+ (logand mask result))))) - -(defun emit-1-wrapper-compute-primary-cache-location (wrapper primary wrapper-cache-no) - (with-lap-registers ((mask index)) - (let ((field wrapper-cache-no)) - (flatten-lap - (opcode :move (operand :cvar 'mask) mask) - (opcode :move (operand :cvar 'field) field) - (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) - (opcode :move (operand :ilogand wrapper-cache-no mask) primary))))) - -(defun emit-n-wrapper-compute-primary-cache-location (wrappers primary miss-label) - (with-lap-registers ((field index) - (mask index)) - (let ((add-wrapper-cache-numbers - (flatten-lap - (gathering1 (flattening-lap) - (iterate ((wrapper (list-elements wrappers)) - (i (interval :from 1))) - (gather1 - (with-lap-registers ((wrapper-cache-no index)) - (flatten-lap - (opcode :move (emit-wrapper-ref wrapper field) wrapper-cache-no) - (opcode :izerop wrapper-cache-no miss-label) - (opcode :move (operand :i+ primary wrapper-cache-no) primary) - (when (zerop (mod i wrapper-cache-number-adds-ok)) - (opcode :move (operand :ilogand primary mask) primary)))))))))) - (flatten-lap - (opcode :move (operand :constant 0) primary) - (opcode :move (operand :cvar 'field) field) - (opcode :move (operand :cvar 'mask) mask) - add-wrapper-cache-numbers - (opcode :move (operand :ilogand primary mask) primary) - (opcode :move (operand :i1+ primary) primary))))) - - - -;;; -;;; NIL means nothing so far, no actual arg info has NILs -;;; in the metatype -;;; CLASS seen all sorts of metaclasses -;;; (specifically, more than one of the next 4 values) -;;; T means everything so far is the class T -;;; STANDARD-CLASS seen only standard classes -;;; BUILT-IN-CLASS seen only built in classes -;;; STRUCTURE-CLASS seen only structure classes -;;; -(defun raise-metatype (metatype new-specializer) - (let ((standard (find-class 'standard-class)) - (fsc (find-class 'funcallable-standard-class)) -; (structure (find-class 'structure-class)) - (built-in (find-class 'built-in-class))) - (flet ((specializer->metatype (x) - (let ((meta-specializer - (if (and (eq *boot-state* 'complete) - (eql-specializer-p x)) - (class-of (class-of (eql-specializer-object x))) - (class-of x)))) - (cond ((eq x *the-class-t*) t) - ((*subtypep meta-specializer standard) 'standard-instance) - ((*subtypep meta-specializer fsc) 'standard-instance) -; ((*subtypep meta-specializer structure) 'structure-instance) - ((*subtypep meta-specializer built-in) 'built-in-instance) - (t (error "CLOS can not handle the specializer ~S (meta-specializer ~S)." - new-specializer meta-specializer)))))) - ;; - ;; We implement the following table. The notation is - ;; that X and Y are distinct meta specializer names. - ;; - ;; NIL ===> - ;; X X ===> X - ;; X Y ===> CLASS - ;; - (let ((new-metatype (specializer->metatype new-specializer))) - (cond ((null metatype) new-metatype) - ((eq metatype new-metatype) new-metatype) - (t 'class)))))) - - -(defun emit-fetch-wrapper (metatype argument dest miss-label &optional slot) - (let ((exit-emit-fetch-wrapper (make-symbol "exit-emit-fetch-wrapper"))) - (with-lap-registers ((arg t)) - (ecase metatype - (standard-instance - (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) - (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper"))) - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :std-instance-p arg get-std-inst-wrapper) ;is it a std wrapper? - (opcode :fsc-instance-p arg get-fsc-inst-wrapper) ;is it a fsc wrapper? - (opcode :go miss-label) - (opcode :label get-fsc-inst-wrapper) - (opcode :move (operand :fsc-wrapper arg) dest) ;get fsc wrapper - (and slot - (opcode :move (operand :fsc-slots arg) slot)) - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-std-inst-wrapper) - (opcode :move (operand :std-wrapper arg) dest) ;get std wrapper - (and slot - (opcode :move (operand :std-slots arg) slot)) - (opcode :label exit-emit-fetch-wrapper)))) - - (class - (when slot (error "Can't do a slot reg for this metatype.")) - (let ((get-std-inst-wrapper (make-symbol "get-std-inst-wrapper")) - (get-fsc-inst-wrapper (make-symbol "get-fsc-inst-wrapper")) - (get-built-in-wrapper (make-symbol "get-built-in-wrapper"))) - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :std-instance-p arg get-std-inst-wrapper) - (opcode :fsc-instance-p arg get-fsc-inst-wrapper) - (opcode :built-in-instance-p arg get-built-in-wrapper) - ;; If the code falls through the checks above, there is a serious problem - (opcode :label get-fsc-inst-wrapper) - (opcode :move (operand :fsc-wrapper arg) dest) - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-built-in-wrapper) - (opcode :move (operand :built-in-wrapper arg) dest) - (opcode :go exit-emit-fetch-wrapper) - (opcode :label get-std-inst-wrapper) - (opcode :move (operand :std-wrapper arg) dest) - (opcode :label exit-emit-fetch-wrapper)))) - (structure-instance - (when slot (error "Can't do a slot reg for this metatype.")) - (error "Not yet implemented")) - (built-in-instance - (when slot (error "Can't do a slot reg for this metatype.")) - (let ((get-built-in-wrapper (make-symbol "get-built-in-wrapper"))) - (flatten-lap - (opcode :move (operand :arg argument) arg) - (opcode :built-in-instance-p arg get-built-in-wrapper) - (opcode :go miss-label) - (opcode :label get-built-in-wrapper) - (opcode :move (operand :built-in-wrapper arg) dest)))))))) - - -;;; -;;; Some support stuff for getting a hold of symbols that we need when -;;; building the discriminator codes. Its ok for these to be interned -;;; symbols because we don't capture any user code in the scope in which -;;; these symbols are bound. -;;; - -(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) - -(defun dfun-arg-symbol (arg-number) - (or (nth arg-number (the list *dfun-arg-symbols*)) - (intern (format nil ".ARG~A." arg-number) *the-clos-package*))) - -(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) - -(defun slot-vector-symbol (arg-number) - (or (nth arg-number (the list *slot-vector-symbols*)) - (intern (format nil ".SLOTS~A." arg-number) *the-clos-package*))) - -(defun make-dfun-lambda-list (metatypes applyp) - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i))) - (when applyp - (gather1 '&rest) - (gather1 '.dfun-rest-arg.)))) - -(defun make-dlap-lambda-list (metatypes applyp) - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i))) - (when applyp - (gather1 '&rest)))) - -(defun make-dfun-call (metatypes applyp fn-variable) - (let ((required - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i)))))) - (if applyp - `(apply ,fn-variable ,@required .dfun-rest-arg.) - `(funcall ,fn-variable ,@required)))) - - -;;; -;;; Here is where we actually fill, recache and expand caches. -;;; -;;; The function FILL-CACHE is the ONLY external entrypoint into this code. -;;; It returns 4 values: -;;; a wrapper field number -;;; a cache -;;; a mask -;;; an absolute cache size (the size of the actual vector) -;;; -;;; -(defun fill-cache (field cache nkeys valuep limit-fn wrappers value) - (declare (values field cache mask size)) - (fill-cache-internal field cache nkeys valuep limit-fn wrappers value)) - -(defun default-limit-fn (nlines) - (case nlines - ((1 2 4) 1) - ((8 16) 4) - (otherwise 6))) - - -;;; -;;; Its too bad Common Lisp compilers freak out when you have a defun with -;;; a lot of LABELS in it. If I could do that I could make this code much -;;; easier to read and work with. -;;; -;;; Ahh Scheme... -;;; -;;; In the absence of that, the following little macro makes the code that -;;; follows a little bit more reasonable. I would like to add that having -;;; to practically write my own compiler in order to get just this simple -;;; thing is something of a drag. -;;; -(eval-when (compile load eval) - -(proclaim '(special *nkeys* *valuep* *limit-fn*)) - -;;; This patch avoids a bug in the ENVCALL instruction. Lookup of free -;;; variables under ENVCALL always results in nil. In particular, the -;;; compiler generates such code for flet and friends. Therefore, some -;;; macros must be defined at top-level. - -;(defmacro cache () '.cache.) -;(defmacro nkeys () '*nkeys*) -;(defmacro valuep () '*valuep*) -;(defmacro limit-fn () '*limit-fn*) -;(defmacro line-size () '.line-size.) -;(defmacro mask () '.mask.) -;(defmacro size () '.size.) -;(defmacro nlines () '.nlines.) -;(defmacro line-reserved-p (line) -; `(and (= (nkeys) 1) -; (= ,line 0))) -;(defmacro line-location (line) -; `(and (null (line-reserved-p ,line)) -; (if (= (nkeys) 1) -; (* ,line (line-size)) -; (1+ (* ,line (line-size)))))) -;(defmacro location-line (location) -; `(if (= (nkeys) 1) -; (/ ,location (line-size)) -; (/ (1- ,location) (line-size)))) -;end patch - -(defvar *local-cache-functions* - `((cache () .cache.) - (nkeys () *nkeys*) - (valuep () *valuep*) - (limit-fn () *limit-fn*) - (line-size () .line-size.) - (mask () .mask.) - (size () .size.) - (nlines () .nlines.) - ;; - ;; Return T IFF this cache location is reserved. The only time - ;; this is true is for line number 0 of an nkeys=1 cache. - ;; - (line-reserved-p (line) - (and (= (nkeys) 1) - (= line 0))) - ;; - ;; Given a line number, return the cache location. This is the - ;; value that is the second argument to cache-ref. Basically, - ;; this deals with the offset of nkeys>1 caches and multiplies - ;; by line size. This returns nil if the line is reserved. - ;; - (line-location (line) - (and (null (line-reserved-p line)) - (if (= (nkeys) 1) - (* line (line-size)) - (1+ (* line (line-size)))))) - ;; - ;; Given a cache location, return the line. This is the inverse - ;; of LINE-LOCATION. - ;; - (location-line (location) - (if (= (nkeys) 1) - (/ location (line-size)) - (/ (1- location) (line-size)))) - ;; - ;; Given a line number, return the wrappers stored at that line. - ;; As usual, if nkeys=1, this returns a single value. Only when - ;; nkeys>1 does it return a list. An error is signalled if the - ;; line is reserved. - ;; - (line-wrappers (line) - (when (line-reserved-p line) (error "Line is reserved.")) - (let ((location (line-location line))) - (if (= (nkeys) 1) - (cache-ref (cache) location) - (gathering1 (collecting) - (dotimes (i (nkeys)) - (gather1 (cache-ref (cache) (+ location i)))))))) - ;; - ;; Given a line number, return the value stored at that line. - ;; If valuep is NIL, this returns NIL. As with line-wrappers, - ;; an error is signalled if the line is reserved. - ;; - (line-value (line) - (when (line-reserved-p line) (error "Line is reserved.")) - (and (valuep) - (cache-ref (cache) (+ (line-location line) (nkeys))))) - ;; - ;; Given a line number, return true IFF that line has data in - ;; it. The state of the wrappers stored in the line is not - ;; checked. An error is signalled if line is reserved. - (line-full-p (line) - (when (line-reserved-p line) (error "Line is reserved.")) - (not (null (cache-ref (cache) (line-location line))))) - ;; - ;; Given a line number, return true IFF the line is full and - ;; there are no invalid wrappers in the line, and the line's - ;; wrappers are different from wrappers. - ;; An error is signalled if the line is reserved. - ;; - (line-valid-p (line wrappers) - (when (line-reserved-p line) (error "Line is reserved.")) - (let ((loc (line-location line))) - (dotimes (i (nkeys) t) - (let ((wrapper (cache-ref (cache) (+ loc i)))) - (when (or (null wrapper) -;*** (numberp wrapper) - ;Think of this as an optimized: - ; (and (zerop i) - ; (= (nkeys) 1) - ; (null (valuep)) - ; (numberp wrapper)) - (invalid-wrapper-p wrapper)) - (return nil)))))) - ;; - ;; How many unreserved lines separate line-1 and line-2. - ;; - (line-separation (line-1 line-2) - (let ((diff (- line-2 line-1))) - (cond ((zerop diff) diff) - ((plusp diff) diff) - (t - (if (line-reserved-p 0) - (1- (+ (- (nlines) line-1) line-2)) - (+ (- (nlines) line-1) line-2)))))) - ;; - ;; Given a cache line, get the next cache line. This will not - ;; return a reserved line. - ;; - (next-line (line) - (if (= line (1- (nlines))) - (if (line-reserved-p 0) 1 0) - (1+ line))) - ;; - ;; Given a line which has a valid entry in it, this will return - ;; the primary cache line of the wrappers in that line. We just - ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an - ;; easier packaging up of the call to it. - ;; - (line-primary (field line) - (location-line - (compute-primary-cache-location-from-location - field (cache) (line-location line) (mask) (nkeys)))) - ;; - ;; - (fill-line (line wrappers value) - (when (line-reserved-p line) - (error "Attempt to fill a reserved line.")) - (let ((loc (line-location line))) - (cond ((= (nkeys) 1) - (setf (cache-ref (cache) loc) wrappers) - (when (valuep) (setf (cache-ref (cache) (1+ loc)) value))) - (t - (iterate ((i (interval :from 0)) - (w (list-elements wrappers))) - (setf (cache-ref (cache) (+ loc i)) w)) - (when (valuep) (setf (cache-ref (cache) (+ loc (nkeys))) value)))))) - ;; - ;; Blindly copy the contents of one cache line to another. The - ;; contents of the line are overwritten, so whatever was in - ;; there should already have been moved out. - ;; - ;; For convenience in debugging, this also clears out the from - ;; location after it has been copied. - ;; - (copy-line (from to) - (if (line-reserved-p to) - (error "Copying something into a reserved cache line.") - (let ((from-loc (line-location from)) - (to-loc (line-location to))) - (modify-cache (cache) - (dotimes (i (line-size)) - (setf (cache-ref (cache) (+ to-loc i)) - (cache-ref (cache) (+ from-loc i))) - (setf (cache-ref (cache) (+ from-loc i)) - nil)))))) - ;; - ;; - ;; - (transfer-line (from-cache from-line to-cache to-line) - (if (line-reserved-p to-line) - (error "transfering something into a reserved cache line.") - (let ((from-loc (line-location from-line)) - (to-loc (line-location to-line))) - (modify-cache to-cache - (dotimes (i (line-size)) - (setf (cache-ref to-cache (+ to-loc i)) - (cache-ref from-cache (+ from-loc i)))))))) - )) - -(defmacro with-local-cache-functions ((cache) &body body &environment env) - `(let ((.cache. ,cache)) - (declare (type simple-vector .cache.)) - (multiple-value-bind (.mask. .size. .line-size. .nlines.) - (compute-cache-parameters *nkeys* *valuep* .cache.) - (declare (type fixnum .mask. .size. .line-size. .nlines.)) - (progn .mask. .size. .line-size. .nlines.) - (labels ,(mapcar #'(lambda (fn) (assq fn *local-cache-functions*)) - (pickup-local-cache-functions body env)) - ,@body)))) - -(defun pickup-local-cache-functions (body env) - (let ((functions ()) - (possible-functions (mapcar #'car *local-cache-functions*))) - (labels ((walk-function (form context env) - (declare (ignore env)) - (when (and (eq context :eval) - (consp form) - (symbolp (car form))) - (let ((name (car form))) - (when (and (not (memq name functions)) - (memq name possible-functions)) - (pushnew name functions) - (walk (cddr (assq name *local-cache-functions*)))))) - form) - (walk (body) - (walk-form `(progn . ,body) env #'walk-function))) - (walk body) - functions))) - -) - - -;;; -;;; returns 4 values, -;;; It tries to re-adjust the cache every time it makes a new fill. The -;;; intuition here is that we want uniformity in the number of probes needed to -;;; find an entry. Furthermore, adjusting has the nice property of throwing out -;;; any entries that are invalid. -;;; -(defun fill-cache-internal (field cache nkeys valuep limit-fn wrappers value) - (let ((*nkeys* nkeys) - (*valuep* valuep) - (*limit-fn* limit-fn)) - (with-local-cache-functions (cache) - (flet ((4-values-please (f c) - (multiple-value-bind (mask size) - (compute-cache-parameters *nkeys* *valuep* c) - (values f c mask size)))) - (let ((easy-fill-p (fill-cache-p nil field cache wrappers value))) - (if easy-fill-p - (4-values-please field cache) - (multiple-value-bind (adj-field adj-cache) - (adjust-cache field cache wrappers value) - (if adj-field - (4-values-please adj-field adj-cache) - (multiple-value-bind (exp-field exp-cache) - (expand-cache field cache wrappers value) - (4-values-please exp-field exp-cache)))))))))) - -;;; -;;; returns T or NIL -;;; -(defun fill-cache-p (forcep field cache wrappers value) - (with-local-cache-functions (cache) - (let* ((primary (location-line (compute-primary-cache-location field (mask) wrappers)))) - (multiple-value-bind (free emptyp) - (find-free-cache-line primary field cache wrappers) - (when (or forcep emptyp) (fill-line free wrappers value) t))))) - -(defun fill-cache-from-cache-p (forcep field cache from-cache from-line) - (with-local-cache-functions (from-cache) - (let ((primary (line-primary field from-line))) - (multiple-value-bind (free emptyp) - (find-free-cache-line primary field cache) - (when (or forcep emptyp) - (transfer-line from-cache from-line cache free) - t))))) - -(defun entry-in-cache-p (field cache wrappers value) - (declare (ignore field value)) - (with-local-cache-functions (cache) - (dotimes (i (nlines)) - (unless (line-reserved-p i) - (when (equal (line-wrappers i) wrappers) (return t)))))) - -;;; -;;; Returns NIL or (values ) -;;; -;;; This is only called when it isn't possible to put the entry in the cache -;;; the easy way. That is, this function assumes that FILL-CACHE-P has been -;;; called as returned NIL. -;;; -;;; If this returns NIL, it means that it wasn't possible to find a wrapper -;;; field for which all of the entries could be put in the cache (within the -;;; limit). -;;; -(defun adjust-cache (field cache wrappers value) - (with-local-cache-functions (cache) - (let ((ncache (get-cache (size)))) - (do ((nfield field (next-wrapper-field nfield))) - ((null nfield) (free-cache ncache) nil) - (labels ((try-one-fill-from-line (line) - (fill-cache-from-cache-p nil nfield ncache cache line)) - (try-one-fill (wrappers value) - (fill-cache-p nil nfield ncache wrappers value))) - (if (and (dotimes (i (nlines) t) - (when (and (null (line-reserved-p i)) - (line-valid-p i wrappers)) - (unless (try-one-fill-from-line i) (return nil)))) - (try-one-fill wrappers value)) - (return (values nfield ncache)) - (flush-cache-internal ncache))))))) - - -;;; -;;; returns: (values ) -;;; -(defun expand-cache (field cache wrappers value) - (declare (values field cache) (ignore field)) - (with-local-cache-functions (cache) - (multiple-value-bind (ignore size) - (compute-cache-parameters (nkeys) (valuep) (* (nlines) 2)) - (let* ((ncache (get-cache size)) - (nfield (wrapper-field 'number))) - (labels ((do-one-fill-from-line (line) - (unless (fill-cache-from-cache-p nil nfield ncache cache line) - (do-one-fill (line-wrappers line) (line-value line)))) - (do-one-fill (wrappers value) - (multiple-value-bind (adj-field adj-cache) - (adjust-cache nfield ncache wrappers value) - (if adj-field - (setq nfield adj-field ncache adj-cache) - (fill-cache-p t nfield ncache wrappers value)))) - (try-one-fill (wrappers value) - (fill-cache-p nil nfield ncache wrappers value))) - (dotimes (i (nlines)) - (when (and (null (line-reserved-p i)) - (line-valid-p i wrappers)) - (do-one-fill-from-line i))) - (unless (try-one-fill wrappers value) - (do-one-fill wrappers value)) - (values nfield ncache)))))) - - -;;; -;;; This is the heart of the cache filling mechanism. It implements the decisions -;;; about where entries are placed. -;;; -;;; Find a line in the cache at which a new entry can be inserted. -;;; -;;; -;;; is in fact empty? -;;; -(defun find-free-cache-line (primary field cache &optional wrappers) - (declare (values line empty?)) - (with-local-cache-functions (cache) - (let ((limit (funcall (limit-fn) (nlines))) - (wrappedp nil)) - (when (line-reserved-p primary) (setq primary (next-line primary))) - (labels (;; - ;; Try to find a free line starting at . - ;; is the primary line of the entry we are finding a free - ;; line for, it is used to compute the seperations. - ;; - (find-free (p s) - (do* ((line s (next-line line)) - (nsep (line-separation p s) (1+ nsep))) - (()) - (if (null (line-valid-p line wrappers)) ;If this line is empty or - (return (values line t)) ;invalid, just use it. - - (let ((osep (line-separation (line-primary field line) line))) - (if (and wrappedp (>= line primary)) - ;; - ;; have gone all the way around the cache, time to quit - ;; - (return (values line nil)) - - (when (cond ((or (= nsep limit)) t) - ((= nsep osep) (zerop (random 2))) - ((> nsep osep) t) - (t nil)) - ;; - ;; Try to displace what is in this line so that we - ;; can use the line. - ;; - (return (values line (displace line))))))) - - (if (= line (1- (nlines))) (setq wrappedp t)))) - ;; - ;; Given a line, attempt to free up that line by moving its - ;; contents elsewhere. Returns nil when it wasn't possible to - ;; move the contents of the line without dumping something on - ;; the floor. - ;; - (displace (line) - (if (= line (1- (nlines))) (setq wrappedp t)) - (multiple-value-bind (dline dempty?) - (find-free (line-primary field line) (next-line line)) - (when dempty? (copy-line line dline) t)))) - - (find-free primary primary))))) diff --git a/obsolete/clos/2.0/clos-env-internal.lisp b/obsolete/clos/2.0/clos-env-internal.lisp deleted file mode 100644 index 6d720032..00000000 --- a/obsolete/clos/2.0/clos-env-internal.lisp +++ /dev/null @@ -1,260 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL") -(il:filecreated "28-Aug-87 18:42:36" il:{phylum}clos-env-internal.\;1 8356 - - il:|changes| il:|to:| (il:vars il:clos-env-internalcoms) - (il:props (il:clos-env-internal il:makefile-environment)) - (il:functions stack-eql stack-pointer-frame stack-frame-valid-p - stack-frame-fn-header stack-frame-pc fnheader-debugging-info - stack-frame-name compiled-closure-fnheader compiled-closure-env) -) - - -; Copyright (c) 1987 by Xerox Corporation. All rights reserved. - -(il:prettycomprint il:clos-env-internalcoms) - -(il:rpaqq il:clos-env-internalcoms ( - -(il:* il:|;;;| "***************************************") - - - -(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") - - - -(il:* il:|;;;| "") - - - -(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws.") - - - -(il:* il:|;;;| " ") - - - -(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification.") - - - -(il:* il:|;;;| " ") - - - -(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:") - - - -(il:* il:|;;;| " CommonLoops Coordinator") - - - -(il:* il:|;;;| " Xerox Artifical Intelligence Systems") - - - -(il:* il:|;;;| " 2400 Hanover St.") - - - -(il:* il:|;;;| " Palo Alto, CA 94303") - - - -(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") - - - -(il:* il:|;;;| "") - - - -(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") - - - -(il:* il:|;;;| " *************************************************************************") - - - -(il:* il:|;;;| "") - - (il:declare\: il:dontcopy (il:prop il:makefile-environment - il:clos-env-internal)) - (il:* il:\; - "We're off to hack the system...") - - (il:declare\: il:eval@compile il:dontcopy (il:files clos::abc) - - - (il:* il:|;;| "The Deltas and The East and The Freeze") -) - (il:functions stack-eql stack-pointer-frame stack-frame-valid-p - stack-frame-fn-header stack-frame-pc - fnheader-debugging-info stack-frame-name - compiled-closure-fnheader compiled-closure-env))) - - - -(il:* il:|;;;| "***************************************") - - - - -(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.") - - - - -(il:* il:|;;;| "") - - - - -(il:* il:|;;;| -"Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws." -) - - - - -(il:* il:|;;;| " ") - - - - -(il:* il:|;;;| -"This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification." -) - - - - -(il:* il:|;;;| " ") - - - - -(il:* il:|;;;| -"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:" -) - - - - -(il:* il:|;;;| " CommonLoops Coordinator") - - - - -(il:* il:|;;;| " Xerox Artifical Intelligence Systems") - - - - -(il:* il:|;;;| " 2400 Hanover St.") - - - - -(il:* il:|;;;| " Palo Alto, CA 94303") - - - - -(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)") - - - - -(il:* il:|;;;| "") - - - - -(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.") - - - - -(il:* il:|;;;| " *************************************************************************") - - - - -(il:* il:|;;;| "") - -(il:declare\: il:dontcopy - -(il:putprops il:clos-env-internal il:makefile-environment (:package "XCL" :readtable "XCL")) -) - - - -(il:* il:\; "We're off to hack the system...") - -(il:declare\: il:eval@compile il:dontcopy -(il:filesload clos::abc) -) - -(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x) - (il:stackp y) - (eql (il:fetch (il:stackp il:edfxp - ) - il:of x) - (il:fetch (il:stackp il:edfxp - ) - il:of y)))) - - -(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer)) - - -(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame))) - - -(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame)) - - -(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame)) - - -(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc) - il:of fnheader)) - (name-table-words - (let ((size (il:fetch (il:fnheader il:ntsize) - il:of fnheader))) - (if (zerop size) - il:wordsperquad - (* size 2)))) - (past-name-table-in-words (+ (il:fetch (il:fnheader - - il:overheadwords - ) - il:of fnheader) - name-table-words))) - (and (= (- start-pc (* il:bytesperword - past-name-table-in-words)) - il:bytespercell) - - (il:* il:|;;| "It's got a debugging-info list.") - - (il:\\getbaseptr fnheader - past-name-table-in-words)))) - - -(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame)) - - -(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of| - closure)) - - -(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure)) - -(il:putprops il:clos-env-internal il:copyright ("Xerox Corporation" 1987)) -(il:declare\: il:dontcopy - (il:filemap (nil))) -il:stop diff --git a/obsolete/clos/2.0/clos-env.lisp b/obsolete/clos/2.0/clos-env.lisp deleted file mode 100644 index be366810..00000000 --- a/obsolete/clos/2.0/clos-env.lisp +++ /dev/null @@ -1,1609 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; Medley-Lisp specific environment hacking for CLOS - -(in-package "CLOS") - -;; -;; Protect the Corporation -;; -(eval-when (eval load) - (format *terminal-io* - "~&;CLOS-ENV Copyright (c) 1991 by ~ - Venue Corporation. All rights reserved.~%")) - - -;;; Make funcallable instances (FINs) print by calling print-object. - -(eval-when (eval load) - (il:defprint 'il:compiled-closure 'il:print-closure)) - -(defun il:print-closure (x &optional stream depth) - ;; See the IRM, section 25.3.3. Unfortunatly, that documentation is - ;; not correct. In particular, it makes no mention of the third argument. - (cond ((not (funcallable-instance-p x)) - ;; IL:\CCLOSURE.DEFPRINT is the orginal system function for - ;; printing closures - (il:\\cclosure.defprint x stream)) - ((streamp stream) - ;; Use the standard CLOS printing method, then return T to tell - ;; the printer that we have done the printing ourselves. - (print-object x stream) - t) - (t - ;; Internal printing (again, see the IRM section 25.3.3). - ;; Return a list containing the string of characters that - ;; would be printed, if the object were being printed for - ;; real. - (with-output-to-string (stream) - (list (print-object x stream)))))) - - -;;; Naming methods - -(defun gf-named (gf-name) - (let ((spec (cond ((symbolp gf-name) gf-name) - ((and (consp gf-name) - (eq (first gf-name) 'setf) - (symbolp (second gf-name)) - (null (cddr gf-name))) - (get-setf-function-name (second gf-name))) - (t nil)))) - (if (and (fboundp spec) - (generic-function-p (symbol-function spec))) - (symbol-function spec) - nil))) - -(defun generic-function-method-names (gf-name hasdefp) - (if hasdefp - (let ((names nil)) - (maphash #'(lambda (key value) - (declare (ignore value)) - (when (and (consp key) (eql (car key) gf-name)) - (pushnew key names))) - (gethash 'methods xcl:*definition-hash-table*)) - names) - (let ((gf (gf-named gf-name))) - (when gf - (mapcar #'full-method-name (generic-function-methods gf)))))) - -(defun full-method-name (method) - "Return the full name of the method" - (let ((specializers (mapcar #'(lambda (x) - (cond ((eq x 't) t) - ((and (consp x) (eq (car x) 'eql)) x) - (t (class-name x)))) - (method-specializers method)))) - ;; Now go through some hair to make sure that specializer is - ;; really right. Once CLOS returns the right value for - ;; specializers this can be taken out. - (let* ((arglist (method-lambda-list method)) - (number-required (or (position-if - #'(lambda (x) (member x lambda-list-keywords)) - arglist) - (length arglist))) - (diff (- number-required (length specializers)))) - (when (> diff 0) - (setq specializers (nconc (copy-list specializers) - (make-list diff :initial-element 't))))) - (make-full-method-name (generic-function-name - (method-generic-function method)) - (method-qualifiers method) - specializers))) - -(defun make-full-method-name (generic-function-name qualifiers arg-types) - "Return the full name of a method, given the generic-function name, the method -qualifiers, and the arg-types" - ;; The name of the method is: - ;; ( .. - ;; (..)) - (labels ((remove-trailing-ts (l) - (if (null l) - nil - (let ((tail (remove-trailing-ts (cdr l)))) - (if (null tail) - (if (eq (car l) 't) - nil - (list (car l))) - (if (eq l tail) - l - (cons (car l) tail))))))) - `(,generic-function-name ,@qualifiers - ,(remove-trailing-ts arg-types)))) - -(defun parse-full-method-name (method-name) - "Parse the method name, returning the gf-name, the qualifiers, and the -arg-types." - (values (first method-name) - (butlast (rest method-name)) - (car (last method-name)))) - -(defun prompt-for-full-method-name (gf-name &optional has-def-p) - "Prompt the user for the full name of a method on the given generic function name" - (let ((method-names (generic-function-method-names gf-name has-def-p))) - (cond ((null method-names) - nil) - ((null (cdr method-names)) - (car method-names)) - (t (il:menu - (il:create - il:menu il:items il:_ ;If HAS-DEF-P, include only - ; those methods that have a - ; symbolic def'n that we can - ; find - (remove-if #'null - (mapcar #'(lambda (m) - (if (or (not has-def-p) - (il:hasdef m 'methods)) - `(,(with-output-to-string (s) - (dolist (x m) - (format s "~A " x)) - s) - ',m) - nil)) - method-names)) - il:title il:_ "Which method?")))))) - - -;;; Converting generic defining macros into DEFDEFINER macros - -(defmacro make-defdefiner (definer-name definer-type type-description &body - definer-options) - "Make the DEFINER-NAME use DEFDEFINER, defining items of type DEFINER-TYPE" - (let ((old-definer-macro-name (intern (string-append definer-name - " old definition") - (symbol-package definer-name))) - (old-definer-macro-expander (intern (string-append definer-name - " old expander") - (symbol-package definer-name)))) - `(progn - ;; First, move the current defining function off to some safe - ;; place - (unmake-defdefiner ',definer-name) - (cond ((not (fboundp ',definer-name)) - (error "~A has no definition!" ',definer-name)) - ((fboundp ',old-definer-macro-name)) - ((macro-function ',definer-name) - ; We have to move the macro - ; expansion function as well, - ; so it won't get clobbered - ; when the original macro is - ; redefined. See AR 7410. - (let* ((expansion-function (macro-function ',definer-name))) - (setf (symbol-function ',old-definer-macro-expander) - (loop (if (symbolp expansion-function) - (setq expansion-function - (symbol-function expansion-function)) - (return expansion-function)))) - (setf (macro-function ',old-definer-macro-name) - ',old-definer-macro-expander) - (setf (get ',definer-name 'make-defdefiner) expansion-function))) - (t (error "~A does not name a macro." ',definer-name))) - ;; Make sure the type is defined - (xcl:def-define-type ,definer-type ,type-description) - ;; Now redefine the definer, using DEFEDFINER and the original def'n - (xcl:defdefiner ,(if definer-options - (cons definer-name definer-options) - definer-name) - ,definer-type (&body b) `(,',old-definer-macro-name ,@,'b))))) - -(defun unmake-defdefiner (definer-name) - (let ((old-expander (get definer-name 'make-defdefiner))) - (when old-expander - (setf (macro-function definer-name old-expander)) - (remprop definer-name 'make-defdefiner)))) - - -;;; For tricking ED into being able to use just the generic-function-name -;;; instead of the full method name - -(defun source-manager-method-edit-fn (name type source editcoms options) - "Edit a method of the given name" - (let ((full-name (if (gf-named name) - ;If given the name of a - ; generic-function, try to get - ; the full method name - (prompt-for-full-method-name name t) - ; Otherwise it should name the - ; method - name))) - (when (not (null full-name)) - (il:default.editdef full-name type source editcoms options)) - (or full-name name))) ;Return the name - -(defun source-manager-method-hasdef-fn (name type &optional source) - "Is there a method defined with the given name?" - (cond ((not (eq type 'methods)) nil) - ((or (symbolp name) - (and (consp name) - (eq (first name) 'setf) - (symbolp (second name)) - (null (cddr name)))) - ;; If passed in the name of a generic-function, pretend that - ;; there is a method by that name if there is a generic function - ;; by that name, and there is a method whose source we can find. - (if (and (not (null (gf-named name))) - (find-if #'(lambda (m) - (il:hasdef m type source)) - (generic-function-method-names name t))) - name - nil)) - ((and (consp name) (>= (length name) 2)) - ;; Standard methods are named (gf-name {qualifiers}* ({specializers}*)) - (when (il:getdef name type source '(il:nocopy il:noerror)) - name)) - (t - ;; Nothing else can name a method - nil))) - -;;; Initialize the CLOS env - -(defun initialize-clos-env nil - "Initialize the Medley CLOS environment" - ;; Set up SourceManager DEFDEFINERS for classes and methods. - ;; - ;; Make sure to define methods before classes, so that (IL:FILES?) will build - ;; filecoms that have classes before methods. - (unless (il:hasdef 'methods 'il:filepkgtype) - (make-defdefiner defmethod methods "methods" - (:name (lambda (form) - (multiple-value-bind (name qualifiers arglist) - (parse-defmethod (cdr form)) - (make-full-method-name name qualifiers - (specialized-lambda-list-specializers - arglist))))) - (:undefiner - (lambda (method-name) - (multiple-value-bind - (name qualifiers arg-types) - (parse-full-method-name method-name) - (let* ((gf (gf-named name)) - (method (when gf - (get-method gf qualifiers - (mapcar #'find-class - arg-types))))) - (when method (remove-method gf method)))))))) - ;; Include support for DEFGENERIC, if that is defined - (unless (or (not (fboundp 'defgeneric)) - (il:hasdef 'generic-functions 'il:filepkgtype)) - (make-defdefiner defgeneric generic-functions "generic-function definitions")) - ;; DEFCLASS FileManager stuff - (unless (il:hasdef 'classes 'il:filepkgtype) - (make-defdefiner defclass classes "class definitions" - (:undefiner (lambda (name) - (when (find-class name t) - (setf (find-class name) nil))))) - ;; CLASSES "include" TYPES. - (il:filepkgcom 'classes 'il:contents - #'(lambda (com name type &optional reason) - (declare (ignore name reason)) - (if (member type '(il:types classes) :test #'eq) - (cdr com) - nil)))) - ;; Set up the hooks so that ED can be handed the name of a generic function, - ;; and end up editing a method instead - (il:filepkgtype 'methods 'il:editdef 'source-manager-method-edit-fn - 'il:hasdef 'source-manager-method-hasdef-fn) - ;; Set up the inspect macro. The right way to do this is to - ;; (ENSURE-GENERIC-FUNCTION 'IL:INSPECT...), but for now... - (push '((il:function clos-object-p) . \\internal-inspect-object) - il:inspectmacros) - ;; Unmark any SourceManager changes caused by this loadup - (dolist (com (il:filepkgchanges)) - (dolist (name (cdr com)) - (when (and (symbolp name) - (eq (symbol-package name) (find-package "CLOS"))) - (il:unmarkaschanged name (car com)))))) - -(eval-when (eval load) - (initialize-clos-env)) - - -;;; Inspecting CLOS objects - -(defun clos-object-p (x) - "Is the datum a CLOS object?" - (or (std-instance-p x) - (fsc-instance-p x))) - -(defun \\internal-inspect-object (x type where) - (inspect-object x type where)) - -(defun \\internal-inspect-slot-names (x) - (inspect-slot-names x)) - -(defun \\internal-inspect-slot-value (x slot-name) - (inspect-slot-value x slot-name)) - -(defun \\internal-inspect-setf-slot-value (x slot-name value) - (inspect-setf-slot-value x slot-name value)) - -(defun \\internal-inspect-slot-name-command (slot-name x window) - (inspect-slot-name-command slot-name x window)) - -(defun \\internal-inspect-title (x y) - (inspect-title x y)) - -(defmethod inspect-object (x type where) - "Open an insect window on the object x" - (il:inspectw.create x '\\internal-inspect-slot-names - '\\internal-inspect-slot-value - '\\internal-inspect-setf-slot-value - '\\internal-inspect-slot-name-command nil nil - '\\internal-inspect-title nil where - #'(lambda (n v) ;Same effect as NIL, but avoids bug in - (declare (ignore v)) ; INSPECTW.CREATE - n))) - -(defmethod inspect-slot-names (x) - "Return a list of names of slots of the object that should be shown in the -inspector" - (mapcar #'(lambda (slotd) (slot-value slotd 'name)) - (slots-to-inspect (class-of x) x))) - -(defmethod inspect-slot-value (x slot-name) - (cond ((not (slot-exists-p x slot-name)) "** no such slot **") - ((not (slot-boundp x slot-name)) "** slot not bound **") - (t (slot-value x slot-name)))) - -(defmethod inspect-setf-slot-value (x slot-name value) - "Used by the inspector to set the value fo a slot" - ;; Make this UNDO-able - (il:undosave `(inspect-setf-slot-value ,x ,slot-name - ,(slot-value x slot-name))) - ;; Then change the value - (setf (slot-value x slot-name) value)) - -(defmethod inspect-slot-name-command (slot-name x window) - "Allows the user to select a menu item to change a slot value in an inspect -window" - ;; This code is a very slightly hacked version of the system function - ;; DEFAULT.INSPECTW.PROPCOMMANDFN. We have to do this because the - ;; standard version makes some nasty assumptions about - ;; structure-objects that are not true for CLOS objects. - (declare (special il:|SetPropertyMenu|)) - (case (il:menu (cond ((typep il:|SetPropertyMenu| 'il:menu) - il:|SetPropertyMenu|) - (t (il:setq il:|SetPropertyMenu| - (il:|create| il:menu il:items il:_ - '((set 'set - "Allows a new value to be entered" - ))))))) - (set - ;; The user want to set the value - (il:ersetq (prog ((il:oldvalueitem (il:itemofpropertyvalue slot-name - window)) - il:newvalue il:pwindow) - (il:ttydisplaystream (il:setq il:pwindow - (il:getpromptwindow window 3))) - (il:clearbuf t t) - (il:resetlst - (il:resetsave (il:\\itemw.flipitem il:oldvalueitem window) - (list 'il:\\itemw.flipitem - il:oldvalueitem window)) - (il:resetsave (il:tty.process (il:this.process))) - (il:resetsave (il:printlevel 4 3)) - (il:|printout| t "Enter the new " - slot-name " for " x t - "The expression read will be EVALuated." - t "> ") - (il:setq il:newvalue (il:lispx (il:lispxread t t) - '>)) - ; clear tty buffer because it - ; sometimes has stuff left. - (il:clearbuf t t)) - (il:closew il:pwindow) - (return (il:inspectw.replace window slot-name il:newvalue))))))) - -(defmethod inspect-title (x window) - "Return the title to use in an inspect window viewing x" - (format nil "Inspecting a ~A" (class-name (class-of x)))) - -(defmethod inspect-title ((x standard-class) window) - (format nil "Inspecting the class ~A" (class-name x))) - - -;;; Debugger support for CLOS - - -(il:filesload clos-env-internal) - -;; Non-CLOS specific changes to the debugger - -;; Redefining the standard INTERESTING-FRAME-P function. Now functions can be -;; declared uninteresting to BT by giving them an XCL::UNINTERESTINGP -;; property. - -(dolist (fn '(si::*unwind-protect* il:*env* - evalhook xcl::nohook xcl::undohook - xcl::execa0001 xcl::execa0001a0002 - xcl::|interpret-UNDOABLY| - cl::|interpret-IF| cl::|interpret-FLET| - cl::|interpret-LET| cl::|interpret-LETA0001| - cl::|interpret-BLOCK| cl::|interpret-BLOCKA0001| - il:do-event il:eval-input - apply t)) - (setf (get fn 'xcl::uninterestingp) t)) - -(defun xcl::interesting-frame-p (xcl::pos &optional xcl::interpflg) - "Return TRUE iff the frame should be visible for a short backtrace." - (declare (special il:openfns)) - (let ((xcl::name (if (il:stackp xcl::pos) (il:stkname xcl::pos) xcl::pos))) - (typecase xcl::name - (symbol (case xcl::name - (il:*env* - ;; *ENV* is used by ENVEVAL etc. - nil) - (il:errorset - (or (<= (il:stknargs xcl::pos) 1) - (not (eq (il:stkarg 2 xcl::pos nil) - 'il:internal)))) - (il:eval - (or (<= (il:stknargs xcl::pos) 1) - (not (eq (il:stkarg 2 xcl::pos nil) - 'xcl::internal)))) - (il:apply - (or (<= (il:stknargs xcl::pos) 2) - (not (il:stkarg 3 xcl::pos nil)))) - (otherwise - (cond ((get xcl::name 'xcl::uninterestingp) - ;; Explicitly declared uninteresting. - nil) - ((eq (il:chcon1 xcl::name) (char-code #\\)) - ;; Implicitly declared uninteresting by starting the - ;; name with a "\". - nil) - ((or (member xcl::name il:openfns :test #'eq) - (eq xcl::name 'funcall)) - ;;The function won't be seen when compiled, so only show - ;;it if INTERPFLG it true - xcl::interpflg) - (t - ;; Interesting by default. - t))))) - (cons (case (car xcl::name) - (:broken t) - (otherwise nil))) - (otherwise nil)))) - -(setq il:*short-backtrace-filter* 'xcl::interesting-frame-p) - - -(eval-when (eval compile) - (il:record il:bkmenuitem (il:label (il:bkmenuinfo il:frame-name)))) - - -;; Change the frame inspector to open up lexical environments - - ;; Since the DEFSTRUCT is going to build the accessors in the package that is - ;; current at read-time, and we want the accessors to reside in the IL - ;; package, we have got to make sure that the defstruct happens when the - ;; package is IL. - -(in-package "IL") - -(cl:defstruct (frame-prop-name (:type cl:list)) - (label-fn 'nill) - (value-fn - (function - (lambda (prop-name framespec) - (frame-prop-name-data prop-name)))) - (setf-fn 'nill) - (inspect-fn - (function - (lambda (value prop-name framespec window) - (default.inspectw.valuecommandfn value prop-name (car framespec) window)))) - (data nil)) - -(cl:in-package "CLOS") - -(defun il:debugger-stack-frame-prop-names (il:framespec) - ;; Frame prop-names are structures of the form - ;; (LABEL-FN VALUE-FN SETF-FN EDIT-FN DATA) - (let ((il:pos (car il:framespec)) - (il:backtrace-item (cadr il:framespec))) - (il:if (eq 'eval (il:stkname il:pos)) - il:then - (let ((il:expression (il:stkarg 1 il:pos)) - (il:environment (il:stkarg 2 il:pos))) - `(,(il:make-frame-prop-name :inspect-fn - (il:function - (il:lambda (il:value il:prop-name il:framespec il:window) - (il:inspect/as/function il:value (car il:framespec) il:window))) - :data il:expression) - ,(il:make-frame-prop-name :data "ENVIRONMENT") - ,@(il:for il:aspect il:in - `((,(and il:environment (il:environment-vars il:environment)) - "vars") - (,(and il:environment (il:environment-functions il:environment)) - "functions") - (,(and il:environment (il:environment-blocks il:environment)) - "blocks") - (,(and il:environment (il:environment-tagbodies il:environment)) - "tag bodies")) - il:bind il:group-name il:p-list - il:eachtime (il:setq il:group-name (cadr il:aspect)) - (il:setq il:p-list (car il:aspect)) - il:when (not (null il:p-list)) - il:join - `(,(il:make-frame-prop-name :data il:group-name) - ,@(il:for il:p il:on il:p-list il:by cddr il:collect - (il:make-frame-prop-name :label-fn - (il:function (il:lambda (il:prop-name il:framespec) - (car (il:frame-prop-name-data il:prop-name)))) - :value-fn - (il:function (il:lambda (il:prop-name il:framespec) - (cadr (il:frame-prop-name-data il:prop-name)))) - :setf-fn - (il:function (il:lambda (il:prop-name il:framespec il:new-value) - (il:change (cadr (il:frame-prop-name-data - il:prop-name)) - il:new-value))) - :data il:p)))))) - il:else - (flet ((il:build-name (&key il:arg-name il:arg-number) - (il:make-frame-prop-name :label-fn - (il:function (il:lambda (il:prop-name il:framespec) - (car (il:frame-prop-name-data il:prop-name)))) - :value-fn - (il:function (il:lambda (il:prop-name il:framespec) - (il:stkarg (cadr (il:frame-prop-name-data - il:prop-name)) - (car il:framespec)))) - :setf-fn - (il:function (il:lambda (il:prop-name il:framespec il:new-value) - (il:setstkarg (cadr (il:frame-prop-name-data - il:prop-name)) - (car il:framespec) - il:new-value))) - :data - (list il:arg-name il:arg-number)))) - (let ((il:nargs (il:stknargs il:pos t)) - (il:nargs1 (il:stknargs il:pos)) - (il:fnname (il:stkname il:pos)) - il:argname - (il:arglist)) - (and (il:litatom il:fnname) - (il:ccodep il:fnname) - (il:setq il:arglist (il:listp (il:smartarglist il:fnname)))) - `(,(il:make-frame-prop-name :inspect-fn - (il:function (il:lambda (il:value il:prop-name il:framespec - il:window) - (il:inspect/as/function il:value - (car il:framespec) - il:window))) - :data - (il:fetch (il:bkmenuitem il:frame-name) il:of il:backtrace-item)) - ,@(il:bind il:mode il:for il:i il:from 1 il:to il:nargs1 il:collect - (progn (il:while (il:fmemb (il:setq il:argname (il:pop il:arglist)) - lambda-list-keywords) - il:do - (il:setq il:mode il:argname)) - (il:build-name :arg-name - (or (il:stkargname il:i il:pos) - ; special - (if (case il:mode - ((nil &optional) il:argname) - (t nil)) - (string il:argname) - (il:concat "arg " (- il:i 1)))) - :arg-number il:i))) - ,@(let* ((il:novalue "No value") - (il:slots (il:for il:pvar il:from 0 il:as il:i il:from - (il:add1 il:nargs1) - il:to il:nargs il:by 1 il:when - (and (il:neq il:novalue (il:stkarg il:i il:pos - il:novalue)) - (or (il:setq il:argname (il:stkargname - il:i il:pos)) - (il:setq il:argname (il:concat - "local " - il:pvar))) - ) - il:collect - (il:build-name :arg-name il:argname - :arg-number il:i)))) - (and il:slots (cons (il:make-frame-prop-name :data "locals") - il:slots))))))))) - -(defun il:debugger-stack-frame-fetchfn (il:framespec il:prop-name) - (il:apply* (il:frame-prop-name-value-fn il:prop-name) - il:prop-name il:framespec)) - -(defun il:debugger-stack-frame-storefn (il:framespec il:prop-name il:newvalue) - (il:apply* (il:frame-prop-name-setf-fn il:prop-name) - il:prop-name il:framespec il:newvalue)) - -(defun il:debugger-stack-frame-value-command (il:datum il:prop-name - il:framespec il:window) - (il:apply* (il:frame-prop-name-inspect-fn il:prop-name) - il:datum il:prop-name il:framespec il:window)) - -(defun il:debugger-stack-frame-title (il:framespec &optional il:window) - (declare (ignore il:window)) - (il:concat (il:stkname (car il:framespec)) " Frame")) - -(defun il:debugger-stack-frame-property (il:prop-name il:framespec) - (il:apply* (il:frame-prop-name-label-fn il:prop-name) - il:prop-name il:framespec)) - -;; Teaching the debugger that there are other file-manager types that can -;; appear on the stack - -(defvar xcl::*function-types* '(il:fns il:functions) - "Manager types that can appear on the stack") - -;; Redefine a couple of system functions to use the above stuff - -#+Xerox-Lyric -(progn - -(defun il:attach-backtrace-menu (&optional (il:ttywindow - (il:wfromds (il:ttydisplaystream))) - il:skip) - (let ((il:bkmenu (il:|create| il:menu - il:items il:_ - (il:collect-backtrace-items il:ttywindow il:skip) - il:whenselectedfn il:_ - (il:function il:backtrace-item-selected) - il:whenheldfn il:_ - #'(il:lambda (il:item il:menu il:button) - (declare (ignore il:item il:menu)) - (case il:button - (il:left (il:promptprint - "Open a frame inspector on this stack frame" - )) - (il:middle (il:promptprint - "Inspect/Edit this function")) - )) - il:menuoutlinesize il:_ 0 - il:menufont il:_ il:backtracefont - il:menucolumns il:_ 1)) - (il:ttyregion (il:windowprop il:ttywindow 'il:region)) - il:btw) - (cond - ((il:setq il:btw (il:|for| il:atw il:|in| (il:attachedwindows il:ttywindow) - il:|when| (and (il:setq il:btw (il:windowprop il:atw 'il:menu)) - (eql (il:|fetch| (il:menu il:whenselectedfn) - il:|of| (car il:btw)) - (il:function il:backtrace-item-selected))) - il:|do| - (return il:atw))) - (il:deletemenu (car (il:windowprop il:btw 'il:menu)) - nil il:btw) - (il:windowprop il:btw 'il:extent nil) - (il:clearw il:btw)) - ((il:setq il:btw (il:createw (il:region-next-to (il:windowprop il:ttywindow 'il:region) - (il:widthifwindow (il:imin (il:|fetch| (il:menu - il:imagewidth - ) - il:|of| il:bkmenu) - il:|MaxBkMenuWidth|)) - (il:|fetch| (il:region il:height) il:|of| il:ttyregion - ) - 'il:left))) - (il:attachwindow il:btw il:ttywindow (cond - ((il:igreaterp (il:|fetch| (il:region il:left) - il:|of| (il:windowprop - il:btw - 'il:region)) - (il:|fetch| (il:region il:left) - il:|of| il:ttyregion)) - 'il:right) - (t 'il:left)) - nil - 'il:localclose) - (il:windowprop il:btw 'il:process (il:windowprop il:ttywindow 'il:process)) - - )) - (il:addmenu il:bkmenu il:btw (il:|create| il:_ il:position - il:xcoord il:_ 0 - il:ycoord il:_ (il:idifference (il:windowprop - il:btw - 'il:height) - (il:|fetch| (il:menu il:imageheight - ) il:|of| - il:bkmenu - )))))) - -(defun il:backtrace-item-selected (il:item il:menu il:button) - (il:resetlst - (prog (il:olditem il:ttywindow il:bkpos il:pos il:positions il:framewindow - (il:framespecn (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| il:item) - - )) - (cond - ((il:setq il:olditem (il:|fetch| (il:menu il:menuuserdata) il:|of| il:menu)) - (il:menudeselect il:olditem il:menu) - )) - (il:setq il:ttywindow (il:windowprop (il:wfrommenu il:menu) - 'il:mainwindow)) - (il:setq il:bkpos (il:windowprop il:ttywindow 'il:stack-position)) - (il:setq il:pos (il:stknth (- il:framespecn) - il:bkpos)) - (let ((il:lp (il:windowprop il:ttywindow 'il:lastpos))) - (and il:lp (il:stknth 0 il:pos il:lp))) - (il:menuselect il:item il:menu) - (if (eq il:button 'il:middle) - (progn - - - (il:resetsave nil (list 'il:relstk il:pos)) - (il:inspect/as/function (il:|fetch| (il:bkmenuitem il:frame-name) - il:|of| il:item) - il:pos il:ttywindow)) - (progn - - - (il:setq il:framewindow - (xcl:with-profile (il:process.eval - (il:windowprop il:ttywindow 'il:process) - '(let ((il:profile (xcl:copy-profile (xcl:find-profile - "READ-PRINT")))) - (setf (xcl::profile-entry-value ' - xcl:*eval-function* il:profile) - xcl:*eval-function*) - (xcl:save-profile il:profile)) - t) - (il:inspectw.create (list il:pos il:item) - 'il:debugger-stack-frame-prop-names - 'il:debugger-stack-frame-fetchfn - 'il:debugger-stack-frame-storefn nil ' - il:debugger-stack-frame-value-command nil ' - il:debugger-stack-frame-title nil ( - il:make-frame-inspect-window - il:ttywindow) - 'il:debugger-stack-frame-property))) - (cond - ((not (il:windowprop il:framewindow 'il:mainwindow)) - (il:attachwindow il:framewindow il:ttywindow - (cond - ((il:igreaterp (il:|fetch| (il:region il:bottom) - il:|of| (il:windowprop il:framewindow - 'il:region)) - (il:|fetch| (il:region il:bottom) - il:|of| (il:windowprop il:ttywindow 'il:region))) - 'il:top) - (t 'il:bottom)) - nil - 'il:localclose) - (il:windowaddprop il:framewindow 'il:closefn (il:function il:detachwindow - )))))) - (return)))) - -(defun il:collect-backtrace-items (xcl::tty-window xcl::skip) - (let* ((xcl::items (cons nil nil)) - (xcl::items-tail xcl::items)) - (macrolet ((xcl::collect-item (xcl::new-item) - `(progn (setf (rest xcl::items-tail) - (cons ,xcl::new-item nil)) - (pop xcl::items-tail)))) - (let* ((xcl::filter-fn (cond - ((null xcl::skip) - #'xcl:true) - ((eq xcl::skip t) - il:*short-backtrace-filter*) - (t xcl::skip))) - (xcl::top-frame (il:stknth 0 (il:getwindowprop xcl::tty-window ' - il:stack-position))) - (xcl::next-frame xcl::top-frame) - (xcl::frame-number 0) - xcl::interesting-p xcl::last-frame-consumed xcl::use-frame xcl::label) - (loop (when (null xcl::next-frame) - (return)) - (multiple-value-setq (xcl::interesting-p xcl::last-frame-consumed - xcl::use-frame xcl::label) - (funcall xcl::filter-fn xcl::next-frame)) - (when (null xcl::last-frame-consumed) - - (setf xcl::last-frame-consumed xcl::next-frame)) - (when xcl::interesting-p - (when (null xcl::use-frame) - (setf xcl::use-frame xcl::last-frame-consumed)) - - (when (null xcl::label) - (setf xcl::label (il:stkname xcl::use-frame)) - (if (member xcl::label '(eval il:eval il:apply apply) - :test - 'eq) - (setf xcl::label (il:stkarg 1 xcl::use-frame)))) - - (loop (cond - ((not (typep xcl::next-frame 'il:stackp)) - (error "~%Use-frame ~S not found" xcl::use-frame)) - ((xcl::stack-eql xcl::next-frame xcl::use-frame) - (return)) - (t (incf xcl::frame-number) - (setf xcl::next-frame (il:stknth -1 xcl::next-frame - xcl::next-frame))))) - - (xcl::collect-item (il:|create| il:bkmenuitem - il:label il:_ (let ((*print-level* 2) - (*print-length* 3) - (*print-escape* t) - (*print-gensym* t) - (*print-pretty* nil) - (*print-circle* nil) - (*print-radix* 10) - (*print-array* nil) - (il:*print-structure* - nil)) - (prin1-to-string - xcl::label)) - il:bkmenuinfo il:_ xcl::frame-number - il:frame-name il:_ xcl::label))) - - (loop (cond - ((not (typep xcl::next-frame 'il:stackp)) - (error "~%Last-frame-consumed ~S not found" - xcl::last-frame-consumed)) - ((prog1 (xcl::stack-eql xcl::next-frame xcl::last-frame-consumed - ) - (incf xcl::frame-number) - (setf xcl::next-frame (il:stknth -1 xcl::next-frame - - xcl::next-frame))) - (return))))))) - (rest xcl::items))) - -) -#+Xerox-Medley -(progn - -(defun dbg::attach-backtrace-menu (&optional tty-window skip) - (declare (special il:\\term.ofd il:backtracefont)) - (or tty-window (il:setq tty-window (il:wfromds (il:ttydisplaystream)))) - (prog (btw bkmenu - (tty-region (il:windowprop tty-window 'il:region)) - ;; And, for the FORMAT below... - (*print-level* 2) - (*print-length* 3) - (*print-escape* t) - (*print-gensym* t) - (*print-pretty* nil) - (*print-circle* nil) - (*print-radix* 10) - (*print-array* nil) - (il:*print-structure* nil)) - (setq bkmenu - (il:|create| il:menu - il:items il:_ (dbg::collect-backtrace-items tty-window skip) - il:whenselectedfn il:_ 'dbg::backtrace-item-selected - il:menuoutlinesize il:_ 0 - il:menufont il:_ il:backtracefont - il:menucolumns il:_ 1 - il:whenheldfn il:_ - #'(il:lambda (item menu button) - (declare (ignore item menu)) - (case button - (il:left - (il:promptprint - "Open a frame inspector on this stack frame")) - (il:middle - (il:promptprint "Inspect/Edit this function")))))) - (cond ((setq btw - (dolist (atw (il:attachedwindows tty-window)) - ;; Test for an attached window that has a backtrace menu in - ;; it. - (when (and (setq btw (il:windowprop atw 'il:menu)) - (eq (il:|fetch| (il:menu il:whenselectedfn) - il:|of| (car btw)) - 'dbg::backtrace-item-selected)) - (return atw)))) - ;; If there is alread a backtrace window, delete the old menu from - ;; it. - (il:deletemenu (car (il:windowprop btw 'il:menu)) nil btw) - (il:windowprop btw 'il:extent nil) - (il:clearw btw)) - ((setq btw - (il:createw (dbg::region-next-to - (il:windowprop tty-window 'il:region) - (il:widthifwindow - (il:imin (il:|fetch| (il:menu il:imagewidth) - il:|of| bkmenu) - il:|MaxBkMenuWidth|)) - (il:|fetch| (il:region il:height) - il:|of| tty-region) - :left))) - ; put bt window at left of TTY - ; window unless ttywindow is - ; near left edge. - (il:attachwindow btw tty-window - (if (il:igreaterp (il:|fetch| (il:region il:left) - il:|of| - (il:windowprop btw - 'il:region)) - (il:|fetch| (il:region il:left) - il:|of| tty-region)) - 'il:right - 'il:left) - nil - 'il:localclose) - ;; So that button clicks will switch the TTY - (il:windowprop btw 'il:process - (il:windowprop tty-window 'il:process)))) - (il:addmenu bkmenu btw (il:|create| il:position - il:xcoord il:_ 0 - il:ycoord il:_ (- (il:windowprop btw 'il:height) - (il:|fetch| (il:menu - il:imageheight) - il:|of| bkmenu)))) - ;; IL:ADDMENU sets up buttoneventfn for window that we don't - ;; want. We want to catch middle button events before the menu - ;; handler, so that we can pop up edit/inspect menu for the frame - ;; currently selected. So replace the buttoneventfn, and can - ;; nuke the cursorin and cursormoved guys, cause don't need them. - (il:windowprop btw 'il:buttoneventfn 'dbg::backtrace-menu-buttoneventfn) - (il:windowprop btw 'il:cursorinfn nil) - (il:windowprop btw 'il:cursormovedfn nil))) - -(defun dbg::collect-backtrace-items (tty-window skip) - (xcl:with-collection - ;; - ;; There are a number of possibilities for the values returned by the - ;; filter-fn. - ;; - ;; (1) INTERESTING-P is false, and the other values are all NIL. This - ;; is the simple case where the stack frame NEXT-POS should be ignored - ;; completly, and processing should continue with the next frame. - ;; - ;; (2) INTERESTING-P is true, and the other values are all NIL. This - ;; is the simple case where the stack frame NEXT-POS should appear in - ;; the backtrace as is, and processing should continue with the next - ;; frame. - ;; - ;; [Note that these two cases take care of old values of the - ;; filter-fn.] - ;; - ;; (3) INTERESTING-P is false, and LAST-FRAME-CONSUMED is a stack - ;; frame. In that case, ignore all stack frames from NEXT-POS to - ;; LAST-FRAME-CONSUMED, inclusive. - ;; - ;; (4) INTERESTING-P is true, and LAST-FRAME-CONSUMED is a stack - ;; frame. In this case, the backtrace should include a single entry - ;; coresponding to the frame USE-FRAME (which defaults to - ;; LAST-FRAME-CONSUMED), and processing should continue with the next - ;; frame after LAST-FRAME-CONSUMED. If LABEL is non-NIL, it will be - ;; the label that appears in the backtrace menu; otherwise the name of - ;; USE-FRAME will be used (or the form being EVALed if the frame is an - ;; EVAL frame). - ;; - (let* ((filter (cond ((null skip) #'xcl:true) - ((eq skip t) il:*short-backtrace-filter*) - (t skip))) - (top-frame (il:stknth 0 (il:getwindowprop tty-window - 'dbg::stack-position))) - (next-frame top-frame) - (frame-number 0) - interestingp last-frame-consumed frame-to-use label-to-use) - (loop (when (null next-frame) (return)) - ;; Get the values of INTERSTINGP, LAST-FRAME-CONSUMED, - ;; FRAME-TO-USE, and LABEL-TO-USE - (multiple-value-setq (interestingp last-frame-consumed - frame-to-use label-to-use) - (funcall filter next-frame)) - (when (null last-frame-consumed) - (setf last-frame-consumed next-frame)) - (when interestingp - (when (null frame-to-use) - (setf frame-to-use last-frame-consumed)) - (when (null label-to-use) - (setf label-to-use (il:stkname frame-to-use)) - (if (member label-to-use '(eval il:eval il:apply apply) - :test 'eq) - (setf label-to-use (il:stkarg 1 frame-to-use)))) - - ;; Walk the stack until we find the frame to use - (loop (cond ((not (typep next-frame 'il:stackp)) - (error "~%Use-frame ~S not found" frame-to-use)) - ((xcl::stack-eql next-frame frame-to-use) - (return)) - (t (incf frame-number) - (setf next-frame - (il:stknth -1 next-frame next-frame))))) - - ;; Add the menu item to the list under construction - (xcl:collect (il:|create| il:bkmenuitem - il:label il:_ (let ((*print-level* 2) - (*print-length* 3) - (*print-escape* t) - (*print-gensym* t) - (*print-pretty* nil) - (*print-circle* nil) - (*print-radix* 10) - (*print-array* nil) - (il:*print-structure* nil)) - (prin1-to-string label-to-use)) - il:bkmenuinfo il:_ frame-number - il:frame-name il:_ label-to-use))) - - ;; Update NEXT-POS - (loop (cond ((not (typep next-frame 'il:stackp)) - (error "~%Last-frame-consumed ~S not found" - last-frame-consumed)) - ((prog1 - (xcl::stack-eql next-frame last-frame-consumed) - (incf frame-number) - (setf next-frame (il:stknth -1 next-frame - next-frame))) - (return)))))))) - -(defun dbg::backtrace-menu-buttoneventfn (window &aux menu) - (setq menu (car (il:listp (il:windowprop window 'il:menu)))) - (unless (or (il:lastmousestate il:up) (null menu)) - (il:totopw window) - (cond ((il:lastmousestate il:middle) - ;; look for a selected frame in this menu, and then pop up - ;; the editor invoke menu for that frame. don't change the - ;; selection, just present the edit menu. - (let* ((selection (il:menu.handler menu - (il:windowprop window 'il:dsp))) - (tty-window (il:windowprop window 'il:mainwindow)) - (last-pos (il:windowprop tty-window 'dbg::lastpos))) - - ;; don't have to worry about releasing POS because we - ;; only look at it here (nobody here hangs on to it) - ;; and we will be around for less time than LASTPOS. - ;; The debugger is responsible for releasing LASTPOS. - (il:inspect/as/function (cond - ((and selection - (il:|fetch| (il:bkmenuitem il:frame-name) - il:|of| (car selection)))) - ((and (symbolp (il:stkname last-pos)) - (il:getd (il:stkname last-pos))) - (il:stkname last-pos)) - (t 'il:nill)) - last-pos tty-window))) - (t (let ((selection (il:menu.handler menu - (il:windowprop window 'il:dsp)))) - (when selection - (il:doselecteditem menu (car selection) (cdr selection)))))))) - -;; This function isn't really redefined, but it needs to be recomiled since we -;; changed the def'n of the BKMENUITEM record. - -(defun dbg::backtrace-item-selected (item menu button) - ;;When a frame name is selected in the backtrace menu, this is the function - ;;that gets called. - (declare (special il:brkenv) (ignore button)) - (let* ((frame-spec (il:|fetch| (il:bkmenuitem il:bkmenuinfo) il:|of| item)) - (tty-window (il:windowprop (il:wfrommenu menu) 'il:mainwindow)) - (bkpos (il:windowprop tty-window 'dbg::stack-position)) - (pos (il:stknth (- frame-spec) bkpos))) - (let ((lp (il:windowprop tty-window 'dbg::lastpos))) - (and lp (il:stknth 0 pos lp))) - ;; change the item selected from OLDITEM to ITEM. Only do this on left - ;; buttons now. Middle just pops up the edit menu, doesn't select. -woz - (let ((old-item (il:|fetch| (il:menu il:menuuserdata) il:|of| menu))) - (when old-item (il:menudeselect old-item menu)) - (il:menuselect item menu)) - ;; Change the lexical environment so it is the one in effect as of this - ;; frame. - (il:process.eval (il:windowprop tty-window (quote dbg::process)) - `(setq il:brkenv ',(il:find-lexical-environment pos)) - t) - (let ((frame-window (xcl:with-profile - (il:process.eval (il:windowprop tty-window - 'il:process) - `(let ((profile (xcl:copy-profile - (xcl:find-profile - "READ-PRINT")))) - (setf - (xcl::profile-entry-value - 'xcl:*eval-function* profile) - xcl:*eval-function*) - (xcl:save-profile profile)) - t) - (il:inspectw.create pos - #'(lambda (pos) - (dbg::stack-frame-properties pos t)) - 'dbg::stack-frame-fetchfn - 'dbg::stack-frame-storefn - nil - 'dbg::stack-frame-value-command - nil - (format nil "~S Frame" (il:stkname pos)) - nil (dbg::make-frame-inspect-window - tty-window) - 'dbg::stack-frame-property)))) - (when (not (il:windowprop frame-window 'il:mainwindow)) - (il:attachwindow frame-window tty-window - (if (> (il:|fetch| (il:region il:bottom) il:|of| - (il:windowprop frame-window 'il:region)) - (il:|fetch| (il:region il:bottom) il:|of| - (il:windowprop tty-window 'il:region))) - 'il:top 'il:bottom) - nil 'il:localclose) - (il:windowaddprop frame-window 'il:closefn 'il:detachwindow))))) - -) ;end of Xerox-Medley - -(defun il:select.fns.editor (&optional function) - ;; gives the user a menu choice of editors. - (il:menu (il:|create| il:menu - il:items il:_ (cond ((il:ccodep function) - '((il:|InspectCode| 'il:inspectcode - "Shows the compiled code.") - (il:|DisplayEdit| 'ed - "Edit it with the display editor") - (il:|TtyEdit| 'il:ef - "Edit it with the standard editor"))) - ((il:closure-p function) - '((il:|Inspect| 'inspect - "Inspect this object"))) - (t '((il:|DisplayEdit| 'ed - "Edit it with the display editor") - (il:|TtyEdit| 'il:ef - "Edit it with the standard editor")))) - il:centerflg il:_ t))) - -;; - - -;; CLOS specific extensions to the debugger - - -;; There are some new things that act as functions, and that we want to be -;; able to edit from a backtrace window - -(pushnew 'methods xcl::*function-types*) - -(eval-when (eval compile load) - (unless (generic-function-p (symbol-function 'il:inspect/as/function)) - (make-specializable 'il:inspect/as/function))) - -(defmethod il:inspect/as/function (name stack-pointer debugger-window) - ;; Calls an editor on function NAME. STKP and WINDOW are the stack pointer - ;; and window of the break in which this inspect command was called. - (declare (ignore debugger-window)) - (let ((editor (il:select.fns.editor name))) - (case editor - ((nil) - ;; No editor chosen, so don't do anything - nil) - (il:inspectcode - ;; Inspect the compiled code - (let ((frame (xcl::stack-pointer-frame stack-pointer))) - (if (and (il:stackp stack-pointer) - (xcl::stack-frame-valid-p frame)) - (il:inspectcode (let ((code-base (xcl::stack-frame-fn-header frame))) - (cond ((eq (il:\\get-compiled-code-base name) - code-base) - name) - (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 - (il:make-compiled-closure code-base)))) - nil nil nil (xcl::stack-frame-pc frame)) - (il:inspectcode name)))) - (ed - ;; Use the standard editor. - ;; This used to take care to apply the editor in the debugger - ;; process, so forms evaluated in the editor happen in the - ;; context of the break. But that doesn't count for much any - ;; more, now that lexical variables are the way to go. Better to - ;; use the LEX debugger command (thank you, Herbie) and - ;; shift-select pieces of code from the editor into the debugger - ;; window. - (ed name `(,@xcl::*function-types* :display))) - (otherwise (funcall editor name))))) - -(defmethod il:inspect/as/function ((name standard-object) stkp window) - (when (il:menu (il:|create| il:menu - il:items il:_ '(("Inspect" t "Inspect this object")))) - (inspect name))) - -(defmethod il:inspect/as/function ((x standard-method) stkp window) - (let* ((generic-function-name (slot-value (slot-value x 'generic-function) - 'name)) - (method-name (full-method-name x)) - (editor (il:select.fns.editor method-name))) - (il:allow.button.events) - (case editor - (ed (ed method-name '(:display methods))) - (il:inspectcode (il:inspectcode (slot-value x 'function))) - ((nil) nil) - (otherwise (funcall editor method-name))))) - -;; A replacement for the vanilla IL:INTERESTING-FRAME-P so we can see methods -;; and generic-functions on the stack. - -(defun interesting-frame-p (stack-pos &optional interp-flag) - ;; Return up to four values: INTERESTING-P LAST-FRAME-CONSUMED USE-FRAME and - ;; LABEL. See the function IL:COLLECT-BACKTRACE-ITEMS for a full description - ;; of how these values are used. - (labels - ((function-matches-frame-p (function frame) - "Is the function being called in this frame?" - (let* ((frame-name (il:stkname frame)) - (code-being-run (cond - ((typep frame-name 'il:closure) - frame-name) - ((and (consp frame-name) - (eq 'il:\\interpreter - (xcl::stack-frame-name - (il:\\stackargptr frame)))) - frame-name) - (t (xcl::stack-frame-fn-header - (il:\\stackargptr frame)))))) - (or (eq function code-being-run) - (and (typep function 'il:compiled-closure) - (eq (xcl::compiled-closure-fnheader function) - code-being-run))))) - (generic-function-from-frame (frame) - "If this the frame of a generic function return the gf, otherwise - return NIL." - ;; Generic functions are implemented as compiled closures. On the - ;; stack, we only see the fnheader for the the closure. This could - ;; be a discriminator code, or in the default method only case it - ;; will be the actual method function. To tell if this is a generic - ;; function frame, we have to check very carefully to see if the - ;; right stuff is on the stack. Specifically, the closure's ccode, - ;; and the first local variable has to be a ptrhunk big enough to be - ;; a FIN environment, and fin-env-fin of that ptrhunk has to point - ;; to a generic function whose ccode and environment match. - (let ((n-args (il:stknargs frame)) - (env nil) - (gf nil)) - (if (and ;; is there at least one local? - (> (il:stknargs frame t) n-args) - ;; and does the local contain something that might be - ;; the closure environment of a funcallable instance? - (setf env (il:stkarg (1+ n-args) frame)) - ;; and does the local contain something that might be - ;; the closure environment of a funcallable instance? - (typep env *fin-env-type*) - (setf gf (fin-env-fin env)) - ;; whose fin-env-fin points to a generic function? - (generic-function-p gf) - ;; whose environment is the same as env? - (eq (xcl::compiled-closure-env gf) env) - ;; and whose code is the same as the code for this - ;; frame? - (function-matches-frame-p gf frame)) - gf - nil)))) - (let ((frame-name (il:stkname stack-pos))) - ;; See if there is a generic-function on the stack at this - ;; location. - (let ((gf (generic-function-from-frame stack-pos))) - (when gf - (return-from interesting-frame-p (values t stack-pos stack-pos gf)))) - ;; See if this is an interpreted method. The method body is - ;; wrapped in a (BLOCK ...). We look for an - ;; interpreted call to BLOCK whose block-name is the name of - ;; generic-function. - (when (and (eq frame-name 'eval) - (consp (il:stkarg 1 stack-pos)) - (eq (first (il:stkarg 1 stack-pos)) 'block) - (symbolp (second (il:stkarg 1 stack-pos))) - (fboundp (second (il:stkarg 1 stack-pos))) - (generic-function-p - (symbol-function (second (il:stkarg 1 stack-pos))))) - (let* ((form (il:stkarg 1 stack-pos)) - (block-name (second form)) - (generic-function (symbol-function block-name)) - (methods (generic-function-methods (symbol-function block-name)))) - ;; If this is really a method being called from a - ;; generic-function, the g-f should be no more than a - ;; few(?) frames up the stack. Check for the method call - ;; by looking for a call to APPLY, where the function - ;; being applied is the code in one of the methods. - (do ((i 100 (1- i)) - (previous-pos stack-pos current-pos) - (current-pos (il:stknth -1 stack-pos) (il:stknth -1 current-pos)) - (found-method nil) - (method-pos)) - ((or (null current-pos) (<= i 0)) nil) - (cond ((equalp generic-function - (generic-function-from-frame current-pos)) - (if found-method - (return-from interesting-frame-p - (values t previous-pos method-pos found-method)) - (return))) - (found-method nil) - ((eq (il:stkname current-pos) 'apply) - (dolist (method methods) - (when (eq (method-function method) - (il:stkarg 1 current-pos)) - (setq method-pos current-pos) - (setq found-method method) - (return)))))))) - ;; Try to handle compiled methods - (when (and (symbolp frame-name) - (not (fboundp frame-name)) - (eq (il:chcon1 frame-name) - (il:charcode il:\()) - (or (string-equal "(method " (symbol-name frame-name) - :start2 0 :end2 13) - (string-equal "(method " (symbol-name frame-name) - :start2 0 :end2 12) - (string-equal "(method " (symbol-name frame-name) - :start2 0 :end2 8))) - ;; Looks like a name that CLOS consed up. See if there is a - ;; GF nearby up the stack. If there is, use it to help - ;; determine which method we have. - (do ((i 30 (1- i)) - (current-pos (il:stknth -1 stack-pos) - (il:stknth -1 current-pos)) - (gf)) - ((or (null current-pos) - (<= i 0)) - nil) - (setq gf (generic-function-from-frame current-pos)) - (when gf - (dolist (method (generic-function-methods gf)) - (when (function-matches-frame-p (method-function method) - stack-pos) - (return-from interesting-frame-p - (values t stack-pos stack-pos method)))) - (return)))) - ;; If we haven't already returned, use the default method. - (xcl::interesting-frame-p stack-pos interp-flag)))) - - -(setq il:*short-backtrace-filter* 'interesting-frame-p) - -;;; Support for undo - - (defun undoable-setf-slot-value (object slot-name new-value) - (if (slot-boundp object slot-name) - (il:undosave (list 'undoable-setf-slot-value - object slot-name (slot-value object slot-name))) - (il:undosave (list 'slot-makunbound object slot-name))) - (setf (slot-value object slot-name) new-value)) - - (setf (get 'slot-value :undoable-setf-inverse) 'undoable-setf-slot-value) - - -;;; Support for ?= and friends - -;; The arglists for generic-functions are built using gensyms, and don't reflect -;; any keywords (they are all included in an &REST arg). Rather then use the -;; arglist in the code, we use the one that CLOS kindly keeps in the generic-function. - -(xcl:advise-function 'il:smartarglist - '(if (and il:explainflg - (symbolp il:fn) - (fboundp il:fn) - (generic-function-p (symbol-function il:fn))) - (generic-function-pretty-arglist (symbol-function il:fn)) - (xcl:inner)) - :when :around :priority :last) - -(setf (get 'defclass 'il:argnames) - '(nil (class-name (#\{ superclass-name #\} #\*) - (#\{ slot-specifier #\} #\*) - #\{ slot-option #\} #\*))) - -(setf (get 'defmethod 'il:argnames) - '(nil (#\{ name #\| (setf name) #\} #\{ method-qualifier #\} #\* - specialized-lambda-list #\{ declaration #\| doc-string #\} #\* - #\{ form #\} #\*))) - -;;; Prettyprinting support, the result of Harley Davis. - -;; Support the standard Prettyprinter. This is really minimal right now. If -;; anybody wants to fix this, I'd be happy to include their code. In fact, -;; there is almost no support for Commonlisp in the standard Prettyprinter, so -;; the field is wide open to hackers with time on their hands. - - -(setf (get 'defmethod :definition-print-template) ;Not quite right, since it - '(:name :arglist :body)) ; doesn't handle qualifiers, - ; but it will have to do. - -(defun defclass-prettyprint (form) - (let ((left (il:dspxposition)) - (char-width (il:charwidth (il:charcode x) *standard-output*))) - (xcl:destructuring-bind (defclass name supers slots . options) form - (princ "(") - (prin1 defclass) - (princ " ") - (prin1 name) - (princ " ") - (if (null supers) - (princ "()") ;Print "()" instead of "nil" - (il:sequential.prettyprint (list supers) (il:dspxposition))) - (if (null slots) - (progn (il:prinendline (+ left (* 4 char-width)) *standard-output*) - (princ "()")) - (il:sequential.prettyprint (list slots) (+ left (* 4 char-width)))) - (when options - (il:sequential.prettyprint options (+ left (* 2 char-width)))) - (princ ")") - nil))) - -(let ((pprint-macro (assoc 'defclass il:prettyprintmacros))) - (if (null pprint-macro) - (push (cons 'defclass 'defclass-prettyprint) - il:prettyprintmacros) - (setf (cdr pprint-macro) 'defclass-prettyprint))) - -(defun binder-prettyprint (form) - ;; Prettyprints expressions like MULTIPLE-VALUE-BIND and WITH-SLOTS - ;; that are of the form (fn (var ...) form &rest body). - ;; This code is far from correct, but it's better than nothing. - (if (and (consp form) - (not (null (cdddr form)))) - ;; I have no idea what I'm doing here. Seems I can copy and edit somebody - ;; elses code without understanding it. - (let ((body-indent (+ (il:dspxposition) - (* 2 (il:charwidth (il:charcode x) - *standard-output*)))) - (form-indent (+ (il:dspxposition) - (* 4 (il:charwidth (il:charcode x) - *standard-output*))))) - (princ "(") - (prin1 (first form)) - (princ " ") - (il:superprint (second form) form nil *standard-output*) - (il:sequential.prettyprint (list (third form)) form-indent) - (il:sequential.prettyprint (cdddr form) body-indent) - (princ ")") - nil) ;Return NIL to indicate that we did - ; the printing - t)) ;Return true to use default printing - - -(dolist (fn '(multiple-value-bind with-accessors with-slots)) - (let ((pprint-macro (assoc fn 'il:prettyprintmacros))) - (if (null pprint-macro) - (push (cons fn 'binder-prettyprint) - il:prettyprintmacros) - (setf (cdr pprint-macro) 'binder-prettyprint)))) - - - -;; SEdit has its own prettyprinter, so we need to support that too. This is due -;; to Harley Davis. Really. - -(push (cons :slot-spec - '(((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) - break sedit::from-indent . 0) - (sedit::set-indent . 1) - (sedit::next-inline? 1 break sedit::from-indent . 1) - (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) - break sedit::from-indent . 0)) - ((sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) - break sedit::from-indent . 0) - (sedit::set-indent . 1) - (sedit::next-inline? 1 break sedit::from-indent . 1) - (sedit::prev-keyword? (sedit::next-inline? 1 break sedit::from-indent . 1) - break sedit::from-indent . 0)))) - sedit:*indent-alist*) - -(setf (sedit:get-format :slot-spec) - '(:indent :slot-spec :inline t)) - -(setf (sedit:get-format :slot-spec-list) - '(:indent :binding-list :args (:slot-spec) :inline nil)) - -(setf (sedit:get-format 'defclass) - '(:indent ((2) 1) - :args (:keyword nil nil :slot-spec-list nil) - :sublists (4))) - -(setf (sedit:get-format 'defmethod) - '(:indent ((2)) - :args (:keyword nil :lambda-list nil) - :sublists (3))) - -(setf (sedit:get-format 'defgeneric) 'defun) - -(setf (sedit:get-format 'generic-flet) 'flet) - -(setf (sedit:get-format 'generic-labels) 'flet) - -(setf (sedit:get-format 'call-next-method) - '(:indent (1) :args (:keyword nil))) - -(setf (sedit:get-format 'symbol-macrolet) 'let) - -(setf (sedit:get-format 'with-accessors) - '(:indent ((1) 1) - :args (:keyword :binding-list nil) - :sublists (2) - :miser :never)) - -(setf (sedit:get-format 'with-slots) 'with-accessors) - -(setf (sedit:get-format 'make-instance) - '(:indent ((1)) - :args (:keyword nil :slot-spec-list))) - -(setf (sedit:get-format '*make-instance) 'make-instance) - -;;; PrettyFileIndex stuff, the product of Harley Davis. - -(defvar *pfi-class-type* '(class defclass pfi-class-namer)) - -(defvar *pfi-method-type* '(method defmethod pfi-method-namer) - "Handles method for prettyfileindex") - -(defvar *pfi-index-accessors* nil - "t -> each slot accessor gets a listing in the index.") - -(defvar *pfi-method-index* :group - ":group, :separate, :both, or nil") - -(defun pfi-add-class-type () - (pushnew *pfi-class-type* il:*pfi-types*)) - -(defun pfi-add-method-type () - (pushnew *pfi-method-type* il:*pfi-types*)) - -(defun pfi-class-namer (expression entry) - (let ((class-name (second expression))) - ;; Following adds all slot readers/writers/accessors as separate entries in - ;; the index. Probably a mistake. - (if *pfi-index-accessors* - (let ((slot-list (fourth expression)) - (accessor-names nil)) - (labels ((add-accessor (method-index name-index) - (push (case *pfi-method-index* - (:group method-index) - (:separate name-index) - ((t :both) (list method-index name-index)) - ((nil) nil) - (otherwise (error "Illegal value for *pfi-method-index*: ~S" - *pfi-method-index*))) - accessor-names)) - (add-reader (reader-name) - (add-accessor `(method (,reader-name (,class-name))) - `(,reader-name (,class-name)))) - (add-writer (writer-name) - (add-accessor `(method ((setf ,writer-name) (t ,class-name))) - `((setf ,writer-name) (t ,class-name))))) - (dolist (slot-def slot-list) - (do* ((rest-slot-args (cdr slot-def) (cddr rest-slot-args)) - (slot-arg (first rest-slot-args) (first rest-slot-args))) - ((null rest-slot-args)) - (case slot-arg - (:reader (add-reader (second rest-slot-args))) - (:writer (add-writer (second rest-slot-args))) - (:accessor (add-reader (second rest-slot-args)) - (add-writer (second rest-slot-args))) - (otherwise nil)))) - (cons `(class (,class-name)) accessor-names))) - class-name))) - -(defun pfi-method-namer (expression entry) - (let ((method-name (second expression)) - (specializers nil) - (qualifiers nil) - lambda-list) - (do* ((rest-qualifiers (cddr expression) (cdr rest-qualifiers)) - (qualifier (first rest-qualifiers) (first rest-qualifiers))) - ((listp qualifier) (setq lambda-list qualifier) - (setq qualifiers (reverse qualifiers)) qualifiers) - (push qualifier qualifiers)) - (do* ((rest-lambda-list lambda-list (cdr rest-lambda-list)) - (arg (first rest-lambda-list) (first rest-lambda-list))) - ((or (member arg lambda-list-keywords) (null rest-lambda-list)) - (setq specializers (reverse specializers))) - (push (if (listp arg) (second arg) t) specializers)) - (let ((method-index `(method (,method-name ,@qualifiers ,specializers))) - (name-index `(,method-name ,@qualifiers ,specializers))) - (case *pfi-method-index* - (:group method-index) - (:separate name-index) - ((t :both) (list method-index name-index)) - ((nil) nil) - (otherwise (error "Illegal value for *pfi-method-index*: ~S" *pfi-method-index*)))))) - -(defun pfi-install-clos () - (pfi-add-method-type) - (pfi-add-class-type)) - -(eval-when (eval load) - (when (boundp (quote il:*pfi-types*)) - (pfi-install-clos)) - ) diff --git a/obsolete/clos/2.0/combin.lisp b/obsolete/clos/2.0/combin.lisp deleted file mode 100644 index f76ba815..00000000 --- a/obsolete/clos/2.0/combin.lisp +++ /dev/null @@ -1,254 +0,0 @@ -;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; - -(in-package 'clos) - -(defun make-effective-method-function (generic-function form) - (flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn)) - (if (and (listp form) - (eq (car form) 'call-method) - (method-p (cadr form)) - (every #'method-p (caddr form))) - ;; - ;; The effective method is just a call to call-method. This opens up - ;; the possibility of just using the method function of the method as - ;; as the effective method function. - ;; - ;; But we have to be careful. If that method function will ask for - ;; the next methods we have to provide them. We do not look to see - ;; if there are next methods, we look at whether the method function - ;; asks about them. If it does, we must tell it whether there are - ;; or aren't to prevent the leaky next methods bug. - ;; - (let* ((method-function (method-function (cadr form))) - (arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info))) - (if (not (method-function-needs-next-methods-p method-function)) - method-function - (let ((next-method-functions (mapcar #'method-function (caddr form)))) - (name-function - (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) - (let ((*next-methods* .next-method-functions.)) - ,(make-dfun-call metatypes applyp '.method-function.))) - #'default-test-converter ;This could be optimized by making - ;the interface from here to the - ;walker more clear so that the - ;form wouldn't get walked at all. - #'(lambda (form) - (if (memq form '(.next-method-functions. .method-function.)) - (values form (list form)) - form)) - #'(lambda (form) - (cond ((eq form '.next-method-functions.) - (list next-method-functions)) - ((eq form '.method-function.) - (list method-function))))))))) - ;; - ;; We have some sort of `real' effective method. Go off and get a - ;; compiled function for it. Most of the real hair here is done by - ;; the GET-FUNCTION mechanism. - ;; - (name-function (make-effective-method-function-internal generic-function form))))) - -(defvar *global-effective-method-gensyms* ()) -(defvar *rebound-effective-method-gensyms*) - -(defun get-effective-method-gensym () - (or (pop *rebound-effective-method-gensyms*) - (let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-"))) - (push new *global-effective-method-gensyms*) - new))) - -(eval-when (load) - (let ((*rebound-effective-method-gensyms* ())) - (dotimes (i 10) (get-effective-method-gensym)))) - -(defun make-effective-method-function-internal (generic-function effective-method) - (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) - (arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info))) - (labels ((test-converter (form) - (if (and (consp form) (eq (car form) 'call-method)) - '.call-method. - (default-test-converter form))) - (code-converter (form) - (if (and (consp form) (eq (car form) 'call-method)) - ;; - ;; We have a `call' to CALL-METHOD. There may or may not be next methods - ;; and the two cases are a little different. It controls how many gensyms - ;; we will generate. - ;; - (let ((gensyms - (if (cddr form) - (list (get-effective-method-gensym) - (get-effective-method-gensym)) - (list (get-effective-method-gensym) - ())))) - (values `(let ((*next-methods* ,(cadr gensyms))) - ,(make-dfun-call metatypes applyp (car gensyms))) - gensyms)) - (default-code-converter form))) - (constant-converter (form) - (if (and (consp form) (eq (car form) 'call-method)) - (if (cddr form) - (list (check-for-make-method (cadr form)) - (mapcar #'check-for-make-method (caddr form))) - (list (check-for-make-method (cadr form)) - ())) - (default-constant-converter form))) - (check-for-make-method (effective-method) - (cond ((method-p effective-method) - (method-function effective-method)) - ((and (listp effective-method) - (eq (car effective-method) 'make-method)) - (make-effective-method-function generic-function - (make-progn (cadr effective-method)))) - (t - (error "Effective-method form is malformed."))))) - (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method) - #'test-converter - #'code-converter - #'constant-converter)))) - - - -(defvar *invalid-method-error* - #'(lambda (&rest args) - (declare (ignore args)) - (error - "INVALID-METHOD-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) - -(defvar *method-combination-error* - #'(lambda (&rest args) - (declare (ignore args)) - (error - "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~ - of a method combination function (inside the body of~%~ - DEFINE-METHOD-COMBINATION or a method on the generic~%~ - function COMPUTE-EFFECTIVE-METHOD)."))) - -;(defmethod compute-effective-method :around ;issue with magic -; ((generic-function generic-function) ;generic functions -; (method-combination method-combination) -; applicable-methods) -; (declare (ignore applicable-methods)) -; (flet ((real-invalid-method-error (method format-string &rest args) -; (declare (ignore method)) -; (apply #'error format-string args)) -; (real-method-combination-error (format-string &rest args) -; (apply #'error format-string args))) -; (let ((*invalid-method-error* #'real-invalid-method-error) -; (*method-combination-error* #'real-method-combination-error)) -; (call-next-method)))) - -(defun invalid-method-error (&rest args) - (declare (arglist method format-string &rest format-arguments)) - (apply *invalid-method-error* args)) - -(defun method-combination-error (&rest args) - (declare (arglist format-string &rest format-arguments)) - (apply *method-combination-error* args)) - - - -;;; -;;; The STANDARD method combination type. This is coded by hand (rather than -;;; with define-method-combination) for bootstrapping and efficiency reasons. -;;; Note that the definition of the find-method-combination-method appears in -;;; the file defcombin.lisp, this is because EQL methods can't appear in the -;;; bootstrap. -;;; -;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION -;;; classes has to appear here for this reason. This code must conform to -;;; the code in the file defcombin, look there for more details. -;;; - -(defclass method-combination () ()) - -(define-gf-predicate method-combination-p method-combination) - -(defclass standard-method-combination - (definition-source-mixin method-combination) - ((type :reader method-combination-type - :initarg :type) - (documentation :reader method-combination-documentation - :initarg :documentation) - (options :reader method-combination-options - :initarg :options))) - -(defmethod print-object ((mc method-combination) stream) - (printing-random-thing (mc stream) - (format stream - "Method-Combination ~S ~S" - (method-combination-type mc) - (method-combination-options mc)))) - -(eval-when (load eval) - (setq *standard-method-combination* - (make-instance 'standard-method-combination - :type 'standard - :documentation "The standard method combination." - :options ()))) - -;This definition appears in defcombin.lisp. -; -;(defmethod find-method-combination ((generic-function generic-function) -; (type (eql 'standard)) -; options) -; (when options -; (method-combination-error -; "The method combination type STANDARD accepts no options.")) -; *standard-method-combination*) - -(defun make-call-methods (methods) - (mapcar #'(lambda (method) `(call-method ,method ())) methods)) - -(defmethod compute-effective-method ((generic-function generic-function) - (combin standard-method-combination) - applicable-methods) - (let ((before ()) - (primary ()) - (after ()) - (around ())) - (dolist (m applicable-methods) - (let ((qualifiers (method-qualifiers m))) - (cond ((member ':before qualifiers) (push m before)) - ((member ':after qualifiers) (push m after)) - ((member ':around qualifiers) (push m around)) - (t - (push m primary))))) - (setq before (reverse before) - after (reverse after) - primary (reverse primary) - around (reverse around)) - (cond ((null primary) - `(error "No primary method for the generic function ~S." ',generic-function)) - ((and (null before) (null after) (null around)) - ;; - ;; By returning a single call-method `form' here we enable an important - ;; implementation-specific optimization. - ;; - `(call-method ,(first primary) ,(rest primary))) - (t - (let ((main-effective-method - (if (or before after (rest primary)) - `(multiple-value-prog1 - (progn ,@(make-call-methods before) - (call-method ,(first primary) ,(rest primary))) - ,@(make-call-methods (reverse after))) - `(call-method ,(first primary) ())))) - (if around - `(call-method ,(first around) - (,@(rest around) (make-method ,main-effective-method))) - main-effective-method)))))) - diff --git a/obsolete/clos/2.0/compat.lisp b/obsolete/clos/2.0/compat.lisp deleted file mode 100644 index ca390f84..00000000 --- a/obsolete/clos/2.0/compat.lisp +++ /dev/null @@ -1,11 +0,0 @@ -;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp; -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; - -(in-package 'clos) - -() diff --git a/obsolete/clos/2.0/construct.lisp b/obsolete/clos/2.0/construct.lisp deleted file mode 100644 index 7d740475..00000000 --- a/obsolete/clos/2.0/construct.lisp +++ /dev/null @@ -1,1090 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; -;;; This file defines the defconstructor and other make-instance optimization -;;; mechanisms. -;;; - -(in-package 'clos) - -;;; -;;; defconstructor is used to define special purpose functions which just -;;; call make-instance with a symbol as the first argument. The semantics -;;; of defconstructor is that it is equivalent to defining a function which -;;; just calls make-instance. The purpose of defconstructor is to provide -;;; CLOS with a way of noticing these calls to make-instance so that it can -;;; optimize them. Specific ports of CLOS could just have their compiler -;;; spot these calls to make-instance and then call this code. Having the -;;; special defconstructor facility is the best we can do portably. -;;; -;;; -;;; A call to defconstructor like: -;;; -;;; (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r) -;;; -;;; Is equivalent to a defun like: -;;; -;;; (defun make-foo (a b &rest r) -;;; (make-instance 'foo 'a a ':mumble b 'baz r)) -;;; -;;; Calls like the following are also legal: -;;; -;;; (defconstructor make-foo foo ()) -;;; (defconstructor make-bar bar () :x *x* :y *y*) -;;; (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c)) -;;; -;;; -;;; The general idea of this implementation is that the expansion of the -;;; defconstructor form includes the creation of closure generators which -;;; can be called to create constructor code for the class. The ways that -;;; a constructor can be optimized depends not only on the defconstructor -;;; form, but also on the state of the class and the generic functions in -;;; the initialization protocol. Because of this, the determination of the -;;; form of constructor code to be used is a two part process. -;;; -;;; At compile time, make-constructor-code-generators looks at the actual -;;; defconstructor form and makes a list of appropriate constructor code -;;; generators. All that is really taken into account here is whether -;;; any initargs are supplied in the call to make-instance, and whether -;;; any of those are constant. -;;; -;;; At constructor code generation time (see note about lazy evaluation) -;;; compute-constructor-code calls each of the constructor code generators -;;; to try to get code for this constructor. Each generator looks at the -;;; state of the class and initialization protocol generic functions and -;;; decides whether its type of code is appropriate. This depends on things -;;; like whether there are any applicable methods on initialize-instance, -;;; whether class slots are affected by initialization etc. -;;; -;;; -;;; Constructor objects are funcallable instances, the protocol followed to -;;; to compute the constructor code for them is quite similar to the protocol -;;; followed to compute the discriminator code for a generic function. When -;;; the constructor is first loaded, we install as its code a function which -;;; will compute the actual constructor code the first time it is called. -;;; -;;; If there is an update to the class structure which might invalidate the -;;; optimized constructor, the special lazy constructor installer is put back -;;; so that it can compute the appropriate constructor when it is called. -;;; This is the same kind of lazy evaluation update strategy used elswhere -;;; in CLOS. -;;; -;;; To allow for flexibility in the CLOS implementation and to allow CLOS users -;;; to specialize this constructor facility for their own metaclasses, there -;;; is an internal protocol followed by the code which loads and installs -;;; the constructors. This is documented in the comments in the code. -;;; -;;; This code is also designed so that one of its levels, can be used to -;;; implement optimization of calls to make-instance which can't go through -;;; the defconstructor facility. This has not been implemented yet, but the -;;; hooks are there. -;;; -;;; - -(defmacro defconstructor - (name class lambda-list &rest initialization-arguments) - (expand-defconstructor class - name - lambda-list - (copy-list initialization-arguments))) - -(defun expand-defconstructor (class-name name lambda-list supplied-initargs) - (let ((class (find-class class-name nil)) - (supplied-initarg-names - (gathering1 (collecting) - (iterate ((name (*list-elements supplied-initargs :by #'cddr))) - (gather1 name))))) - (when (null class) - (error "defconstructor form being compiled (or evaluated) before~@ - class ~S is defined." - class-name)) - `(progn - ;; In order to avoid undefined function warnings, we want to tell - ;; the compile time environment that a function with this name and - ;; this argument list has been defined. The portable way to do this - ;; is with defun. - (proclaim '(notinline ,name)) - (defun ,name ,lambda-list - (declare (ignore ,@(specialized-lambda-list-parameters lambda-list))) - (error "Constructor ~S not loaded." ',name)) - - ,(make-top-level-form `(defconstructor ,name) - '(load eval) - `(load-constructor - ',class-name - ',(class-name (class-of class)) - ',name - ',supplied-initarg-names - ;; make-constructor-code-generators is called to return a list - ;; of constructor code generators. The actual interpretation - ;; of this list is left to compute-constructor-code, but the - ;; general idea is that it should be an plist where the keys - ;; name a kind of constructor code and the values are generator - ;; functions which return the actual constructor code. The - ;; constructor code is usually a closures over the arguments - ;; to the generator. - ,(make-constructor-code-generators class - name - lambda-list - supplied-initarg-names - supplied-initargs)))))) - -(defun load-constructor (class-name metaclass-name constructor-name - supplied-initarg-names code-generators) - (let ((class (find-class class-name nil))) - (cond ((null class) - (error "defconstructor form being loaded (or evaluated) before~@ - class ~S is defined." - class-name)) - ((neq (class-name (class-of class)) metaclass-name) - (error "When defconstructor ~S was compiled, the metaclass of the~@ - class ~S was ~S. The metaclass is now ~S.~@ - The constructor must be recompiled." - constructor-name - class-name - metaclass-name - (class-name (class-of class)))) - (t - (load-constructor-internal class - constructor-name - supplied-initarg-names - code-generators) - constructor-name)))) - -;;; -;;; The actual constructor objects. -;;; -(defclass constructor () - ((class ;The class with which this - :initarg :class ;constructor is associated. - :reader constructor-class) ;The actual class object, - ;not the class name. - ; - (name ;The name of this constructor. - :initform nil ;This is the symbol in whose - :initarg :name ;function cell the constructor - :reader constructor-name) ;usually sits. Of course, this - ;is optional. defconstructor - ;makes named constructors, but - ;it is possible to manipulate - ;anonymous constructors also. - ; - (code-type ;The type of code currently in - :initform nil ;use by this constructor. This - :accessor constructor-code-type) ;is mostly for debugging and - ;analysis purposes. - ;The lazy installer sets this - ;to LAZY. The most basic and - ;least optimized type of code - ;is called FALLBACK. - ; - (supplied-initarg-names ;The names of the initargs this - :initarg :supplied-initarg-names ;constructor supplies when it - :reader ;"calls" make-instance. - constructor-supplied-initarg-names) ; - ; - (code-generators ;Generators for the different - :initarg :code-generators ;types of code this constructor - :reader constructor-code-generators)) ;could use. - (:metaclass funcallable-standard-class)) - - -;;; -;;; Because the value in the code-type slot should always correspond to the -;;; funcallable-instance-function of the constructor, this function should -;;; always be used to set the both at the same time. -;;; -(defun set-constructor-code (constructor code type) - (set-funcallable-instance-function constructor code) - (set-function-name constructor (constructor-name constructor)) - (setf (constructor-code-type constructor) type)) - - -(defmethod print-object ((constructor constructor) stream) - (printing-random-thing (constructor stream) - (format stream - "~S ~S (~S)" - (or (class-name (class-of constructor)) "Constructor") - (or (constructor-name constructor) "Anonymous") - (constructor-code-type constructor)))) - -(defmethod describe-object ((constructor constructor) stream) - (format stream - "~S is a constructor for the class ~S.~%~ - The current code type is ~S.~%~ - Other possible code types are ~S." - constructor (constructor-class constructor) - (constructor-code-type constructor) - (gathering1 (collecting) - (doplist (key val) (constructor-code-generators constructor) - (gather1 key))))) - -;;; -;;; I am not in a hairy enough mood to make this implementation be metacircular -;;; enough that it can support a defconstructor for constructor objects. -;;; -(defun make-constructor (class name supplied-initarg-names code-generators) - (make-instance 'constructor - :class class - :name name - :supplied-initarg-names supplied-initarg-names - :code-generators code-generators)) - -; This definition actually appears in std-class.lisp. -;(defmethod class-constructors ((class std-class)) -; (with-slots (plist) class (getf plist 'constructors))) - -(defmethod add-constructor ((class std-class) - (constructor constructor)) - (with-slots (plist) class - (pushnew constructor (getf plist 'constructors)))) - -(defmethod remove-constructor ((class std-class) - (constructor constructor)) - (with-slots (plist) class - (setf (getf plist 'constructors) - (delete constructor (getf plist 'constructors))))) - -(defmethod get-constructor ((class std-class) name &optional (error-p t)) - (or (dolist (c (class-constructors class)) - (when (eq (constructor-name c) name) (return c))) - (if error-p - (error "Couldn't find a constructor with name ~S for class ~S." - name class) - ()))) - -;;; -;;; This is called to actually load a defconstructor constructor. It must -;;; install the lazy installer in the function cell of the constructor name, -;;; and also add this constructor to the list of constructors the class has. -;;; -(defmethod load-constructor-internal - ((class std-class) name initargs generators) - (let ((constructor (make-constructor class name initargs generators)) - (old (get-constructor class name nil))) - (when old (remove-constructor class old)) - (install-lazy-constructor-installer constructor) - (add-constructor class constructor) - (setf (symbol-function name) constructor))) - -(defmethod install-lazy-constructor-installer ((constructor constructor)) - (let ((class (constructor-class constructor))) - (set-constructor-code constructor - #'(lambda (&rest args) - (multiple-value-bind (code type) - (compute-constructor-code class constructor) - (prog1 (apply code args) - (set-constructor-code constructor - code - type)))) - 'lazy))) - -;;; -;;; The interface to keeping the constructors updated. -;;; -;;; add-method and remove-method (for standard-generic-function and -method), -;;; promise to call maybe-update-constructors on the generic function and -;;; the method. -;;; -;;; The class update code promises to call update-constructors whenever the -;;; class is changed. That is, whenever the supers, slots or options change. -;;; If user defined classes of constructor needs to be updated in more than -;;; these circumstances, they should use the dependent updating mechanism to -;;; make sure update-constructors is called. -;;; -;;; Bootstrapping concerns force the definitions of maybe-update-constructors -;;; and update-constructors to be in the file std-class. For clarity, they -;;; also appear below. Be sure to keep the definition here and there in sync. -;;; -;(defvar *initialization-generic-functions* -; (list #'make-instance -; #'default-initargs -; #'allocate-instance -; #'initialize-instance -; #'shared-initialize)) -; -;(defmethod maybe-update-constructors -; ((generic-function generic-function) -; (method method)) -; (when (memq generic-function *initialization-generic-functions*) -; (labels ((recurse (class) -; (update-constructors class) -; (dolist (subclass (class-direct-subclasses class)) -; (recurse subclass)))) -; (when (classp (car (method-specializers method))) -; (recurse (car (method-specializers method))))))) -; -;(defmethod update-constructors ((class std-class)) -; (dolist (cons (class-constructors class)) -; (install-lazy-constructor-installer cons))) -; -;(defmethod update-constructors ((class class)) -; ()) - - - -;;; -;;; Here is the actual smarts for making the code generators and then trying -;;; each generator to get constructor code. This extensible mechanism allows -;;; new kinds of constructor code types to be added. A programmer defining a -;;; specialization of the constructor class can either use this mechanism to -;;; define new code types, or can override this mechanism by overriding the -;;; methods on make-constructor-code-generators and compute-constructor-code. -;;; -;;; The function defined by define-constructor-code-type will receive the -;;; class object, and the 4 original arguments to defconstructor. It can -;;; return a constructor code generator, or return nil if this type of code -;;; is determined to not be appropriate after looking at the defconstructor -;;; arguments. -;;; -;;; When compute-constructor-code is called, it first performs basic checks -;;; to make sure that the basic assumptions common to all the code types are -;;; valid. (For details see method definition). If any of the tests fail, -;;; the fallback constructor code type is used. If none of the tests fail, -;;; the constructor code generators are called in order. They receive 5 -;;; arguments: -;;; -;;; CLASS the class the constructor is making instances of -;;; WRAPPER that class's wrapper -;;; DEFAULTS the result of calling class-default-initargs on class -;;; INITIALIZE the applicable methods on initialize-instance -;;; SHARED the applicable methosd on shared-initialize -;;; -;;; The first code generator to return code is used. The code generators are -;;; called in reverse order of definition, so define-constructor-code-type -;;; forms which define better code should appear after ones that define less -;;; good code. The fallback code type appears first. Note that redefining a -;;; code type does not change its position in the list. To do that, define -;;; a new type at the end with the behavior. -;;; - -(defvar *constructor-code-types* ()) - -(defmacro define-constructor-code-type (type arglist &body body) - (let ((fn-name (intern (format nil - "CONSTRUCTOR-CODE-GENERATOR ~A ~A" - (package-name (symbol-package type)) - (symbol-name type)) - *the-clos-package*))) - `(progn - (defun ,fn-name ,arglist .,body) - (load-define-constructor-code-type ',type ',fn-name)))) - -(defun load-define-constructor-code-type (type generator) - (let ((old-entry (assq type *constructor-code-types*))) - (if old-entry - (setf (cadr old-entry) generator) - (push (list type generator) *constructor-code-types*)) - type)) - -(defmethod make-constructor-code-generators - ((class std-class) - name lambda-list supplied-initarg-names supplied-initargs) - (cons 'list - (gathering1 (collecting) - (dolist (entry *constructor-code-types*) - (let ((generator - (funcall (cadr entry) class name lambda-list - supplied-initarg-names - supplied-initargs))) - (when generator - (gather1 `',(car entry)) - (gather1 generator))))))) - -(defmethod compute-constructor-code ((class std-class) - (constructor constructor)) - (let* ((proto (class-prototype class)) - (wrapper (class-wrapper class)) - (defaults (class-default-initargs class)) - (make - (compute-applicable-methods #'make-instance (list class))) - (supplied-initarg-names - (constructor-supplied-initarg-names constructor)) - (default - (compute-applicable-methods #'default-initargs - (list class supplied-initarg-names))) ;? - (allocate - (compute-applicable-methods #'allocate-instance (list class))) - (initialize - (compute-applicable-methods #'initialize-instance (list proto))) - (shared - (compute-applicable-methods #'shared-initialize (list proto t))) - (code-generators - (constructor-code-generators constructor)) - (code-generators - (constructor-code-generators constructor))) - (flet ((call-code-generator (generator) - (when (null generator) - (unless (setq generator (getf code-generators 'fallback)) - (error "No FALLBACK generator?"))) - (funcall generator class wrapper defaults initialize shared))) - (if (or (cdr make) - (cdr default) - (cdr allocate) - (check-initargs class - supplied-initarg-names - defaults - (append initialize shared))) - ;; These are basic shared assumptions, if one of the - ;; has been violated, we have to resort to the fallback - ;; case. Any of these assumptions could be moved out - ;; of here and into the individual code types if there - ;; was a need to do so. - (values (call-code-generator nil) 'fallback) - ;; Otherwise try all the generators until one produces - ;; code for us. - (doplist (type generator) code-generators - (let ((code (call-code-generator generator))) - (when code (return (values code type))))))))) - -;;; -;;; The facilities are useful for debugging, and to measure the performance -;;; boost from constructors. -;;; - -(defun map-constructors (fn) - (let ((nclasses 0) - (nconstructors 0)) - (labels ((recurse (class) - (incf nclasses) - (dolist (constructor (class-constructors class)) - (incf nconstructors) - (funcall fn constructor)) - (dolist (subclass (class-direct-subclasses class)) - (recurse subclass)))) - (recurse (find-class 't)) - (values nclasses nconstructors)))) - -(defun reset-constructors () - (multiple-value-bind (nclass ncons) - (map-constructors #'install-lazy-constructor-installer ) - (format t "~&~D classes, ~D constructors." nclass ncons))) - -(defun disable-constructors () - (multiple-value-bind (nclass ncons) - (map-constructors - #'(lambda (c) - (let ((gen (getf (constructor-code-generators c) 'fallback))) - (if (null gen) - (error "No fallback constructor for ~S." c) - (set-constructor-code c - (funcall gen - (constructor-class c) - () () () ()) - 'fallback))))) - (format t "~&~D classes, ~D constructors." nclass ncons))) - -(defun enable-constructors () - (reset-constructors)) - - -;;; -;;; Helper functions and utilities that are shared by all of the code types -;;; and by the main compute-constructor-code method as well. -;;; - -(defvar *standard-initialize-instance-method* - (get-method #'initialize-instance - () - (list *the-class-standard-object*))) - -(defvar *standard-shared-initialize-method* - (get-method #'shared-initialize - () - (list *the-class-standard-object* *the-class-t*))) - -(defun non-clos-initialize-instance-methods-p (methods) - (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*)) - methods)) - -(defun non-clos-shared-initialize-methods-p (methods) - (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*)) - methods)) - -(defun non-clos-or-after-initialize-instance-methods-p (methods) - (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*) - (equal '(:after) (method-qualifiers m)))) - methods)) - -(defun non-clos-or-after-shared-initialize-methods-p (methods) - (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*) - (equal '(:after) (method-qualifiers m)))) - methods)) - - -;;; -;;; if initargs are valid return nil, otherwise return t. -;;; -(defun check-initargs (class supplied-initarg-names defaults methods) - (let ((legal (apply #'append - (mapcar #'slotd-initargs (class-slots class))))) - ;; Add to the set of slot-filling initargs the set of - ;; initargs that are accepted by the methods. If at - ;; any point we come across &allow-other-keys, we can - ;; just quit. - (dolist (method methods) - (multiple-value-bind (keys allow-other-keys) - (function-keywords method) - (when allow-other-keys - (return-from check-initargs nil)) - (setq legal (append keys legal)))) - ;; Now check the supplied-initarg-names and the default initargs - ;; against the total set that we know are legal. - (dolist (key supplied-initarg-names) - (unless (memq key legal) - (return-from check-initargs t))) - (dolist (default defaults) - (unless (memq (car default) legal) - (return-from check-initargs t))))) - - -;;; -;;; This returns two values. The first is a vector which can be used as the -;;; initial value of the slots vector for the instance. The first is a symbol -;;; describing the initforms this class has. -;;; -;;; If the first value is: -;;; -;;; :unsupplied no slot has an initform -;;; :constants all slots have either a constant initform -;;; or no initform at all -;;; t there is at least one non-constant initform -;;; -(defun compute-constant-vector (class) - (declare (values constants flag)) - (let* ((wrapper (class-wrapper class)) - (layout (wrapper-instance-slots-layout wrapper)) - (flag :unsupplied) - (constants ())) - (dolist (slotd (class-slots class)) - (let ((name (slotd-name slotd)) - (initform (slotd-initform slotd)) - (initfn (slotd-initfunction slotd))) - (cond ((null (memq name layout))) - ((or (eq initform *slotd-unsupplied*) - (null initfn)) - (push (cons name *slot-unbound*) constants)) - ((constantp initform) - (push (cons name (eval initform)) constants) - (when (eq flag ':unsupplied) (setq flag ':constants))) - (t - (push (cons name *slot-unbound*) constants) - (setq flag 't))))) - (values - (apply #'vector - (mapcar #'cdr - (sort constants #'(lambda (x y) - (memq (car y) - (memq (car x) layout)))))) - flag))) - -(defmacro copy-constant-vector (constants) - `(copy-seq (the simple-vector ,constants))) - - -;;; -;;; This takes a class and a list of initarg-names, and returns an alist -;;; indicating the positions of the slots those initargs may fill. The -;;; order of the initarg-names argument is important of course, since we -;;; have to respect the rules about the leftmost initarg that fills a slot -;;; having precedence. This function allows initarg names to appear twice -;;; in the list, it only considers the first appearance. -;;; -(defun compute-initarg-positions (class initarg-names) - (let* ((layout (wrapper-instance-slots-layout (class-wrapper class))) - (positions - (gathering1 (collecting) - (iterate ((slot-name (list-elements layout)) - (position (interval :from 0))) - (gather1 (cons slot-name position))))) - (slot-initargs - (mapcar #'(lambda (slotd) - (list (slotd-initargs slotd) - (or (cdr (assq (slotd-name slotd) positions)) - ':class))) - (class-slots class)))) - ;; Go through each of the initargs, and figure out what position - ;; it fills by replacing the entries in slot-initargs it fills. - (dolist (initarg initarg-names) - (dolist (slot-entry slot-initargs) - (let ((slot-initargs (car slot-entry))) - (when (and (listp slot-initargs) - (not (null slot-initargs)) - (memq initarg slot-initargs)) - (setf (car slot-entry) initarg))))) - (gathering1 (collecting) - (dolist (initarg initarg-names) - (let ((positions (gathering1 (collecting) - (dolist (slot-entry slot-initargs) - (when (eq (car slot-entry) initarg) - (gather1 (cadr slot-entry))))))) - (when positions - (gather1 (cons initarg positions)))))))) - - -;;; -;;; The FALLBACK case allows anything. This always works, and always appears -;;; as the last of the generators for a constructor. It does a full call to -;;; make-instance. -;;; - -(define-constructor-code-type fallback - (class name arglist supplied-initarg-names supplied-initargs) - (declare (ignore name supplied-initarg-names)) - `(function - (lambda (&rest ignore) - (declare (ignore ignore)) - (function - (lambda ,arglist - (make-instance - ',(class-name class) - ,@(gathering1 (collecting) - (iterate ((tail (*list-tails supplied-initargs :by #'cddr))) - (gather1 `',(car tail)) - (gather1 (cadr tail)))))))))) - -;;; -;;; The GENERAL case allows: -;;; constant, unsupplied or non-constant initforms -;;; constant or non-constant default initargs -;;; supplied initargs -;;; slot-filling initargs -;;; :after methods on shared-initialize and initialize-instance -;;; -(define-constructor-code-type general - (class name arglist supplied-initarg-names supplied-initargs) - (declare (ignore name)) - (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class)) - (wrapper-fetcher (wrapper-fetcher class))) - `(function - (lambda (class .wrapper. defaults init shared) - (multiple-value-bind (.constants. - .constant-initargs. - .initfns-initargs-and-positions. - .supplied-initarg-positions. - .shared-initfns. - .initfns.) - (general-generator-internal class - defaults - init - shared - ',supplied-initarg-names - ',supplied-initargs) - .supplied-initarg-positions. - (when (and .constants. - (null (non-clos-or-after-initialize-instance-methods-p - init)) - (null (non-clos-or-after-shared-initialize-methods-p - shared))) - (function - (lambda ,arglist - (declare (optimize (speed 3) (safety 0))) - (let ((.instance. (,raw-allocator)) - (.slots. (copy-constant-vector .constants.)) - (.positions. .supplied-initarg-positions.) - (.initargs. .constant-initargs.)) - .positions. - - (setf (,slots-fetcher .instance.) .slots.) - (setf (,wrapper-fetcher .instance.) .wrapper.) - - (dolist (entry .initfns-initargs-and-positions.) - (let ((val (funcall (car entry))) - (initarg (cadr entry))) - (when initarg - (push val .initargs.) - (push initarg .initargs.)) - (dolist (pos (cddr entry)) - (setf (%svref .slots. pos) val)))) - - ,@(gathering1 (collecting) - (doplist (initarg value) supplied-initargs - (unless (constantp value) - (gather1 `(let ((.value. ,value)) - (push .value. .initargs.) - (push ',initarg .initargs.) - (dolist (.p. (pop .positions.)) - (setf (%svref .slots. .p.) - .value.))))))) - - (dolist (fn .shared-initfns.) - (apply fn .instance. t .initargs.)) - (dolist (fn .initfns.) - (apply fn .instance. .initargs.)) - - .instance.))))))))) - -(defun general-generator-internal - (class defaults init shared supplied-initarg-names supplied-initargs) - (flet ((bail-out () (return-from general-generator-internal nil))) - (let* ((constants (compute-constant-vector class)) - (layout (wrapper-instance-slots-layout (class-wrapper class))) - (initarg-positions - (compute-initarg-positions class - (append supplied-initarg-names - (mapcar #'car defaults)))) - (initfns-initargs-and-positions ()) - (supplied-initarg-positions ()) - (constant-initargs ()) - (used-positions ())) - - ;; - ;; Go through each of the supplied initargs for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If its a constant form, fill the constant vector. - ;; - Otherwise remember the positions no two initargs - ;; will try to fill the same position, since compute - ;; initarg positions already took care of that, but - ;; we do need to know what initforms will and won't - ;; be needed. - ;; - (doplist (initarg val) supplied-initargs - (let ((positions (cdr (assq initarg initarg-positions)))) - (cond ((memq :class positions) (bail-out)) - ((constantp val) - (setq val (eval val)) - (push val constant-initargs) - (push initarg constant-initargs) - (dolist (pos positions) (setf (svref constants pos) val))) - (t - (push positions supplied-initarg-positions))) - (setq used-positions (append positions used-positions)))) - ;; - ;; Go through each of the default initargs, for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If it is a constant, and it does fill a slot, put that - ;; into the constant vector. - ;; - If it isn't a constant, record its initfn and position. - ;; - (dolist (default defaults) - (let* ((name (car default)) - (initfn (cadr default)) - (form (caddr default)) - (value ()) - (positions (cdr (assq name initarg-positions)))) - (unless (memq name supplied-initarg-names) - (cond ((memq :class positions) (bail-out)) - ((constantp form) - (setq value (eval form)) - (push value constant-initargs) - (push name constant-initargs) - (dolist (pos positions) - (setf (svref constants pos) value))) - (t - (push (list* initfn name positions) - initfns-initargs-and-positions))) - (setq used-positions (append positions used-positions))))) - ;; - ;; Go through each of the slot initforms: - ;; - ;; - If its position has already been filled, do nothing. - ;; The initfn won't need to be called, and the slot won't - ;; need to be touched. - ;; - If it is a class slot, and has an initform, bail out. - ;; - If its a constant or unsupplied, ignore it, it is - ;; already in the constant vector. - ;; - Otherwise, record its initfn and position - ;; - (dolist (slotd (class-slots class)) - (let* ((alloc (slotd-allocation slotd)) - (name (slotd-name slotd)) - (form (slotd-initform slotd)) - (initfn (slotd-initfunction slotd)) - (position (position name layout))) - (cond ((neq alloc :instance) - (unless (or (eq form *slotd-unsupplied*) - (null initfn)) - (bail-out))) - ((member position used-positions)) - ((or (constantp form) - (eq form *slotd-unsupplied*))) - (t - (push (list initfn nil position) - initfns-initargs-and-positions))))) - - (values constants - constant-initargs - (nreverse initfns-initargs-and-positions) - (nreverse supplied-initarg-positions) - (mapcar #'method-function - (remove *standard-shared-initialize-method* shared)) - (mapcar #'method-function - (remove *standard-initialize-instance-method* init)))))) - - -;;; -;;; The NO-METHODS case allows: -;;; constant, unsupplied or non-constant initforms -;;; constant or non-constant default initargs -;;; supplied initargs that are arguments to constructor, or constants -;;; slot-filling initargs -;;; - -(define-constructor-code-type no-methods - (class name arglist supplied-initarg-names supplied-initargs) - (declare (ignore name)) - (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class)) - (wrapper-fetcher (wrapper-fetcher class))) - `(function - (lambda (class .wrapper. defaults init shared) - (multiple-value-bind (.constants. - .initfns-and-positions. - .supplied-initarg-positions.) - (no-methods-generator-internal class - defaults - ',supplied-initarg-names - ',supplied-initargs) - .initfns-and-positions. - .supplied-initarg-positions. - (when (and .constants. - (null (non-clos-initialize-instance-methods-p init)) - (null (non-clos-shared-initialize-methods-p shared))) - #'(lambda ,arglist - (declare (optimize (speed 3) (safety 0))) - (let ((.instance. (,raw-allocator)) - (.slots. (copy-constant-vector .constants.)) - (.positions. .supplied-initarg-positions.)) - .positions. - (setf (,slots-fetcher .instance.) .slots.) - (setf (,wrapper-fetcher .instance.) .wrapper.) - - (dolist (entry .initfns-and-positions.) - (let ((val (funcall (car entry)))) - (dolist (pos (cdr entry)) - (setf (%svref .slots. pos) val)))) - - ,@(gathering1 (collecting) - (doplist (initarg value) supplied-initargs - (unless (constantp value) - (gather1 - `(let ((.value. ,value)) - (dolist (.p. (pop .positions.)) - (setf (%svref .slots. .p.) .value.))))))) - - .instance.)))))))) - -(defun no-methods-generator-internal - (class defaults supplied-initarg-names supplied-initargs) - (flet ((bail-out () (return-from no-methods-generator-internal nil))) - (let* ((constants (compute-constant-vector class)) - (layout (wrapper-instance-slots-layout (class-wrapper class))) - (initarg-positions - (compute-initarg-positions class - (append supplied-initarg-names - (mapcar #'car defaults)))) - (initfns-and-positions ()) - (supplied-initarg-positions ()) - (used-positions ())) - ;; - ;; Go through each of the supplied initargs for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If its a constant form, fill the constant vector. - ;; - Otherwise remember the positions, no two initargs - ;; will try to fill the same position, since compute - ;; initarg positions already took care of that, but - ;; we do need to know what initforms will and won't - ;; be needed. - ;; - (doplist (initarg val) supplied-initargs - (let ((positions (cdr (assq initarg initarg-positions)))) - (cond ((memq :class positions) (bail-out)) - ((constantp val) - (setq val (eval val)) - (dolist (pos positions) - (setf (svref constants pos) val))) - (t - (push positions supplied-initarg-positions))) - (setq used-positions (append positions used-positions)))) - ;; - ;; Go through each of the default initargs, for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If it is a constant, and it does fill a slot, put that - ;; into the constant vector. - ;; - If it isn't a constant, record its initfn and position. - ;; - (dolist (default defaults) - (let* ((name (car default)) - (initfn (cadr default)) - (form (caddr default)) - (value ()) - (positions (cdr (assq name initarg-positions)))) - (unless (memq name supplied-initarg-names) - (cond ((memq :class positions) (bail-out)) - ((constantp form) - (setq value (eval form)) - (dolist (pos positions) - (setf (svref constants pos) value))) - (t - (push (cons initfn positions) - initfns-and-positions))) - (setq used-positions (append positions used-positions))))) - ;; - ;; Go through each of the slot initforms: - ;; - ;; - If its position has already been filled, do nothing. - ;; The initfn won't need to be called, and the slot won't - ;; need to be touched. - ;; - If it is a class slot, and has an initform, bail out. - ;; - If its a constant or unsupplied, do nothing, we know - ;; that it is already in the constant vector. - ;; - Otherwise, record its initfn and position - ;; - (dolist (slotd (class-slots class)) - (let* ((alloc (slotd-allocation slotd)) - (name (slotd-name slotd)) - (form (slotd-initform slotd)) - (initfn (slotd-initfunction slotd)) - (position (position name layout))) - (cond ((neq alloc :instance) - (unless (or (eq form *slotd-unsupplied*) - (null initfn)) - (bail-out))) - ((member position used-positions)) - ((or (constantp form) - (eq form *slotd-unsupplied*))) - (t - (push (list initfn position) initfns-and-positions))))) - - (values constants - (nreverse initfns-and-positions) - (nreverse supplied-initarg-positions))))) - - -;;; -;;; The SIMPLE-SLOTS case allows: -;;; constant or unsupplied initforms -;;; constant default initargs -;;; supplied initargs -;;; slot filling initargs -;;; - -(define-constructor-code-type simple-slots - (class name arglist supplied-initarg-names supplied-initargs) - (declare (ignore name)) - (let ((raw-allocator (raw-instance-allocator class)) - (slots-fetcher (slots-fetcher class)) - (wrapper-fetcher (wrapper-fetcher class))) - `(function - (lambda (class .wrapper. defaults init shared) - (when (and (null (non-clos-initialize-instance-methods-p init)) - (null (non-clos-shared-initialize-methods-p shared))) - (multiple-value-bind (.constants. .supplied-initarg-positions.) - (simple-slots-generator-internal class - defaults - ',supplied-initarg-names - ',supplied-initargs) - (when .constants. - (function - (lambda ,arglist - (declare (optimize (speed 3) (safety 0))) - (let ((.instance. (,raw-allocator)) - (.slots. (copy-constant-vector .constants.)) - (.positions. .supplied-initarg-positions.)) - - .positions. - (setf (,slots-fetcher .instance.) .slots.) - (setf (,wrapper-fetcher .instance.) .wrapper.) - - ,@(gathering1 (collecting) - (doplist (initarg value) supplied-initargs - (unless (constantp value) - (gather1 - `(let ((.value. ,value)) - (dolist (.p. (pop .positions.)) - (setf (%svref .slots. .p.) .value.))))))) - - .instance.)))))))))) - -(defun simple-slots-generator-internal - (class defaults supplied-initarg-names supplied-initargs) - (flet ((bail-out () (return-from simple-slots-generator-internal nil))) - (let* ((constants (compute-constant-vector class)) - (layout (wrapper-instance-slots-layout (class-wrapper class))) - (initarg-positions - (compute-initarg-positions class - (append supplied-initarg-names - (mapcar #'car defaults)))) - (supplied-initarg-positions ()) - (used-positions ())) - ;; - ;; Go through each of the supplied initargs for three reasons. - ;; - ;; - If it fills a class slot, bail out. - ;; - If its a constant form, fill the constant vector. - ;; - Otherwise remember the positions, no two initargs - ;; will try to fill the same position, since compute - ;; initarg positions already took care of that, but - ;; we do need to know what initforms will and won't - ;; be needed. - ;; - (doplist (initarg val) supplied-initargs - (let ((positions (cdr (assq initarg initarg-positions)))) - (cond ((memq :class positions) (bail-out)) - ((constantp val) - (setq val (eval val)) - (dolist (pos positions) - (setf (svref constants pos) val))) - (t - (push positions supplied-initarg-positions))) - (setq used-positions (append used-positions positions)))) - ;; - ;; Go through each of the default initargs for three reasons. - ;; - ;; - If it isn't a constant form, bail out. - ;; - If it fills a class slot, bail out. - ;; - If it is a constant, and it does fill a slot, put that - ;; into the constant vector. - ;; - (dolist (default defaults) - (let* ((name (car default)) - (form (caddr default)) - (value ()) - (positions (cdr (assq name initarg-positions)))) - (unless (memq name supplied-initarg-names) - (cond ((memq :class positions) (bail-out)) - ((not (constantp form)) - (bail-out)) - (t - (setq value (eval form)) - (dolist (pos positions) - (setf (svref constants pos) value))))))) - ;; - ;; Go through each of the slot initforms: - ;; - ;; - If its position has already been filled, do nothing. - ;; The initfn won't need to be called, and the slot won't - ;; need to be touched, we are OK. - ;; - If it has a non-constant initform, bail-out. This - ;; case doesn't handle those. - ;; - If it has a constant or unsupplied initform we don't - ;; really need to do anything, the value is in the - ;; constants vector. - ;; - (dolist (slotd (class-slots class)) - (let* ((alloc (slotd-allocation slotd)) - (name (slotd-name slotd)) - (form (slotd-initform slotd)) - (initfn (slotd-initfunction slotd)) - (position (position name layout))) - (cond ((neq alloc :instance) - (unless (or (eq form *slotd-unsupplied*) - (null initfn)) - (bail-out))) - ((member position used-positions)) - ((or (constantp form) - (eq form *slotd-unsupplied*))) - (t - (bail-out))))) - - (values constants (nreverse supplied-initarg-positions))))) diff --git a/obsolete/clos/2.0/cpl.lisp b/obsolete/clos/2.0/cpl.lisp deleted file mode 100644 index 9eda3018..00000000 --- a/obsolete/clos/2.0/cpl.lisp +++ /dev/null @@ -1,271 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- -;;;. Copyright (c) 1991 by Venue - - -(in-package "CLOS") - - -;;; compute-class-precedence-list Knuth section 2.2.3 has some interesting notes on this. What -;;; appears here is basically the algorithm presented there. The key idea is that we use -;;; class-precedence-description (CPD) structures to store the precedence information as we proceed. -;;; The CPD structure for a class stores two critical pieces of information: - a count of the number -;;; of "reasons" why the class can't go into the class precedence list yet. - a list of the -;;; "reasons" this class prevents others from going in until after it - - - -;; - - - -;;; A "reason" is essentially a single local precedence constraint. If a constraint between two -;;; classes arises more than once it generates more than one reason. This makes things simpler, -;;; linear, and isn't a problem as long as we make sure to keep track of each instance of a -;;; "reason". This code is divided into three phases. - the first phase simply generates the CPD's -;;; for each of the class and its superclasses. The remainder of the code will manipulate these -;;; CPDs rather than the class objects themselves. At the end of this pass, the CPD-SUPERS field of -;;; a CPD is a list of the CPDs of the direct superclasses of the class. - the second phase folds -;;; all the local constraints into the CPD structure. The CPD-COUNT of each CPD is built up, and -;;; the CPD-AFTER fields are augmented to include precedence constraints from the CPD-SUPERS field -;;; and from the order of classes in other CPD-SUPERS fields. After this phase, the CPD-AFTER field -;;; of a class includes all the direct superclasses of the class plus any class that immediately -;;; follows the class in the direct superclasses of another. There can be duplicates in this list. -;;; The CPD-COUNT field is equal to the number of times this class appears in the CPD-AFTER field of -;;; all the other CPDs. - In the third phase, classes are put into the precedence list one at a -;;; time, with only those classes with a CPD-COUNT of 0 being candidates for insertion. When a -;;; class is inserted , every CPD in its CPD-AFTER field has its count decremented. In the usual -;;; case, there is only one candidate for insertion at any point. If there is more than one, the -;;; specified tiebreaker rule is used to choose among them. - - -(defmethod compute-class-precedence-list ((root std-class) - direct-superclasses) - (compute-std-cpl root direct-superclasses)) - -(defstruct (class-precedence-description (:conc-name nil) - (:print-function (lambda (obj str depth) - (declare (ignore depth)) - (format str "#" (class-name (cpd-class obj)) - (cpd-count obj)))) - (:constructor make-cpd nil)) - (cpd-class nil) - (cpd-supers nil) - (cpd-after nil) - (cpd-count 0)) - -(defun compute-std-cpl (class supers) - (cond ((null supers) - ; First two branches of COND - (list class)) - ; are implementing the single - ((null (cdr supers)) - ; inheritance optimization. - (cons class (compute-std-cpl (car supers) - (class-direct-superclasses (car supers))))) - (t (multiple-value-bind (all-cpds nclasses) - (compute-std-cpl-phase-1 class supers) - (compute-std-cpl-phase-2 all-cpds) - (compute-std-cpl-phase-3 class all-cpds nclasses))))) - -(defvar *compute-std-cpl-class->entry-table-size* 60) - -(defun compute-std-cpl-phase-1 (class supers) - (let ((nclasses 0) - (all-cpds nil) - (table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test - #'eq))) - (labels ((get-cpd (c) - (or (gethash c table) - (setf (gethash c table) - (make-cpd)))) - (walk (c supers) - (if (forward-referenced-class-p c) - (cpl-forward-referenced-class-error class c) - (let ((cpd (get-cpd c))) - (unless (cpd-class cpd) - ; If we have already done this class - ; before, we can quit. - (setf (cpd-class cpd) - c) - (incf nclasses) - (push cpd all-cpds) - (setf (cpd-supers cpd) - (mapcar #'get-cpd supers)) - (dolist (super supers) - (walk super (class-direct-superclasses super)))))))) - (walk class supers) - (values all-cpds nclasses)))) - -(defun compute-std-cpl-phase-2 (all-cpds) - (dolist (cpd all-cpds) - (let ((supers (cpd-supers cpd))) - (when supers - (setf (cpd-after cpd) - (nconc (cpd-after cpd) - supers)) - (incf (cpd-count (car supers)) - 1) - (do* ((t1 supers t2) - (t2 (cdr t1) - (cdr t1))) - ((null t2)) - (incf (cpd-count (car t2)) - 2) - (push (car t2) - (cpd-after (car t1)))))))) - -(defun - compute-std-cpl-phase-3 - (class all-cpds nclasses) - (let ((candidates nil) - (next-cpd nil) - (rcpl nil)) - - ;; We have to bootstrap the collection of those CPD's that have a zero count. Once we get - ;; going, we will maintain this list incrementally. - (dolist (cpd all-cpds) - (when (zerop (cpd-count cpd)) - (push cpd candidates))) - (loop (when (null candidates) - - ;; If there are no candidates, and enough classes have been put into the precedence - ;; list, then we are all done. Otherwise it means there is a consistency problem. - (if (zerop nclasses) - (return (reverse rcpl)) - (cpl-inconsistent-error class all-cpds))) - - ;; Try to find the next class to put in from among the candidates. If there is only one, - ;; its easy, otherwise we have to use the famous RPG tiebreaker rule. There is some - ;; hair here to avoid having to call DELETE on the list of candidates. I dunno if its - ;; worth it but what the hell. - (setq next-cpd - (if (null (cdr candidates)) - (prog1 (car candidates) - (setq candidates nil)) - (block tie-breaker - (dolist (c rcpl) - (let ((supers (class-direct-superclasses c))) - (if (memq (cpd-class (car candidates)) - supers) - (return-from tie-breaker (pop candidates)) - (do ((loc candidates (cdr loc))) - ((null (cdr loc))) - (let ((cpd (cadr loc))) - (when (memq (cpd-class cpd) - supers) - (setf (cdr loc) - (cddr loc)) - (return-from tie-breaker cpd)))))))))) - (decf nclasses) - (push (cpd-class next-cpd) - rcpl) - (dolist (after (cpd-after next-cpd)) - (when (zerop (decf (cpd-count after))) - (push after candidates)))))) - - -;;; Support code for signalling nice error messages. - - -(defun cpl-error (class format-string &rest format-args) - (error "While computing the class precedence list of the class ~A.~%~A" - (if (class-name class) - (format nil "named ~S" (class-name class)) - class) - (apply #'format nil format-string format-args))) - -(defun cpl-forward-referenced-class-error (class forward-class) - (flet ((class-or-name (class) - (if (class-name class) - (format nil "named ~S" (class-name class)) - class))) - (let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class)))) - ) - (cpl-error class - "The class ~A is a forward referenced class.~@ - The class ~A is ~A." (class-or-name forward-class) - (class-or-name forward-class) - (if (null (cdr names)) - (format nil "a direct superclass of the class ~A" (class-or-name class)) - (format nil "reached from the class ~A by following~@ - the direct superclass chain through: ~A~ - ~% ending at the class ~A" (class-or-name class) - (format nil "~{~% the class ~A,~}" (butlast names)) - (car (last names)))))))) - -(defun find-superclass-chain (bottom top) - (labels ((walk (c chain) - (if (eq c top) - (return-from find-superclass-chain (nreverse chain)) - (dolist (super (class-direct-superclasses c)) - (walk super (cons super chain)))))) - (walk bottom (list bottom)))) - -(defun cpl-inconsistent-error (class all-cpds) - (let ((reasons (find-cycle-reasons all-cpds))) - (cpl-error class "It is not possible to compute the class precedence list because~@ - there ~A in the local precedence relations.~@ - ~A because:~{~% ~A~}." (if (cdr reasons) - "are circularities" - "is a circularity") - (if (cdr reasons) - "These arise" - "This arises") - (format-cycle-reasons (apply #'append reasons))))) - -(defun format-cycle-reasons (reasons) - (flet ((class-or-name (cpd) - (let ((class (cpd-class cpd))) - (if (class-name class) - (format nil "named ~S" (class-name class)) - class)))) - (mapcar #'(lambda (reason) - (ecase (caddr reason) - (:super (format nil - "the class ~A appears in the supers of the class ~A" - (class-or-name (cadr reason)) - (class-or-name (car reason)))) - (:in-supers (format nil - "the class ~A follows the class ~A in the supers of the class ~A" - (class-or-name (cadr reason)) - (class-or-name (car reason)) - (class-or-name (cadddr reason)))))) - reasons))) - -(defun find-cycle-reasons (all-cpds) - (let ((been-here nil) - ; List of classes we have visited. - (cycle-reasons nil)) - (labels ((chase (path) - (if (memq (car path) - (cdr path)) - (record-cycle (memq (car path) - (nreverse path))) - (unless (memq (car path) - been-here) - (push (car path) - been-here) - (dolist (after (cpd-after (car path))) - (chase (cons after path)))))) - (record-cycle - (cycle) - (let ((reasons nil)) - (do* ((t1 cycle t2) - (t2 (cdr t1) - (cdr t1))) - ((null t2)) - (let ((c1 (car t1)) - (c2 (car t2))) - (if (memq c2 (cpd-supers c1)) - (push (list c1 c2 :super) - reasons) - (dolist (cpd all-cpds) - (when (memq c2 (memq c1 (cpd-supers cpd))) - (return (push (list c1 c2 :in-supers cpd) - reasons))))))) - (push (nreverse reasons) - cycle-reasons)))) - (dolist (cpd all-cpds) - (unless (zerop (cpd-count cpd)) - (chase (list cpd)))) - cycle-reasons))) diff --git a/obsolete/clos/2.0/ctypes.lisp b/obsolete/clos/2.0/ctypes.lisp deleted file mode 100644 index 1de6d3a4..00000000 --- a/obsolete/clos/2.0/ctypes.lisp +++ /dev/null @@ -1,25 +0,0 @@ -;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; - -(in-package 'clos) - -;;; -;;; The built-in method combination types as taken from page 1-31 of 88-002R. -;;; Note that the STANDARD method combination type is defined by hand in the -;;; file combin.lisp. -;;; - -(define-method-combination + :identity-with-one-argument t) -(define-method-combination and :identity-with-one-argument t) -(define-method-combination append :identity-with-one-argument nil) -(define-method-combination list :identity-with-one-argument nil) -(define-method-combination max :identity-with-one-argument t) -(define-method-combination min :identity-with-one-argument t) -(define-method-combination nconc :identity-with-one-argument t) -(define-method-combination or :identity-with-one-argument t) -(define-method-combination progn :identity-with-one-argument t) diff --git a/obsolete/clos/2.0/defclass.lisp b/obsolete/clos/2.0/defclass.lisp deleted file mode 100644 index 4aaf9791..00000000 --- a/obsolete/clos/2.0/defclass.lisp +++ /dev/null @@ -1,230 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - -;;;. Copyright (c) 1991 by Venue -(in-package "CLOS") - -;;; ************************************************************************* - - - -;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. The original -;;; motiviation for this function was to deal with the bug in the Genera compiler that prevents -;;; lambda expressions in top-level forms other than DEFUN from being compiled. Now this function is -;;; used to grab other functionality as well. This includes: - Preventing the grouping of top-level -;;; forms. For example, a DEFCLASS followed by a DEFMETHOD may not want to be grouped into the same -;;; top-level form. - Telling the programming environment what the pretty version of the name of -;;; this form is. This is used by WARN. - - -(defun make-top-level-form (name times form) - (flet ((definition-name nil (if (and (listp name) - (memq (car name) - '(defmethod defclass class method - method-combination))) - (format nil "~A~{ ~S~}" (capitalize-words (car name) - nil) - (cdr name)) - (format nil "~S" name)))) - (definition-name) - (make-progn `',name `(eval-when ,times ,form)))) - -(defun make-progn (&rest forms) - (let ((progn-form nil)) - (labels ((collect-forms (forms) - (unless (null forms) - (collect-forms (cdr forms)) - (if (and (listp (car forms)) - (eq (caar forms) - 'progn)) - (collect-forms (cdar forms)) - (push (car forms) - progn-form))))) - (collect-forms forms) - (cons 'progn progn-form)))) - - -;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. DEFCLASS always expands -;;; into a call to LOAD-DEFCLASS. Until the meta- braid is set up, LOAD-DEFCLASS has a special -;;; definition which simply collects all class definitions up, when the metabraid is initialized it -;;; is done from those class definitions. After the metabraid has been setup, and the protocol for -;;; defining classes has been defined, the real definition of LOAD-DEFCLASS is installed by the file -;;; defclass.lisp - - -(defmacro defclass (name direct-superclasses direct-slots &rest options) - (declare (indentation 2 4 3 1)) - (expand-defclass name direct-superclasses direct-slots options)) - -(defun expand-defclass (name supers slots options) - (setq supers (copy-tree supers) - slots - (copy-tree slots) - options - (copy-tree options)) - (let ((metaclass 'standard-class)) - (dolist (option options) - (if (not (listp option)) - (error "~S is not a legal defclass option." option) - (when (eq (car option) - ':metaclass) - (unless (legal-class-name-p (cadr option)) - (error - "The value of the :metaclass option (~S) is not a~%~ - legal class name." (cadr option))) - (setq metaclass (cadr option)) - (setf options (remove option options)) - (return t)))) - (let ((*initfunctions* nil) - (*accessors* nil)) - ; Truly a crock, but we got to have it - ; to live nicely. - (declare (special *initfunctions* *accessors*)) - (let ((canonical-slots (mapcar #'(lambda (spec) - (canonicalize-slot-specification name spec)) - slots)) - (other-initargs (mapcar #'(lambda (option) - (canonicalize-defclass-option name option)) - options))) - (do-standard-defsetfs-for-defclass *accessors*) -; (load-defclass name metaclass supers -; canonical-slots (apply #'append -; other-initargs) *accessors*))))) - (make-top-level-form `(defclass ,name nil nil) - *defclass-times* - `(let ,(mapcar #'cdr *initfunctions*) - (load-defclass ',name ',metaclass ',supers (list - ,@canonical-slots - ) - (list ,@(apply #'append other-initargs)) - ',*accessors*))))))) - -(defun make-initfunction (initform) - (declare (special *initfunctions*)) - (cond ((or (eq initform 't) - (equal initform ''t)) - '#'true) - ((or (eq initform 'nil) - (equal initform ''nil)) - '#'false) - ((or (eql initform '0) - (equal initform ''0)) - '#'zero) - (t (let ((entry (assoc initform *initfunctions* :test #'equal))) - (unless entry - (setq entry (list initform (gensym) - `#'(lambda nil ,initform))) - (push entry *initfunctions*)) - (cadr entry))))) - -(defun canonicalize-slot-specification (class-name spec) - (declare (special *accessors*)) - (cond ((and (symbolp spec) - (not (keywordp spec)) - (not (memq spec '(t nil)))) - `'(:name ,spec)) - ((not (consp spec)) - (error "~S is not a legal slot specification." spec)) - ((null (cdr spec)) - `'(:name ,(car spec))) - ((null (cddr spec)) - (error - "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~ - Convert it to ~S" class-name spec (list (car spec) - :initform - (cadr spec)))) - (t (let* ((name (pop spec)) - (readers nil) - (writers nil) - (initargs nil) - (unsupplied (list nil)) - (initform (getf spec :initform unsupplied))) - (doplist (key val) - spec - (case key - (:accessor - (push val *accessors*) - (push val readers) - (push `(setf ,val) - writers)) - (:reader (push val readers)) - (:writer (push val writers)) - (:initarg (push val initargs)))) - (loop (unless (remf spec :accessor) - (return))) - (loop (unless (remf spec :reader) - (return))) - (loop (unless (remf spec :writer) - (return))) - (loop (unless (remf spec :initarg) - (return))) - (setq spec `(:name ',name :readers ',readers - :writers ',writers :initargs - ',initargs - ',spec)) - (if (eq initform unsupplied) - `(list* ,@spec) - `(list* :initfunction ,(make-initfunction initform) - ,@spec)))))) - -(defun canonicalize-defclass-option (class-name option) - (declare (ignore class-name)) - (case (car option) - (:default-initargs (let ((canonical nil)) - (let (key val (tail (cdr option))) - (loop (when (null tail) - (return nil)) - (setq key (pop tail) - val - (pop tail)) - (push ``(,',key ,,(make-initfunction val) - ,',val) - canonical)) - `(':direct-default-initargs (list ,@(nreverse canonical)))))) - (otherwise `(',(car option) - ',(cdr option))))) - - -;;; This is the early definition of load-defclass. It just collects up all the class definitions in -;;; a list. Later, in the file braid1.lisp, these are actually defined. Each entry in -;;; *early-class-definitions* is an early-class-definition. - - -(defparameter *early-class-definitions* nil) - -(defun make-early-class-definition (name source metaclass superclass-names canonical-slots - other-initargs) - (list 'early-class-definition name source metaclass superclass-names canonical-slots - other-initargs)) - -(defun ecd-class-name (ecd) - (nth 1 ecd)) - -(defun ecd-source (ecd) - (nth 2 ecd)) - -(defun ecd-metaclass (ecd) - (nth 3 ecd)) - -(defun ecd-superclass-names (ecd) - (nth 4 ecd)) - -(defun ecd-canonical-slots (ecd) - (nth 5 ecd)) - -(defun ecd-other-initargs (ecd) - (nth 6 ecd)) - -(proclaim '(notinline load-defclass)) - -(defun load-defclass (name metaclass supers canonical-slots canonical-options accessor-names) - (setq supers (copy-tree supers) - canonical-slots - (copy-tree canonical-slots) - canonical-options - (copy-tree canonical-options)) - (do-standard-defsetfs-for-defclass accessor-names) - (let ((ecd (make-early-class-definition name (load-truename) - metaclass supers canonical-slots (apply #'append canonical-options))) - (existing (find name *early-class-definitions* :key #'ecd-class-name))) - (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*))) - ecd)) diff --git a/obsolete/clos/2.0/defcombin.lisp b/obsolete/clos/2.0/defcombin.lisp deleted file mode 100644 index 5bb69ebd..00000000 --- a/obsolete/clos/2.0/defcombin.lisp +++ /dev/null @@ -1,410 +0,0 @@ -;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; - -(in-package 'clos) - -;;; -;;; DEFINE-METHOD-COMBINATION -;;; - -(defmacro define-method-combination (&whole form &rest args) - (declare (ignore args)) - (if (and (cddr form) - (listp (caddr form))) - (expand-long-defcombin form) - (expand-short-defcombin form))) - - -;;; -;;; STANDARD method combination -;;; -;;; The STANDARD method combination type is implemented directly by the class -;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does -;;; standard method combination directly and is defined by hand in the file -;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this -;;; file for bootstrapping reasons. -;;; -;;; A commented out copy of this definition appears in combin.lisp. -;;; If you change this definition here, be sure to change it there -;;; also. -;;; -(defmethod find-method-combination ((generic-function generic-function) - (type (eql 'standard)) - options) - (when options - (method-combination-error - "The method combination type STANDARD accepts no options.")) - *standard-method-combination*) - - - -;;; -;;; short method combinations -;;; -;;; Short method combinations all follow the same rule for computing the -;;; effective method. So, we just implement that rule once. Each short -;;; method combination object just reads the parameters out of the object -;;; and runs the same rule. -;;; -;;; -(defclass short-method-combination (standard-method-combination) - ((operator - :reader short-combination-operator - :initarg :operator) - (identity-with-one-argument - :reader short-combination-identity-with-one-argument - :initarg :identity-with-one-argument))) - -(define-gf-predicate short-method-combination-p short-method-combination) - -(defun expand-short-defcombin (whole) - (let* ((type (cadr whole)) - (documentation - (getf (cddr whole) :documentation "")) - (identity-with-one-arg - (getf (cddr whole) :identity-with-one-argument nil)) - (operator - (getf (cddr whole) :operator type))) - (make-top-level-form `(define-method-combination ,type) - '(load eval) - `(load-short-defcombin - ',type ',operator ',identity-with-one-arg ',documentation)))) - -(defun load-short-defcombin (type operator ioa doc) - (let* ((truename (load-truename)) - (specializers - (list (find-class 'generic-function) - (make-instance 'eql-specializer :object type) - *the-class-t*)) - (old-method - (get-method #'find-method-combination () specializers nil)) - (new-method nil)) - (setq new-method - (make-instance 'standard-method - :qualifiers () - :specializers specializers - :lambda-list '(generic-function type options) - :function #'(lambda (gf type options) - (declare (ignore gf)) - (do-short-method-combination - type options operator ioa new-method doc)) - :definition-source `((define-method-combination ,type) ,truename))) - (when old-method - (remove-method #'find-method-combination old-method)) - (add-method #'find-method-combination new-method))) - -(defun do-short-method-combination (type options operator ioa method doc) - (cond ((null options) (setq options '(:most-specific-first))) - ((equal options '(:most-specific-first))) - ((equal options '(:most-specific-last))) - (t - (method-combination-error - "Illegal options to a short method combination type.~%~ - The method combination type ~S accepts one option which~%~ - must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST." - type))) - (make-instance 'short-method-combination - :type type - :options options - :operator operator - :identity-with-one-argument ioa - :definition-source method - :documentation doc)) - -(defmethod compute-effective-method ((generic-function generic-function) - (combin short-method-combination) - applicable-methods) - (let ((type (method-combination-type combin)) - (operator (short-combination-operator combin)) - (ioa (short-combination-identity-with-one-argument combin)) - (around ()) - (primary ())) - (dolist (m applicable-methods) - (let ((qualifiers (method-qualifiers m))) - (flet ((lose (method why) - (invalid-method-error - method - "The method ~S ~A.~%~ - The method combination type ~S was defined with the~%~ - short form of DEFINE-METHOD-COMBINATION and so requires~%~ - all methods have either the single qualifier ~S or the~%~ - single qualifier :AROUND." - method why type type))) - (cond ((null qualifiers) - (lose m "has no qualifiers")) - ((cdr qualifiers) - (lose m "has more than one qualifier")) - ((eq (car qualifiers) :around) - (push m around)) - ((eq (car qualifiers) type) - (push m primary)) - (t - (lose m "has an illegal qualifier")))))) - (setq around (nreverse around) - primary (nreverse primary)) - (let ((main-method - (if (and (null (cdr primary)) - (not (null ioa))) - `(call-method ,(car primary) ()) - `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ())) - primary))))) - (cond ((null primary) - `(error "No ~S methods for the generic function ~S." - ',type ',generic-function)) - ((null around) main-method) - (t - `(call-method ,(car around) - (,@(cdr around) (make-method ,main-method)))))))) - - -;;; -;;; long method combinations -;;; -;;; - -(defclass long-method-combination (standard-method-combination) - ((function :initarg :function - :reader long-method-combination-function))) - -(defun expand-long-defcombin (form) - (let ((type (cadr form)) - (lambda-list (caddr form)) - (method-group-specifiers (cadddr form)) - (body (cddddr form)) - (arguments-option ()) - (gf-var nil)) - (when (and (consp (car body)) (eq (caar body) :arguments)) - (setq arguments-option (cdr (pop body)))) - (when (and (consp (car body)) (eq (caar body) :generic-function)) - (setq gf-var (cadr (pop body)))) - (multiple-value-bind (documentation function) - (make-long-method-combination-function - type lambda-list method-group-specifiers arguments-option gf-var - body) - (make-top-level-form `(define-method-combination ,type) - '(load eval) - `(load-long-defcombin ',type ',documentation #',function))))) - -(defvar *long-method-combination-functions* (make-hash-table :test #'eq)) - -(defun load-long-defcombin (type doc function) - (let* ((specializers - (list (find-class 'generic-function) - (make-instance 'eql-specializer :object type) - *the-class-t*)) - (old-method - (get-method #'find-method-combination () specializers nil)) - (new-method - (make-instance 'standard-method - :qualifiers () - :specializers specializers - :lambda-list '(generic-function type options) - :function #'(lambda (generic-function type options) - (declare (ignore generic-function)) - (make-instance 'long-method-combination - :type type - :documentation doc - :options options)) - :definition-source `((define-method-combination ,type) - ,(load-truename))))) - (setf (gethash type *long-method-combination-functions*) function) - (when old-method (remove-method #'find-method-combination old-method)) - (add-method #'find-method-combination new-method))) - -(defmethod compute-effective-method ((generic-function generic-function) - (combin long-method-combination) - applicable-methods) - (funcall (gethash (method-combination-type combin) - *long-method-combination-functions*) - generic-function - combin - applicable-methods)) - -;;; -;;; -;;; -(defun make-long-method-combination-function - (type ll method-group-specifiers arguments-option gf-var body) - (declare (ignore type) (values documentation function)) - (multiple-value-bind (documentation declarations real-body) - (extract-declarations body) - - (let ((wrapped-body - (wrap-method-group-specifier-bindings method-group-specifiers - declarations - real-body))) - (when gf-var - (push `(,gf-var .generic-function.) (cadr wrapped-body))) - - (when arguments-option - (setq wrapped-body (deal-with-arguments-option wrapped-body - arguments-option))) - - (when ll - (setq wrapped-body - `(apply #'(lambda ,ll ,wrapped-body) - (method-combination-options .method-combination.)))) - - (values - documentation - `(lambda (.generic-function. .method-combination. .applicable-methods.) - (progn .generic-function. .method-combination. .applicable-methods.) - (block .long-method-combination-function. ,wrapped-body)))))) -;; -;; parse-method-group-specifiers parse the method-group-specifiers -;; - -(defun wrap-method-group-specifier-bindings - (method-group-specifiers declarations real-body) - (with-gathering ((names (collecting)) - (specializer-caches (collecting)) - (cond-clauses (collecting)) - (required-checks (collecting)) - (order-cleanups (collecting))) - (dolist (method-group-specifier method-group-specifiers) - (multiple-value-bind (name tests description order required) - (parse-method-group-specifier method-group-specifier) - (declare (ignore description)) - (let ((specializer-cache (gensym))) - (gather name names) - (gather specializer-cache specializer-caches) - (gather `((or ,@tests) - (if (equal ,specializer-cache .specializers.) - (return-from .long-method-combination-function. - '(error "More than one method of type ~S ~ - with the same specializers." - ',name)) - (setq ,specializer-cache .specializers.)) - (push .method. ,name)) - cond-clauses) - (when required - (gather `(when (null ,name) - (return-from .long-method-combination-function. - '(error "No ~S methods." ',name))) - required-checks)) - (loop (unless (and (constantp order) - (neq order (setq order (eval order)))) - (return t))) - (gather (cond ((eq order :most-specific-first) - `(setq ,name (nreverse ,name))) - ((eq order :most-specific-last) ()) - (t - `(ecase ,order - (:most-specific-first - (setq ,name (nreverse ,name))) - (:most-specific-last)))) - order-cleanups)))) - `(let (,@names ,@specializer-caches) - ,@declarations - (dolist (.method. .applicable-methods.) - (let ((.qualifiers. (method-qualifiers .method.)) - (.specializers. (method-specializers .method.))) - (progn .qualifiers. .specializers.) - (cond ,@cond-clauses))) - ,@required-checks - ,@order-cleanups - ,@real-body))) - -(defun parse-method-group-specifier (method-group-specifier) - (declare (values name tests description order required)) - (let* ((name (pop method-group-specifier)) - (patterns ()) - (tests - (gathering1 (collecting) - (block collect-tests - (loop - (if (or (null method-group-specifier) - (memq (car method-group-specifier) - '(:description :order :required))) - (return-from collect-tests t) - (let ((pattern (pop method-group-specifier))) - (push pattern patterns) - (gather1 (parse-qualifier-pattern name pattern))))))))) - (values name - tests - (getf method-group-specifier :description - (make-default-method-group-description patterns)) - (getf method-group-specifier :order :most-specific-first) - (getf method-group-specifier :required nil)))) - -(defun parse-qualifier-pattern (name pattern) - (cond ((eq pattern '()) `(null .qualifiers.)) - ((eq pattern '*) 't) - ((symbolp pattern) `(,pattern .qualifiers.)) - ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.)) - (t (error "In the method group specifier ~S,~%~ - ~S isn't a valid qualifier pattern." - name pattern)))) - -(defun qualifier-check-runtime (pattern qualifiers) - (loop (cond ((and (null pattern) (null qualifiers)) - (return t)) - ((eq pattern '*) (return t)) - ((and pattern qualifiers (eq (car pattern) (car qualifiers))) - (pop pattern) - (pop qualifiers)) - (t (return nil))))) - -(defun make-default-method-group-description (patterns) - (if (cdr patterns) - (format nil - "methods matching one of the patterns: ~{~S, ~} ~S" - (butlast patterns) (car (last patterns))) - (format nil - "methods matching the pattern: ~S" - (car patterns)))) - - - -;;; -;;; This baby is a complete mess. I can't believe we put it in this -;;; way. No doubt this is a large part of what drives MLY crazy. -;;; -;;; At runtime (when the effective-method is run), we bind an intercept -;;; lambda-list to the arguments to the generic function. -;;; -;;; At compute-effective-method time, the symbols in the :arguments -;;; option are bound to the symbols in the intercept lambda list. -;;; -(defun deal-with-arguments-option (wrapped-body arguments-option) - (let* ((intercept-lambda-list - (gathering1 (collecting) - (dolist (arg arguments-option) - (if (memq arg lambda-list-keywords) - (gather1 arg) - (gather1 (gensym)))))) - (intercept-rebindings - (gathering1 (collecting) - (iterate ((arg (list-elements arguments-option)) - (int (list-elements intercept-lambda-list))) - (unless (memq arg lambda-list-keywords) - (gather1 `(,arg ',int))))))) - ;; - ;; - (setf (cadr wrapped-body) - (append intercept-rebindings (cadr wrapped-body))) - ;; - ;; Be sure to fill out the intercept lambda list so that it can - ;; be too short if it wants to. - ;; - (cond ((memq '&rest intercept-lambda-list)) - ((memq '&allow-other-keys intercept-lambda-list)) - ((memq '&key intercept-lambda-list) - (setq intercept-lambda-list - (append intercept-lambda-list '(&allow-other-keys)))) - (t - (setq intercept-lambda-list - (append intercept-lambda-list '(&rest .ignore.))))) - - `(let ((inner-result. ,wrapped-body)) - `(apply #'(lambda ,',intercept-lambda-list - ,,(when (memq '.ignore. intercept-lambda-list) - ''(declare (ignore .ignore.))) - ,inner-result.) - .combined-method-args.)))) - diff --git a/obsolete/clos/2.0/defs.lisp b/obsolete/clos/2.0/defs.lisp deleted file mode 100644 index e0f2a047..00000000 --- a/obsolete/clos/2.0/defs.lisp +++ /dev/null @@ -1,570 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- -;;;. Copyright (c) 1991 by Venue - - -(in-package "CLOS") - -(eval-when (compile load eval) - (defvar *defclass-times* '(load eval compile)) ;Probably have to change this - ;if you use defconstructor. -(defvar *defmethod-times* '(load eval compile)) -(defvar *defgeneric-times* '(load eval compile)) -) - - -;;; Convert a function name to its standard setf function name. We have to do this hack because not -;;; all Common Lisps have yet converted to having setf function specs. In a port that does have setf -;;; function specs you can use those just by making the obvious simple changes to these functions. -;;; The rest of CLOS believes that there are function names like (SETF ), this is the only place -;;; that knows about this hack. - - -(eval-when (compile load eval) - (defvar *setf-function-names* (make-hash-table :size 200 :test #'eq)) -(defun get-setf-function-name (name) - (or (gethash name *setf-function-names*) - (setf (gethash name *setf-function-names*) - (intern (format nil - "SETF ~A ~A" - (package-name (symbol-package name)) - (symbol-name name)) - *the-clos-package*)))) - -;;; -;;; Call this to define a setf macro for a function with the same behavior as -;;; specified by the SETF function cleanup proposal. Specifically, this will -;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b). -;;; -;;; do-standard-defsetf A macro interface for use at top level -;;; in files. Unfortunately, users may -;;; have to use this for a while. -;;; -;;; do-standard-defsetfs-for-defclass A special version called by defclass. -;;; -;;; do-standard-defsetf-1 A functional interface called by the -;;; above, defmethod and defgeneric. -;;; Since this is all a crock anyways, -;;; users are free to call this as well. -;;; -(defmacro do-standard-defsetf (&rest function-names) - `(eval-when (compile load eval) - (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name)))) - -(defun do-standard-defsetfs-for-defclass (accessors) - (dolist (name accessors) (do-standard-defsetf-1 name))) - -(defun do-standard-defsetf-1 (function-name) - (unless (setfboundp function-name) - (let* ((setf-function-name (get-setf-function-name function-name))) - - (flet ((setf-expander (body env) - (declare (ignore env)) - (let ((temps - (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) - (cdr body))) - (forms (cdr body)) - (vars (list (gensym)))) - (values temps - forms - vars - `(,setf-function-name ,@vars ,@temps) - `(,function-name ,@temps))))) - (let ((setf-method-expander (intern (concatenate 'string - (symbol-name function-name) - "-setf-expander") - (symbol-package function-name)))) - (setf (get function-name :setf-method-expander) setf-method-expander - (symbol-function setf-method-expander) #'setf-expander))) - - ))) -(defun setfboundp (symbol) -(or (get symbol :setf-inverse) - (get symbol 'il:setf-inverse) - (get symbol 'il:setfn) - (get symbol :shared-setf-inverse) - (get symbol :setf-method-expander) - (get symbol 'il:setf-method-expander))) -) - - ; eval-when - - - -;;; CLOS, like user code, must endure the fact that we don't have a properly working setf. Many -;;; things work because they get mentioned by a defclass or defmethod before they are used, but -;;; others have to be done by hand. - - -(do-standard-defsetf - class-wrapper ; *** - generic-function-name - method-function-plist - method-function-get - gdefinition - slot-value-using-class) - -(defsetf slot-value set-slot-value) - - -;;; This is like fdefinition on the Lispm. If Common Lisp had something like function specs I -;;; wouldn't need this. On the other hand, I don't like the way this really works so maybe function -;;; specs aren't really right either? I also don't understand the real implications of a Lisp-1 on -;;; this sort of thing. Certainly some of the lossage in all of this is because these SPECs name -;;; global definitions. Note that this implementation is set up so that an implementation which has -;;; a 'real' function spec mechanism can use that instead and in that way get rid of setf generic -;;; function names. - - -(defmacro parse-gspec (spec (non-setf-var . non-setf-case) - (setf-var . setf-case)) - (once-only (spec) - `(cond ((symbolp ,spec) - (let ((,non-setf-var ,spec)) - ,@non-setf-case)) - ((and (listp ,spec) - (eq (car ,spec) - 'setf) - (symbolp (cadr ,spec))) - (let ((,setf-var (cadr ,spec))) - ,@setf-case)) - (t (error "Can't understand ~S as a generic function specifier.~%~ - It must be either a symbol which can name a function or~%~ - a list like ~S, where the car is the symbol ~S and the cadr~%~ - is a symbol which can name a generic function." ,spec '(setf ) - 'setf))))) - - -;;; If symbol names a function which is traced or advised, return the unadvised, traced etc. -;;; definition. This lets me get at the generic function object even when it is traced. - - -(defun unencapsulated-fdefinition (symbol) - (il:virginfn symbol)) - - -;;; If symbol names a function which is traced or advised, redefine the `real' definition without -;;; affecting the advise. - - -(defun fdefine-carefully (symbol new-definition) - (let ((advisedp (member symbol il:advisedfns :test #'eq)) - (brokenp (member symbol il:brokenfns :test #'eq))) - - ;; In XeroxLisp (late of envos) tracing is implemented as a special case of "breaking". - ;; Advising, however, is treated specially. - (xcl:unadvise-function symbol :no-error t) - (xcl:unbreak-function symbol :no-error t) - (setf (symbol-function symbol) - new-definition) - (when brokenp (xcl:rebreak-function symbol)) - (when advisedp (xcl:readvise-function symbol))) - new-definition) - -(defun gboundp (spec) - (parse-gspec spec (name (fboundp name)) - (name (fboundp (get-setf-function-name name))))) - -(defun gmakunbound (spec) - (parse-gspec spec (name (fmakunbound name)) - (name (fmakunbound (get-setf-function-name name))))) - -(defun gdefinition (spec) - (parse-gspec spec (name (or (macro-function name) - ; ?? - (unencapsulated-fdefinition name))) - (name (unencapsulated-fdefinition (get-setf-function-name name))))) - -(defun SETF\ CLOS\ GDEFINITION (new-value spec) - (parse-gspec spec (name (fdefine-carefully name new-value)) - (name (fdefine-carefully (get-setf-function-name name) - new-value)))) - - -;;; These functions are a pale imitiation of their namesake. They accept class objects or types -;;; where they should. - - -(defun *typep (object type) - (if (classp type) - (let ((class (class-of object))) - (if class - (memq type (class-precedence-list class)) - nil)) - (let ((class (find-class type nil))) - (if class - (*typep object class) - (typep object type))))) - -(defun *subtypep (type1 type2) - (let ((c1 (if (classp type1) - type1 - (find-class type1 nil))) - (c2 (if (classp type2) - type2 - (find-class type2 nil)))) - (if (and c1 c2) - (memq c2 (class-precedence-list c1)) - (if (or c1 c2) - nil - ; This isn't quite right, but... - (subtypep type1 type2))))) - -(defun do-satisfies-deftype (name predicate) - (let* ((specifier `(satisfies ,predicate)) - (expand-fn #'(lambda (&rest ignore) - (declare (ignore ignore)) - specifier))) - - ;; Specific ports can insert their own way of doing this. Many ports may find the - ;; expand-fn defined above useful. - (or - ;; This is the default for ports for which we don't know any better. Note that for - ;; most ports, providing this definition should just speed up class definition. It - ;; shouldn't have an effect on performance of most user code. - (eval `(deftype ,name nil '(satisfies ,predicate)))))) - -(defun make-type-predicate-name (name) - (intern (format nil "TYPE-PREDICATE ~A ~A" (package-name (symbol-package name)) - (symbol-name name)) - *the-clos-package*)) - -(proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string* - *the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number* - *the-class-null* *the-class-list* *the-class-integer* *the-class-float* - *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* - *the-class-array* *the-class-standard-object* *the-class-class* *the-class-method* - *the-class-generic-function* *the-class-standard-class* *the-class-standard-method* - *the-class-standard-generic-function* - *the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots*)) - -(proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol* - *the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational* - *the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null* - *the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float* - *the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character* - *the-wrapper-of-bit-vector* *the-wrapper-of-array*)) - -(defvar *built-in-class-symbols* nil) - -(defvar *built-in-wrapper-symbols* nil) - -(defun get-built-in-class-symbol (class-name) - (or (cadr (assq class-name *built-in-class-symbols*)) - (let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name)) - *the-clos-package*))) - (push (list class-name symbol) - *built-in-class-symbols*) - symbol))) - -(defun get-built-in-wrapper-symbol (class-name) - (or (cadr (assq class-name *built-in-wrapper-symbols*)) - (let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name)) - *the-clos-package*))) - (push (list class-name symbol) - *built-in-wrapper-symbols*) - symbol))) - -(pushnew 'class *variable-declarations*) - -(pushnew 'variable-rebinding *variable-declarations*) - -(defun variable-class (var env) - (caddr (variable-declaration 'class var env))) - -(defvar *boot-state* nil) - ; NIL EARLY BRAID COMPLETE - - -(eval-when (load eval) - (when (eq *boot-state* 'complete) - (error "Trying to load (or compile) CLOS in an environment in which it~%~ - has already been loaded. This doesn't work, you will have to~%~ - get a fresh lisp (reboot) and then load CLOS.")) - (when *boot-state* (cerror "Try loading (or compiling) CLOS anyways." "Trying to load (or compile) CLOS in an environment in which it~%~ - has already been partially loaded. This may not work, you may~%~ - need to get a fresh lisp (reboot) and then load CLOS."))) - - -;;; This is used by combined methods to communicate the next methods to the methods they call. This -;;; variable is captured by a lexical variable of the methods to give it the proper lexical scope. - - -(defvar *next-methods* nil) - -(defvar *not-an-eql-specializer* '(not-an-eql-specializer)) - -(defvar *umi-gfs*) - -(defvar *umi-complete-classes*) - -(defvar *umi-reorder*) - -(defvar *invalidate-discriminating-function-force-p* nil) - -(defvar *invalid-dfuns-on-stack* nil) - -(defvar *standard-method-combination*) - -(defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) - - ; *** - - -(defmacro define-gf-predicate (predicate &rest classes) - `(progn (defmethod ,predicate ((x t)) - nil) - ,@(mapcar #'(lambda (c) - `(defmethod ,predicate ((x ,c)) - t)) - classes))) - -(defmacro plist-value (object name) - `(with-slots (plist) - ,object - (getf plist ,name))) - -(defsetf plist-value (object name) - (new-value) - (once-only (new-value) - `(with-slots (plist) - ,object - (if ,new-value - (setf (getf plist ,name) - ,new-value) - (progn (remf plist ,name) - nil))))) - -(defvar *built-in-classes* - - ;; name supers subs cdr of cpl - '((number (t) (complex float rational) - (t)) - (complex (number) - nil - (number t)) - (float (number) - nil - (number t)) - (rational (number) - (integer ratio) - (number t)) - (integer (rational) - nil - (rational number t)) - (ratio (rational) - nil - (rational number t)) - (sequence (t) - (list vector) - (t)) - (list (sequence) - (cons null) - (sequence t)) - (cons (list) - nil - (list sequence t)) - (array (t) - (vector) - (t)) - (vector (array sequence) - (string bit-vector) - (array sequence t)) - (string (vector) - nil - (vector array sequence t)) - (bit-vector (vector) - nil - (vector array sequence t)) - (character (t) - nil - (t)) - (symbol (t) - (null) - (t)) - (null (symbol) - nil - (symbol list sequence t)))) - - -;;; The classes that define the kernel of the metabraid. - - -(defclass t nil nil (:metaclass built-in-class)) - -(defclass standard-object (t) - nil) - -(defclass metaobject (standard-object) - nil) - -(defclass specializer (metaobject) - nil) - -(defclass definition-source-mixin (standard-object) - ((source :initform (load-truename) - :reader definition-source :initarg :definition-source))) - -(defclass plist-mixin (standard-object) - ((plist :initform nil))) - -(defclass documentation-mixin (plist-mixin) - nil) - -(defclass dependent-update-mixin (plist-mixin) - nil) - - -;;; The class CLASS is a specified basic class. It is the common superclass of any kind of class. -;;; That is any class that can be a metaclass must have the class CLASS in its class precedence -;;; list. - - -(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer) - ((name :initform nil :initarg :name :accessor class-name) - (direct-superclasses :initform nil :reader class-direct-superclasses) - (direct-subclasses :initform nil :reader class-direct-subclasses) - (direct-methods :initform (cons nil nil)))) - - -;;; The class CLOS-CLASS is an implementation-specific common superclass of all specified subclasses -;;; of the class CLASS. - - -(defclass clos-class (class) - ((class-precedence-list :initform nil) - (wrapper :initform nil))) - - -;;; The class STD-CLASS is an implementation-specific common superclass of the classes -;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS. - - -(defclass std-class (clos-class) - ((direct-slots :initform nil :accessor class-direct-slots) - (slots :initform nil :accessor class-slots) - (no-of-instance-slots ; *** MOVE TO WRAPPER *** - :initform 0 :accessor class-no-of-instance-slots) - (prototype :initform nil))) - -(defclass standard-class (std-class) - nil) - -(defclass funcallable-standard-class (std-class) - nil) - -(defclass forward-referenced-class (clos-class) - nil) - -(defclass built-in-class (clos-class) - nil) - - -;;; Slot definitions. Note that throughout CLOS, "SLOT-DEFINITION" is abbreviated as "SLOTD". - - -(defclass slot-definition (metaobject) - nil) - -(defclass direct-slot-definition (slot-definition) - nil) - -(defclass effective-slot-definition (slot-definition) - nil) -; -(defclass standard-slot-definition (slot-definition) - ((name :initform nil :accessor slotd-name) - (initform :initform *slotd-unsupplied* :accessor slotd-initform) - (initfunction :initform *slotd-unsupplied* :accessor slotd-initfunction) - (readers :initform nil :accessor slotd-readers) - (writers :initform nil :accessor slotd-writers) - (initargs :initform nil :accessor slotd-initargs) - (allocation :initform nil :accessor slotd-allocation) - (type :initform nil :accessor slotd-type) - (documentation :initform "" :initarg :documentation) - (class :initform nil :accessor slotd-class) - (instance-index :initform nil :accessor slotd-instance-index))) - -(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition) - nil) - - ; Adding slots here may involve extra - ; work to the code in braid.lisp - - -(defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition) - nil) - - ; Adding slots here may involve extra - ; work to the code in braid.lisp - - -(defclass eql-specializer (specializer) - ((object :initarg :object :reader eql-specializer-object))) - - -;;; - - -(defmacro dolist-carefully ((var list improper-list-handler) - &body body) - `(let ((,var nil) - (.dolist-carefully. ,list)) - (loop (when (null .dolist-carefully.) - (return nil)) - (if (consp .dolist-carefully.) - (progn (setq ,var (pop .dolist-carefully.)) - ,@body) - (,improper-list-handler))))) - -(defun legal-std-documentation-p (x) - (if (or (null x) - (stringp x)) - t - "a string or NULL")) - -(defun legal-std-lambda-list-p (x) - (declare (ignore x)) - t) - -(defun legal-std-method-function-p (x) - (if (functionp x) - t - "a function")) - -(defun legal-std-qualifiers-p (x) - (flet ((improper-list nil (return-from legal-std-qualifiers-p "Is not a proper list."))) - (dolist-carefully (q x improper-list) - (let ((ok (legal-std-qualifier-p q))) - (unless (eq ok t) - (return-from legal-std-qualifiers-p (format nil "Contains ~S which ~A" q - ok))))) - t)) - -(defun legal-std-qualifier-p (x) - (if (and x (atom x)) - t - "is not a non-null atom")) - -(defun legal-std-slot-name-p (x) - (cond ((not (symbolp x)) - "is not a symbol and so cannot be bound") - ((keywordp x) - "is a keyword and so cannot be bound") - ((memq x '(t nil)) - "cannot be bound") - (t t))) - -(defun legal-std-specializers-p (x) - (flet ((improper-list nil (return-from legal-std-specializers-p "Is not a proper list."))) - (dolist-carefully (s x improper-list) - (let ((ok (legal-std-specializer-p s))) - (unless (eq ok t) - (return-from legal-std-specializers-p (format nil "Contains ~S which ~A" - s ok))))) - t)) - -(defun legal-std-specializer-p (x) - (if (or (classp x) - (eql-specializer-p x)) - t - "is neither a class object nor an eql specializer")) diff --git a/obsolete/clos/2.0/defsys.lisp b/obsolete/clos/2.0/defsys.lisp deleted file mode 100644 index c8a5f6f7..00000000 --- a/obsolete/clos/2.0/defsys.lisp +++ /dev/null @@ -1,757 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; Some support stuff for compiling and loading CLOS. It would be nice if -;;; there was some portable make-system we could all agree to share for a -;;; while. At least until people really get databases and stuff. -;;; -;;; *** *** -;;; *** DIRECTIONS FOR INSTALLING CLOS AT YOUR SITE *** -;;; *** *** -;;; -;;; To get CLOS working at your site you should: -;;; -;;; - Get all the CLOS source files from Xerox. The complete list of source -;;; file names can be found in the defsystem for CLOS which appears towards -;;; the end of this file. -;;; -;;; - Edit the variable *clos-directory* below to specify the directory at -;;; your site where the clos sources and binaries will be. This variable -;;; can be found by searching from this point for the string "***" in -;;; this file. -;;; -;;; - Use the function (clos::compile-clos) to compile CLOS for your site. -;;; -;;; - Once CLOS has been compiled it can be loaded with (clos::load-clos). -;;; Note that CLOS cannot be loaded on top of itself, nor can it be -;;; loaded into the same world it was compiled in. -;;; - -(in-package "CLOS" :use (list (or (find-package :walker) - (make-package :walker :use '(:lisp))) - (or (find-package :iterate) - (make-package :iterate - :use '(:lisp :walker))) - (find-package :lisp))) - -(export (intern (symbol-name :iterate) ;Have to do this here, - (find-package :iterate)) ;because in the defsystem - (find-package :iterate)) ;(later in this file) - ;we use the symbol iterate - ;to name the file - -;;; -;;; Sure, its weird for this to be here, but in order to follow the rules -;;; about order of export and all that stuff, we can't put it in PKG before -;;; we want to use it. -;;; -(defvar *the-clos-package* (find-package :clos)) - -(defvar *clos-system-date* "5/10/91 Interim CLOS release") - - -;;; -;;; Various hacks to get people's *features* into better shape. -;;; -(eval-when (compile load eval) - #+(and Symbolics Lispm) - (multiple-value-bind (major minor) (sct:get-release-version) - (etypecase minor - (integer) - (string (setf minor (parse-integer minor :junk-allowed t)))) - (pushnew :genera *features*) - (ecase major - ((6) - (pushnew :genera-release-6 *features*)) - ((7) - (pushnew :genera-release-7 *features*) - (ecase minor - ((0 1) (pushnew :genera-release-7-1 *features*)) - ((2) (pushnew :genera-release-7-2 *features*)) - ((3) (pushnew :genera-release-7-3 *features*)) - ((4) (pushnew :genera-release-7-4 *features*)))) - ((8) - (pushnew :genera-release-8 *features*) - (ecase minor - ((0) (pushnew :genera-release-8-0 *features*)) - ((1) (pushnew :genera-release-8-1 *features*)))))) - - #+CLOE-Runtime - (let ((version (lisp-implementation-version))) - (when (string-equal version "2.0" :end1 (min 3 (length version))) - (pushnew :cloe-release-2 *features*))) - - (dolist (feature *features*) - (when (and (symbolp feature) ;3600!! - (equal (symbol-name feature) "CMU")) - (pushnew :CMU *features*))) - - #+TI - (if (eq (si:local-binary-file-type) :xld) - (pushnew ':ti-release-3 *features*) - (pushnew ':ti-release-2 *features*)) - - #+Lucid - (when (search "IBM RT PC" (machine-type)) - (pushnew :ibm-rt-pc *features*)) - - #+ExCL - (cond ((search "sun3" (lisp-implementation-version)) - (push :sun3 *features*)) - ((search "sun4" (lisp-implementation-version)) - (push :sun4 *features*))) - - #+(and HP Lucid) - (push :HP-Lucid *features*) - #+(and HP (not Lucid)) - (push :HP-HPLabs *features*) - - #+Xerox - (case il:makesysname - (:lyric (push :Xerox-Lyric *features*)) - (otherwise (pushnew :Xerox-Medley *features*))) -;;; -;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features* -;;; if you have installed turbo-closure patch. See the file kcl-mods.text -;;; for details. -;;; -;;; The xkcl version of KCL has this fixed already. -;;; - - #+xkcl(pushnew :turbo-closure *features*) - - ) - - - -;;; Yet Another Sort Of General System Facility and friends. -;;; -;;; The entry points are defsystem and operate-on-system. defsystem is used -;;; to define a new system and the files with their load/compile constraints. -;;; Operate-on-system is used to operate on a system defined that has been -;;; defined by defsystem. For example: -#|| - -(defsystem my-very-own-system - "/usr/myname/lisp/" - ((classes (precom) () ()) - (methods (precom classes) (classes) ()) - (precom () (classes methods) (classes methods)))) - -This defsystem should be read as follows: - -* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries - should be in the directory "/usr/me/lisp/". There are three files - in the system, there are named classes, methods and precom. (The - extension the filenames have depends on the lisp you are running in.) - -* For the first file, classes, the (precom) in the line means that - the file precom should be loaded before this file is loaded. The - first () means that no other files need to be loaded before this - file is compiled. The second () means that changes in other files - don't force this file to be recompiled. - -* For the second file, methods, the (precom classes) means that both - of the files precom and classes must be loaded before this file - can be loaded. The (classes) means that the file classes must be - loaded before this file can be compiled. The () means that changes - in other files don't force this file to be recompiled. - -* For the third file, precom, the first () means that no other files - need to be loaded before this file is loaded. The first use of - (classes methods) means that both classes and methods must be - loaded before this file can be compiled. The second use of (classes - methods) mean that whenever either classes or methods changes precom - must be recompiled. - -Then you can compile your system with: - - (operate-on-system 'my-very-own-system :compile) - -and load your system with: - - (operate-on-system 'my-very-own-system :load) - -||# - -;;; -(defvar *system-directory*) - -;;; -;;; *port* is a list of symbols (in the CLOS package) which represent the -;;; Common Lisp in which we are now running. Many of the facilities in -;;; defsys use the value of *port* rather than #+ and #- to conditionalize -;;; the way they work. -;;; -(defvar *port* - '(#+Genera Genera -; #+Genera-Release-6 Rel-6 -; #+Genera-Release-7-1 Rel-7 - #+Genera-Release-7-2 Rel-7 - #+Genera-Release-7-3 Rel-7 - #+Genera-Release-7-1 Rel-7-1 - #+Genera-Release-7-2 Rel-7-2 - #+Genera-Release-7-3 Rel-7-2 ;OK for now - #+Genera-Release-7-4 Rel-7-2 ;OK for now - #+Genera-Release-8 Rel-8 - #+imach Ivory - #+Cloe-Runtime Cloe - #+Lucid Lucid - #+Xerox Xerox - #+Xerox-Lyric Xerox-Lyric - #+Xerox-Medley Xerox-Medley - #+TI TI - #+(and dec vax common) Vaxlisp - #+KCL KCL - #+IBCL IBCL - #+excl excl - #+(and excl sun4) excl-sun4 - #+:CMU CMU - #+HP-HPLabs HP-HPLabs - #+:gclisp gclisp - #+pyramid pyramid - #+:coral coral)) - -;;; -;;; When you get a copy of CLOS (by tape or by FTP), the sources files will -;;; have extensions of ".lisp" in particular, this file will be defsys.lisp. -;;; The preferred way to install clos is to rename these files to have the -;;; extension which your lisp likes to use for its files. Alternately, it -;;; is possible not to rename the files. If the files are not renamed to -;;; the proper convention, the second line of the following defvar should -;;; be changed to: -;;; (let ((files-renamed-p nil) -;;; -;;; Note: Something people installing CLOS on a machine running Unix -;;; might find useful. If you want to change the extensions -;;; of the source files from ".lisp" to ".lsp", *all* you have -;;; to do is the following: -;;; -;;; % foreach i (*.lisp) -;;; ? mv $i $i:r.lsp -;;; ? end -;;; % -;;; -;;; I am sure that a lot of people already know that, and some -;;; Unix hackers may say, "jeez who doesn't know that". Those -;;; same Unix hackers are invited to fix mv so that I can type -;;; "mv *.lisp *.lsp". -;;; -(defvar *pathname-extensions* - (let ((files-renamed-p t) - (proper-extensions - (car - '(#+(and Genera (not imach)) ("lisp" . "bin") - #+(and Genera imach) ("lisp" . "ibin") - #+Cloe-Runtime ("l" . "fasl") - #+(and dec common vax (not ultrix)) ("LSP" . "FAS") - #+(and dec common vax ultrix) ("lsp" . "fas") - #+KCL ("lsp" . "o") - #+IBCL ("lsp" . "o") - #+Xerox ("lisp" . "dfasl") - #+(and Lucid MC68000) ("lisp" . "lbin") - #+(and Lucid VAX) ("lisp" . "vbin") - #+(and Lucid Prime) ("lisp" . "pbin") - #+(and Lucid SUNRise) ("lisp" . "sbin") - #+(and Lucid SPARC) ("lisp" . "sbin") - #+(and Lucid IBM-RT-PC) ("lisp" . "bbin") - #+(and Lucid MIPS) ("lisp" . "mbin") - #+(and Lucid PRISM) ("lisp" . "abin") - #+(and Lucid PA) ("lisp" . "hbin") - #+excl ("cl" . "fasl") - #+:CMU ("slisp" . "sfasl") - #+HP ("l" . "b") - #+TI ("lisp" . #.(string (si::local-binary-file-type))) - #+:gclisp ("LSP" . "F2S") - #+pyramid ("clisp" . "o") - #+:coral ("lisp" . "fasl") - )))) - (cond ((null proper-extensions) '("l" . "lbin")) - ((null files-renamed-p) (cons "lisp" (cdr proper-extensions))) - (t proper-extensions)))) - -(eval-when (compile load eval) - -(defun get-system (name) - (get name 'system-definition)) - -(defun set-system (name new-value) - (setf (get name 'system-definition) new-value)) - -(defmacro defsystem (name directory files) - `(set-system ',name (list #'(lambda () ,directory) - (make-modules ',files) - ',(mapcar #'car files)))) - -) - - -;;; -;;; The internal datastructure used when operating on a system. -;;; -(defstruct (module (:constructor make-module (name)) - (:print-function - (lambda (m s d) - (declare (ignore d)) - (format s "#" (module-name m))))) - name - load-env - comp-env - recomp-reasons) - -(defun make-modules (system-description) - (let ((modules ())) - (labels ((get-module (name) - (or (find name modules :key #'module-name) - (progn (setq modules (cons (make-module name) modules)) - (car modules)))) - (parse-spec (spec) - (if (eq spec 't) - (reverse (cdr modules)) - (case (car spec) - (+ (append (reverse (cdr modules)) (mapcar #'get-module (cdr spec)))) - (- (let ((rem (mapcar #'get-module (cdr spec)))) - (remove-if #'(lambda (m) (member m rem)) (reverse (cdr modules))))) - (otherwise (mapcar #'get-module spec)))))) - (dolist (file system-description) - (let* ((name (car file)) - (port (car (cddddr file))) - (module nil)) - (when (or (null port) - (member port *port*)) - (setq module (get-module name)) - (setf (module-load-env module) (parse-spec (cadr file)) - (module-comp-env module) (parse-spec (caddr file)) - (module-recomp-reasons module) (parse-spec - (cadddr file)))))) - (let ((filenames (mapcar #'car system-description))) - (sort modules #'(lambda (name1 name2) - (member name2 (member name1 filenames))) - :key #'module-name))))) - - -(defun make-transformations (modules filter make-transform) - (let ((transforms (list nil))) - (dolist (m modules) - (when (funcall filter m transforms) (funcall make-transform m transforms))) - (reverse (cdr transforms)))) - -(defun make-compile-transformation (module transforms) - (unless (dolist (trans transforms) - (and (eq (car trans) ':compile) - (eq (cadr trans) module) - (return t))) - (dolist (c (module-comp-env module)) (make-load-transformation c transforms)) - (setf (cdr transforms) - (remove-if #'(lambda (trans) (and (eq (car trans) :load) (eq (cadr trans) module))) - (cdr transforms))) - (push `(:compile ,module) (cdr transforms)))) - -(defvar *being-loaded* ()) - -(defun make-load-transformation (module transforms) - (if (assoc module *being-loaded*) - (throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*)))) - (let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*))) - (catch module - (unless (dolist (trans transforms) - (when (and (eq (car trans) ':load) - (eq (cadr trans) module)) - (return t))) - (dolist (l (module-load-env module)) (make-load-transformation l transforms)) - (push `(:load ,module) (cdr transforms))))))) - -(defun make-load-without-dependencies-transformation (module transforms) - (unless (dolist (trans transforms) - (and (eq (car trans) ':load) - (eq (cadr trans) module) - (return trans))) - (push `(:load ,module) (cdr transforms)))) - -(defun compile-filter (module transforms) - (or (dolist (r (module-recomp-reasons module)) - (when (dolist (transform transforms) - (when (and (eq (car transform) ':compile) - (eq (cadr transform) r)) - (return t))) - (return t))) - (null (probe-file (make-binary-pathname (module-name module)))) - (> (file-write-date (make-source-pathname (module-name module))) - (file-write-date (make-binary-pathname (module-name module)))))) - -(defun operate-on-system (name mode &optional arg print-only) - (let ((system (get-system name))) - (unless system (error "Can't find system with name ~S." name)) - (let ((*system-directory* (funcall (car system))) - (modules (cadr system)) - (transformations ())) - (labels ((load-source (name pathname) - (format t "~&Loading source of ~A..." name) - (or print-only (load pathname))) - (load-binary (name pathname) - (format t "~&Loading binary of ~A..." name) - (or print-only (load pathname))) - (load-module (m) - (let* ((name (module-name m)) - (*load-verbose* nil) - (binary (make-binary-pathname name))) - (load-binary name binary))) - (compile-module (m) - (format t "~&Compiling ~A..." (module-name m)) - (unless print-only - (let ((name (module-name m))) - (compile-file (make-source-pathname name) - :output-file - (make-pathname :defaults - (make-binary-pathname name) - :version :newest))))) - (xcl:true (&rest ignore) (declare (ignore ignore)) 't)) - - (setq transformations - (ecase mode - (:compile - ;; Compile any files that have changed and any other files - ;; that require recompilation when another file has been - ;; recompiled. - (make-transformations - modules - #'compile-filter - #'make-compile-transformation)) - (:recompile - ;; Force recompilation of all files. - (make-transformations - modules - #'xcl:true - #'make-compile-transformation)) - (:recompile-some - ;; Force recompilation of some files. Also compile the - ;; files that require recompilation when another file has - ;; been recompiled. - (make-transformations - modules - #'(lambda (m transforms) - (or (member (module-name m) arg) - (compile-filter m transforms))) - #'make-compile-transformation)) - (:query-compile - ;; Ask the user which files to compile. Compile those - ;; and any other files which must be recompiled when - ;; another file has been recompiled. - (make-transformations - modules - #'(lambda (m transforms) - (or (compile-filter m transforms) - (y-or-n-p "Compile ~A?" - (module-name m)))) - #'make-compile-transformation)) - (:confirm-compile - ;; Offer the user a chance to prevent a file from being - ;; recompiled. - (make-transformations - modules - #'(lambda (m transforms) - (and (compile-filter m transforms) - (y-or-n-p "Go ahead and compile ~A?" - (module-name m)))) - #'make-compile-transformation)) - (:load - ;; Load the whole system. - (make-transformations - modules - #'xcl:true - #'make-load-transformation)) - (:query-load - ;; Load only those files the user says to load. - (make-transformations - modules - #'(lambda (m transforms) - (declare (ignore transforms)) - (y-or-n-p "Load ~A?" (module-name m))) - #'make-load-without-dependencies-transformation)))) - - (#+Genera - compiler:compiler-warnings-context-bind - #+TI - COMPILER:COMPILER-WARNINGS-CONTEXT-BIND - #+:LCL3.0 - lucid-common-lisp:with-deferred-warnings - #-(or Genera TI :LCL3.0) - progn - (loop (when (null transformations) (return t)) - (let ((transform (pop transformations))) - (ecase (car transform) - (:compile (compile-module (cadr transform))) - (:load (load-module (cadr transform))))))))))) - - -(defun make-source-pathname (name) (make-pathname-internal name :source)) -(defun make-binary-pathname (name) (make-pathname-internal name :binary)) - -(defun make-pathname-internal (name type) - (let* ((extension (ecase type - (:source (car *pathname-extensions*)) - (:binary (cdr *pathname-extensions*)))) - (directory (pathname - (etypecase *system-directory* - (string *system-directory*) - (pathname *system-directory*) - (cons (ecase type - (:source (car *system-directory*)) - (:binary (cdr *system-directory*))))))) - (pathname - (make-pathname - :name (string-downcase (string name)) - :type extension - :defaults directory :version :newest))) - - #+Genera - (setq pathname (zl:send pathname :new-raw-name (pathname-name pathname)) - pathname (zl:send pathname :new-raw-type (pathname-type pathname))) - - pathname)) - - - -;;; *** SITE SPECIFIC CLOS DIRECTORY *** -;;; -;;; *clos-directory* is a variable which specifies the directory clos is stored -;;; in at your site. If the value of the variable is a single pathname, the -;;; sources and binaries should be stored in that directory. If the value of -;;; that directory is a cons, the CAR should be the source directory and the -;;; CDR should be the binary directory. -;;; -;;; By default, the value of *clos-directory* is set to the directory that -;;; this file is loaded from. This makes it simple to keep multiple copies -;;; of CLOS in different places, just load defsys from the same directory as -;;; the copy of CLOS you want to use. -;;; -;;; Note that the value of *CLOS-DIRECTORY* is set using a DEFVAR. This is -;;; done to make it possible for users to set it in their init file and then -;;; load this file. The value set in the init file will override the value -;;; here. -;;; -;;; *** *** - -(defun load-truename (&optional (errorp nil)) - (flet ((bad-time () - (when errorp - (error "LOAD-TRUENAME called but a file isn't being loaded.")))) - #+Lispm (or sys:fdefine-file-pathname (bad-time)) - #+excl excl::*source-pathname* - #+Xerox (pathname (or (il:fullname *standard-input*) (bad-time))) - #+(and dec vax common) (truename (sys::source-file #'load-truename)) - ;; - ;; The following use of `lucid::' is a kludge for 2.1 and 3.0 - ;; compatibility. In 2.1 it was in the SYSTEM package, and i - ;; 3.0 it's in the LUCID-COMMON-LISP package. - ;; - #+LUCID (or lucid::*source-pathname* (bad-time)) - #-(or Lispm excl Xerox (and dec vax common) LUCID) nil)) - -#-Symbolics -(defvar *clos-directory* - (or (load-truename t) - (error "Because load-truename is not implemented in this port~%~ - of CLOS, you must manually edit the definition of the~%~ - variable *clos-directory* in the file defsys.lisp."))) - -#+Genera -(defvar *clos-directory* - (let ((source (load-truename t))) - (flet ((subdir (name) - (scl:send source :new-pathname :raw-directory - (append (scl:send source :raw-directory) - (list name))))) - (cons source - #+genera-release-7-2 (subdir "rel-7-2") - #+genera-release-7-3 (subdir "rel-7-3") - #+genera-release-7-4 (subdir "rel-7-4") - #+genera-release-8-0 (subdir "rel-8-0") - #+genera-release-8-1 (subdir "rel-8-1") - )))) - -#+Cloe-Runtime -(defvar *clos-directory* (pathname "/usr3/hornig/clos/")) - -(defsystem clos - *clos-directory* - ;; - ;; file load compile files which port - ;; environment environment force the of - ;; recompilation - ;; of this file - ;; - ( - (patch t t () xerox) - (pkg t t ()) - (walk (pkg) (pkg) ()) - (iterate t t ()) - (macros t t ()) - (low (pkg macros) t (macros)) - (low2 (low) (low) (low) Xerox) - (fin t t (low)) - (defclass t t (low)) - (defs t t (defclass macros iterate)) - (fngen t t (low)) - (lap t t (low)) - (plap t t (low)) - (cache t t (low defs)) - (dlap t t (defs low fin cache lap)) - (boot t t (defs fin)) - (vector t t (boot defs cache fin)) - (slots t t (vector boot defs low cache fin)) - (init t t (vector boot defs low cache fin)) - (std-class t t (vector boot defs low cache fin slots)) - (cpl t t (vector boot defs low cache fin slots)) - (braid t t (boot defs low fin cache)) - (fsc t t (defclass boot defs low fin cache)) - (methods t t (defclass boot defs low fin cache)) - (combin t t (defclass boot defs low fin cache)) - (dfun t t (dlap)) - (fixup (+ precom1 precom2 precom4) t (boot defs low fin)) - (defcombin t t (defclass boot defs low fin)) - (ctypes t t (defclass defcombin)) - (construct t t (defclass boot defs low)) - (env t t (defclass boot defs low fin)) - (compat t t ()) - (precom1 (dlap) t (defs low cache fin dfun)) - (precom2 (dlap) t (defs low cache fin dfun)) - (precom4 (dlap) t (defs low cache fin dfun)) - )) - -(defun compile-clos (&optional m) - (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) - #+Lucid (lcl:*redefinition-action* nil) - #+excl (excl::*redefinition-warnings* nil) - #+Genera (sys:inhibit-fdefine-warnings t) - ) - (cond ((null m) (operate-on-system 'clos :compile)) - ((eq m :print) (operate-on-system 'clos :compile () t)) - ((eq m :query) (operate-on-system 'clos :query-compile)) - ((eq m :confirm) (operate-on-system 'clos :confirm-compile)) - ((eq m 't) (operate-on-system 'clos :recompile)) - ((listp m) (operate-on-system 'clos :compile-from m)) - ((symbolp m) (operate-on-system 'clos :recompile-some `(,m)))))) - -(defun load-clos (&optional m) - (let (#+:coral(ccl::*warn-if-redefine-kernel* nil) - #+Lucid (lcl:*redefinition-action* nil) - #+excl (excl::*redefinition-warnings* nil) - #+Genera (sys:inhibit-fdefine-warnings t) - ) - (cond ((null m) (operate-on-system 'clos :load)) - ((eq m :query) (operate-on-system 'clos :query-load))) - (pushnew :clos *features*))) - -#+Genera -;;; Make sure Genera bug mail contains the CLOS bug data. A little -;;; kludgy, but what the heck. If they didn't mean for people to do -;;; this, they wouldn't have made private patch notes be flavored -;;; objects, right? Right. -(progn - (scl:defflavor clos-private-patch-info ((description)) ()) - (scl:defmethod (sct::private-patch-info-description clos-private-patch-info) () - (or description - (setf description (string-append "CLOS version: " *clos-system-date*)))) - (scl:defmethod (sct::private-patch-info-pathname clos-private-patch-info) () - *clos-directory*) - (unless (find-if #'(lambda (x) (typep x 'clos-private-patch-info)) - sct::*private-patch-info*) - (push (scl:make-instance 'clos-private-patch-info) - sct::*private-patch-info*))) - -(defun bug-report-info (&optional (stream *standard-output*)) - (format stream "~&CLOS system date: ~A~ - ~&Lisp Implementation type: ~A~ - ~&Lisp Implementation version: ~A~ - ~&*features*: ~S" - *clos-system-date* - (lisp-implementation-type) - (lisp-implementation-version) - *features*)) - - - -;;;; -;;; -;;; This stuff is not intended for external use. -;;; -(defun rename-clos () - (dolist (f (cadr (get-system 'clos))) - (let ((old nil) - (new nil)) - (let ((*system-directory* *default-pathname-defaults*)) - (setq old (make-source-pathname (car f)))) - (setq new (make-source-pathname (car f))) - (rename-file old new)))) - -#+Genera -(defun edit-clos () - (dolist (f (cadr (get-system 'clos))) - (let ((*system-directory* *clos-directory*)) - (zwei:find-file (make-source-pathname (car f)))))) - -#+Genera -(defun hardcopy-clos (&optional query-p) - (let ((files (mapcar #'(lambda (f) - (setq f (car f)) - (and (or (not query-p) - (y-or-n-p "~A? " f)) - f)) - (cadr (get-system 'clos)))) - (b zwei:*interval*)) - (unwind-protect - (dolist (f files) - (when f - (multiple-value-bind (ignore b) - (zwei:find-file (make-source-pathname f)) - (zwei:hardcopy-buffer b)))) - (zwei:make-buffer-current b)))) - - -;;; -;;; unido!ztivax!dae@seismo.css.gov -;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet -;;; Victor@carmen.uu.se -;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET -;;; -#+Genera -(defun mail-clos (to) - (let* ((original-buffer zwei:*interval*) - (*system-directory* (pathname "vaxc:/user/ftp/pub/clos/") - ;(funcall (car (get-system 'clos))) - ) - (files (list* 'defsys - 'test - (caddr (get-system 'clos)))) - (total-number (length files)) - (file nil) - (number-of-lines 0) - (i 0) - (mail-buffer nil)) - (unwind-protect - (loop - (when (null files) (return nil)) - (setq file (pop files)) - (incf i) - (multiple-value-bind (ignore b) - (zwei:find-file (make-source-pathname file)) - (setq number-of-lines (zwei:count-lines b)) - (zwei:com-mail-internal t - :initial-to to - :initial-body b - :initial-subject - (format nil - "CLOS file ~A (~A of ~A) ~D lines" - file i total-number number-of-lines)) - (setq mail-buffer zwei:*interval*) - (zwei:com-exit-com-mail) - (format t "~&Just sent ~A (~A of ~A)." b i total-number) - (zwei:kill-buffer mail-buffer))) - (zwei:make-buffer-current original-buffer)))) - - diff --git a/obsolete/clos/2.0/dfun.lisp b/obsolete/clos/2.0/dfun.lisp deleted file mode 100644 index 1e958a30..00000000 --- a/obsolete/clos/2.0/dfun.lisp +++ /dev/null @@ -1,606 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - -;;;. Copyright (c) 1991 by Venue - -(in-package "CLOS") - - - ; ************************************************************************ - ; temporary for data gathering - ; temporary for data gathering - ; ************************************************************************ - - -(defvar *dfun-states* (make-hash-table :test #'eq)) - -(defun notice-dfun-state (generic-function state &optional nkeys valuep) - (setf (gethash generic-function *dfun-states*) - (cons state (when nkeys (list nkeys valuep))))) - - - ; ************************************************************************ - ; temporary for data gathering - ; temporary for data gathering - ; ************************************************************************ - - -(defvar *dfun-constructors* nil) - - ; An alist in which each entry is of - ; the form ( . ( - ; ...)) Each subentry is of the form: - ; ( ) - - -(defvar *enable-dfun-constructor-caching* t) - - ; If this is NIL, then the whole - ; mechanism for caching dfun - ; constructors is turned off. The only - ; time that makes sense is when - ; debugging LAP code. - - -(defun show-dfun-constructors nil (format t "~&DFUN constructor caching is ~A." (if - *enable-dfun-constructor-caching* - "enabled" - "disabled")) - (dolist (generator-entry *dfun-constructors*) - (dolist (args-entry (cdr generator-entry)) - (format t "~&~S ~S" (cons (car generator-entry) - (caar args-entry)) - (caddr args-entry))))) - -(defun get-dfun-constructor (generator &rest args) - (let* ((generator-entry (assq generator *dfun-constructors*)) - (args-entry (assoc args (cdr generator-entry) - :test - #'equal))) - (if (null *enable-dfun-constructor-caching*) - (apply (symbol-function generator) - args) - (or (cadr args-entry) - (let ((new (apply (symbol-function generator) - args))) - (if generator-entry - (push (list (copy-list args) - new nil) - (cdr generator-entry)) - (push (list generator (list (copy-list args) - new nil)) - *dfun-constructors*)) - new))))) - -(defun load-precompiled-dfun-constructor (generator args system constructor) - (let* ((generator-entry (assq generator *dfun-constructors*)) - (args-entry (assoc args (cdr generator-entry) - :test - #'equal))) - (unless args-entry - (if generator-entry - (push (list args constructor system) - (cdr generator-entry)) - (push (list generator (list args constructor system)) - *dfun-constructors*))))) - -(defmacro - precompile-dfun-constructors - (&optional system) - (let - ((*precompiling-lap* t)) - `(progn - ,@(gathering1 (collecting) - (dolist (generator-entry *dfun-constructors*) - (dolist (args-entry (cdr generator-entry)) - (when (or (null (caddr args-entry)) - (eq (caddr args-entry) - system)) - (multiple-value-bind (closure-variables arguments iregs vregs tregs lap) - (apply (symbol-function (car generator-entry)) - (car args-entry)) - (gather1 (make-top-level-form `(precompile-dfun-constructor - ,(car generator-entry)) - '(load) - `(load-precompiled-dfun-constructor - ',(car generator-entry) - ',(car args-entry) - ',system - (precompile-lap-closure-generator ,closure-variables - ,arguments - ,iregs - ,vregs - ,tregs - ,lap)))))))))))) - -(defun make-initial-dfun (generic-function) - #'(lambda (&rest args) - (initial-dfun args generic-function))) - - -;;; When all the methods of a generic function are automatically generated reader or writer methods -;;; a number of special optimizations are possible. These are important because of the large number -;;; of generic functions of this type. There are a number of cases: ONE-CLASS-ACCESSOR In this case, -;;; the accessor generic function has only been called with one class of argument. There is no -;;; cache vector, the wrapper of the one class, and the slot index are stored directly as closure -;;; variables of the discriminating function. This case can convert to either of the next kind. -;;; TWO-CLASS-ACCESSOR Like above, but two classes. This is common enough to do specially. There is -;;; no cache vector. The two classes are stored a separate closure variables. ONE-INDEX-ACCESSOR In -;;; this case, the accessor generic function has seen more than one class of argument, but the index -;;; of the slot is the same for all the classes that have been seen. A cache vector is used to -;;; store the wrappers that have been seen, the slot index is stored directly as a closure variable -;;; of the discriminating function. This case can convert to the next kind. N-N-ACCESSOR This is -;;; the most general case. In this case, the accessor generic function has seen more than one class -;;; of argument and more than one slot index. A cache vector stores the wrappers and corresponding -;;; slot indexes. Because each cache line is more than one element long, a cache lock count is -;;; used. ONE-CLASS-ACCESSOR - - -(defun update-to-one-class-readers-dfun (generic-function wrapper index) - (let ((constructor (get-dfun-constructor 'emit-one-class-reader (consp index)))) - (notice-dfun-state generic-function `(one-class readers ,(consp index))) - ; *** - (update-dfun generic-function (funcall constructor wrapper index - #'(lambda (arg) - (declare (clos-fast-call)) - (one-class-readers-miss arg - generic-function index wrapper)))))) - -(defun update-to-one-class-writers-dfun (generic-function wrapper index) - (let ((constructor (get-dfun-constructor 'emit-one-class-writer (consp index)))) - (notice-dfun-state generic-function `(one-class writers ,(consp index))) - ; *** - (update-dfun generic-function (funcall constructor wrapper index - #'(lambda (new-value arg) - (declare (clos-fast-call)) - (one-class-writers-miss new-value arg - generic-function index wrapper)))))) - -(defun one-class-readers-miss (arg generic-function index wrapper) - (accessor-miss generic-function 'one-class 'reader nil arg index wrapper nil nil nil)) - -(defun one-class-writers-miss (new arg generic-function index wrapper) - (accessor-miss generic-function 'one-class 'writer new arg index wrapper nil nil nil)) - - -;;; TWO-CLASS-ACCESSOR - - -(defun update-to-two-class-readers-dfun (generic-function wrapper-0 wrapper-1 index) - (let ((constructor (get-dfun-constructor 'emit-two-class-reader (consp index)))) - (notice-dfun-state generic-function `(two-class readers ,(consp index))) - ; *** - (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index - #'(lambda (arg) - (declare (clos-fast-call)) - (two-class-readers-miss arg - generic-function index wrapper-0 - wrapper-1)))))) - -(defun update-to-two-class-writers-dfun (generic-function wrapper-0 wrapper-1 index) - (let ((constructor (get-dfun-constructor 'emit-two-class-writer (consp index)))) - (notice-dfun-state generic-function `(two-class writers ,(consp index))) - ; *** - (update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index - #'(lambda (new-value arg) - (declare (clos-fast-call)) - (two-class-writers-miss new-value arg - generic-function index wrapper-0 - wrapper-1)))))) - -(defun two-class-readers-miss (arg generic-function index w0 w1) - (accessor-miss generic-function 'two-class 'reader nil arg index w0 w1 nil nil)) - -(defun two-class-writers-miss (new arg generic-function index w0 w1) - (accessor-miss generic-function 'two-class 'writer new arg index w0 w1 nil nil)) - - -;;; std accessors same index dfun - - -(defun update-to-one-index-readers-dfun (generic-function index &optional field cache) - (unless field - (setq field (wrapper-field 'number))) - (let ((constructor (get-dfun-constructor 'emit-one-index-readers (consp index)))) - (multiple-value-bind (mask size) - (compute-cache-parameters 1 nil (or cache 4)) - (unless cache - (setq cache (get-cache size))) - (notice-dfun-state generic-function `(one-index readers ,(consp index))) - ; *** - (update-dfun generic-function (funcall constructor field cache mask size index - #'(lambda (arg) - (declare (clos-fast-call)) - (one-index-readers-miss arg - generic-function index field cache - ))) - cache)))) - -(defun update-to-one-index-writers-dfun (generic-function index &optional field cache) - (unless field - (setq field (wrapper-field 'number))) - (let ((constructor (get-dfun-constructor 'emit-one-index-writers (consp index)))) - (multiple-value-bind (mask size) - (compute-cache-parameters 1 nil (or cache 4)) - (unless cache - (setq cache (get-cache size))) - (notice-dfun-state generic-function `(one-index writers ,(consp index))) - ; *** - (update-dfun generic-function (funcall constructor field cache mask size index - #'(lambda (new-value arg) - (declare (clos-fast-call)) - (one-index-writers-miss new-value arg - generic-function index field cache - ))) - cache)))) - -(defun one-index-readers-miss (arg gf index field cache) - (accessor-miss gf 'one-index 'reader nil arg index nil nil field cache)) - -(defun one-index-writers-miss (new arg gf index field cache) - (accessor-miss gf 'one-index 'writer new arg index nil nil field cache)) - -(defun one-index-limit-fn (nlines) - (default-limit-fn nlines)) - -(defun update-to-n-n-readers-dfun (generic-function &optional field cache) - (unless field - (setq field (wrapper-field 'number))) - (let ((constructor (get-dfun-constructor 'emit-n-n-readers))) - (multiple-value-bind (mask size) - (compute-cache-parameters 1 t (or cache 2)) - (unless cache - (setq cache (get-cache size))) - (notice-dfun-state generic-function `(n-n readers)) - ; *** - (update-dfun generic-function (funcall constructor field cache mask size - #'(lambda (arg) - (declare (clos-fast-call)) - (n-n-readers-miss arg generic-function - field cache))) - cache)))) - -(defun update-to-n-n-writers-dfun (generic-function &optional field cache) - (unless field - (setq field (wrapper-field 'number))) - (let ((constructor (get-dfun-constructor 'emit-n-n-writers))) - (multiple-value-bind (mask size) - (compute-cache-parameters 1 t (or cache 2)) - (unless cache - (setq cache (get-cache size))) - (notice-dfun-state generic-function `(n-n writers)) - ; *** - (update-dfun generic-function (funcall constructor field cache mask size - #'(lambda (new arg) - (declare (clos-fast-call)) - (n-n-writers-miss new arg - generic-function field cache))) - cache)))) - -(defun n-n-readers-miss (arg gf field cache) - (accessor-miss gf 'n-n 'reader nil arg nil nil nil field cache)) - -(defun n-n-writers-miss (new arg gf field cache) - (accessor-miss gf 'n-n 'writer new arg nil nil nil field cache)) - -(defun n-n-accessors-limit-fn (nlines) - (default-limit-fn nlines)) - - -;;; - - -(defun update-to-checking-dfun (generic-function function &optional field cache) - (unless field - (setq field (wrapper-field 'number))) - (let* ((arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (nkeys (arg-info-nkeys arg-info))) - (if (every #'(lambda (mt) - (eq mt 't)) - metatypes) - (progn (notice-dfun-state generic-function `(default-method-only)) - ; *** - (update-dfun generic-function function)) - (multiple-value-bind (mask size) - (compute-cache-parameters nkeys nil (or cache 2)) - (unless cache - (setq cache (get-cache size))) - (let ((constructor (get-dfun-constructor 'emit-checking metatypes applyp))) - (notice-dfun-state generic-function '(checking) - nkeys nil) - ; **** - (update-dfun generic-function - (funcall constructor field cache mask size function - #'(lambda (&rest args) - (declare (clos-fast-call)) - (checking-miss generic-function args function field - cache))) - cache)))))) - -(defun checking-limit-fn (nlines) - (default-limit-fn nlines)) - - -;;; - - -(defun update-to-caching-dfun (generic-function &optional field cache) - (unless field - (setq field (wrapper-field 'number))) - (let* ((arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info)) - (nkeys (arg-info-nkeys arg-info)) - (constructor (get-dfun-constructor 'emit-caching metatypes applyp))) - (multiple-value-bind (mask size) - (compute-cache-parameters nkeys t (or cache 2)) - (unless cache - (setq cache (get-cache size))) - (notice-dfun-state generic-function '(caching) - nkeys t) - ; **** - (update-dfun generic-function (funcall constructor field cache mask size - #'(lambda (&rest args) - (declare (clos-fast-call)) - (caching-miss generic-function args - field cache))) - cache)))) - -(defun caching-limit-fn (nlines) - (default-limit-fn nlines)) - - -;;; The dynamically adaptive method lookup algorithm is implemented is implemented as a kind of -;;; state machine. The kinds of discriminating function is the state, the various kinds of reasons -;;; for a cache miss are the state transitions. The code which implements the transitions is all in -;;; the miss handlers for each kind of dfun. Those appear here. Note that within the states that -;;; cache, there are dfun updates which simply select a new cache or cache field. Those are not -;;; considered as state transitions. - - -(defun initial-dfun (args generic-function) - (protect-cache-miss-code generic-function args - (multiple-value-bind (wrappers invalidp nfunction applicable) - (cache-miss-values generic-function args) - (multiple-value-bind (ntype nindex) - (accessor-miss-values generic-function applicable args) - (cond ((null applicable) - (apply #'no-applicable-method generic-function args)) - (invalidp (apply nfunction args)) - ((and ntype nindex) - (ecase ntype - (reader (update-to-one-class-readers-dfun generic-function wrappers - nindex)) - (writer (update-to-one-class-writers-dfun generic-function wrappers - nindex))) - (apply nfunction args)) - (ntype (apply nfunction args)) - (t (update-to-checking-dfun generic-function nfunction) - (apply nfunction args))))))) - -(defun - accessor-miss - (gf ostate otype new object oindex ow0 ow1 field cache) - (declare (ignore ow1)) - (let ((args (ecase otype ; The congruence rules assure - (reader (list object)) ; us that this is safe despite - (writer (list new object))))) - ; not knowing the new type yet. - (protect-cache-miss-code - gf args - (multiple-value-bind (wrappers invalidp nfunction applicable) - (cache-miss-values gf args) - (multiple-value-bind (ntype nindex) - (accessor-miss-values gf applicable args) - - ;; The following lexical functions change the state of the dfun to that which is their - ;; name. They accept arguments which are the parameters of the new state, and get other - ;; information from the lexical variables bound above. - (flet ((two-class (index w0 w1) - (when (zerop (random 2)) - (psetf w0 w1 w1 w0)) - (ecase ntype - (reader (update-to-two-class-readers-dfun gf w0 w1 index)) - (writer (update-to-two-class-writers-dfun gf w0 w1 index)))) - (one-index (index &optional field cache) - (ecase ntype - (reader (update-to-one-index-readers-dfun gf index field cache)) - (writer (update-to-one-index-writers-dfun gf index field cache)))) - (n-n (&optional field cache) - (ecase ntype - (reader (update-to-n-n-readers-dfun gf field cache)) - (writer (update-to-n-n-writers-dfun gf field cache)))) - (checking nil (update-to-checking-dfun gf nfunction)) - - ;; - (do-fill (valuep limit-fn update-fn) - (multiple-value-bind (nfield ncache) - (fill-cache field cache 1 valuep limit-fn wrappers nindex) - (unless (and (= nfield field) - (eq ncache cache)) - (funcall update-fn nfield ncache))))) - (cond ((null nfunction) - (apply #'no-applicable-method gf args)) - ((null ntype) - (checking) - (apply nfunction args)) - ((or invalidp (null nindex)) - (apply nfunction args)) - ((not (or (std-instance-p object) - (fsc-instance-p object))) - (checking) - (apply nfunction args)) - ((neq ntype otype) - (checking) - (apply nfunction args)) - (t (ecase ostate - (one-class (if (eql nindex oindex) - (two-class nindex ow0 wrappers) - (n-n))) - (two-class (if (eql nindex oindex) - (one-index nindex) - (n-n))) - (one-index (if (eql nindex oindex) - (do-fill nil #'one-index-limit-fn - #'(lambda (nfield ncache) - (one-index nindex nfield ncache))) - (n-n))) - (n-n (unless (consp nindex) - (do-fill t #'n-n-accessors-limit-fn #'n-n)))) - (apply nfunction args))))))))) - -(defun checking-miss (generic-function args ofunction field cache) - (protect-cache-miss-code generic-function args - (let* ((arg-info (gf-arg-info generic-function)) - (nkeys (arg-info-nkeys arg-info))) - (multiple-value-bind (wrappers invalidp nfunction) - (cache-miss-values generic-function args) - (cond (invalidp (apply nfunction args)) - ((null nfunction) - (apply #'no-applicable-method generic-function args)) - ((eq ofunction nfunction) - (multiple-value-bind (nfield ncache) - (fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil) - (unless (and (= nfield field) - (eq ncache cache)) - (update-to-checking-dfun generic-function nfunction nfield - ncache))) - (apply nfunction args)) - (t (update-to-caching-dfun generic-function) - (apply nfunction args))))))) - -(defun caching-miss (generic-function args ofield ocache) - (protect-cache-miss-code generic-function args - (let* ((arg-info (gf-arg-info generic-function)) - (nkeys (arg-info-nkeys arg-info))) - (multiple-value-bind (wrappers invalidp function) - (cache-miss-values generic-function args) - (cond (invalidp (apply function args)) - ((null function) - (apply #'no-applicable-method generic-function args)) - (t (multiple-value-bind (nfield ncache) - (fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers - function) - (unless (and (= nfield ofield) - (eq ncache ocache)) - (update-to-caching-dfun generic-function nfield ncache))) - (apply function args))))))) - - -;;; Some useful support functions which are shared by the implementations of the different kinds of -;;; dfuns. Given a generic function and a set of arguments to that generic function, returns a mess -;;; of values. Is a single wrapper if the generic function has only one key, that is -;;; arg-info-nkeys of the arg-info is 1. Otherwise a list of the wrappers of the specialized -;;; arguments to the generic function. Note that all these wrappers are valid. This function does -;;; invalid wrapper traps when it finds an invalid wrapper and then returns the new, valid wrapper. -;;; True if any of the specialized arguments had an invalid wrapper, false otherwise. -;;; The compiled effective method function for this set of arguments. Gotten from -;;; get-secondary-dispatch-function so effective-method-function caching is in effect, and that is -;;; important since it is what keeps us in checking dfun state when possible. READER or -;;; WRITER when the only method that would be run is a standard reader or writer method. To be -;;; specific, the value is READER when the method combination is eq to -;;; *standard-method-combination*; there are no applicable :before, :after or :around methods; and -;;; the most specific primary method is a standard reader method. If is READER -;;; or WRITER, and the slot accessed is an :instance slot, this is the index number of that slot in -;;; the object argument. Sorted list of applicable methods. - - -(defun cache-miss-values (generic-function args) - (declare (values wrappers invalidp function applicable)) - (multiple-value-bind (function appl arg-info) - (get-secondary-dispatch-function generic-function args) - (multiple-value-bind (wrappers invalidp) - (get-wrappers generic-function args arg-info) - (values wrappers invalidp (cache-miss-values-function generic-function function) - appl)))) - -(defun get-wrappers (generic-function args &optional arg-info) - (let* ((invalidp nil) - (wrappers nil) - (arg-info (or arg-info (gf-arg-info generic-function))) - (metatypes (arg-info-metatypes arg-info)) - (nkeys (arg-info-nkeys arg-info))) - (flet ((get-valid-wrapper (x) - (let ((wrapper (wrapper-of x))) - (cond ((invalid-wrapper-p wrapper) - (setq invalidp t) - (check-wrapper-validity x)) - (t wrapper))))) - (setq wrappers (block collect-wrappers - (gathering1 (collecting) - (iterate ((arg (list-elements args)) - (metatype (list-elements metatypes))) - (when (neq metatype 't) - (if (= nkeys 1) - (return-from collect-wrappers - (get-valid-wrapper arg)) - (gather1 (get-valid-wrapper arg)))))))) - (values wrappers invalidp)))) - -(defun cache-miss-values-function (generic-function function) - (if (eq *generate-random-code-segments* generic-function) - (progn (setq *generate-random-code-segments* nil) - #'(lambda (&rest args) - (declare (ignore args)) - nil)) - function)) - -(defun generate-random-code-segments (generic-function) - (dolist (arglist (generate-arglists generic-function)) - (let ((*generate-random-code-segments* generic-function)) - (apply generic-function arglist)))) - -(defun generate-arglists (generic-function) - - ;; Generate arglists using class-prototypes and eql-specializer-objects to get all the - ;; "different" values that could be returned by get-secondary-dispatch-function for this - ;; generic-function. - (let ((methods (generic-function-methods generic-function))) - (mapcar #'(lambda (class-list) - (mapcar #'(lambda (specializer) - (if (eql-specializer-p specializer) - (eql-specializer-object specializer) - (class-prototype specializer))) - (method-specializers (find class-list methods :test - #'(lambda (class-list method) - (every - #' - specializer-applicable-using-class-p - (method-specializers - method) - class-list)))))) - (generate-arglist-classes generic-function)))) - -(defun generate-arglist-classes (generic-function) - (let ((methods (generic-function-methods generic-function))) - (declare (ignore methods)) - - ;; Finish this sometime. - nil)) - -(defun accessor-miss-values (generic-function applicable args) - (declare (values type index)) - (let ((type (and (eq (generic-function-method-combination generic-function) - *standard-method-combination*) - (every #'(lambda (m) - (null (method-qualifiers m))) - applicable) - (let ((method (car applicable))) - (cond ((standard-reader-method-p method) - (and (optimize-slot-value-by-class-p (class-of (car args)) - (accessor-method-slot-name method) - nil) - 'reader)) - ((standard-writer-method-p method) - (and (optimize-slot-value-by-class-p (class-of (cadr args)) - (accessor-method-slot-name method) - t) - 'writer)) - (t nil)))))) - (values type (and type (let ((wrapper (wrapper-of (case type - (reader (car args)) - (writer (cadr args))))) - (slot-name (accessor-method-slot-name (car applicable)))) - (or (instance-slot-index wrapper slot-name) - (assq slot-name (wrapper-class-slots wrapper)))))))) diff --git a/obsolete/clos/2.0/dlap.lisp b/obsolete/clos/2.0/dlap.lisp deleted file mode 100644 index e50f0bb8..00000000 --- a/obsolete/clos/2.0/dlap.lisp +++ /dev/null @@ -1,492 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - -;;; Copyright (c) 1991 by Venue - -(in-package "CLOS") - -;;; - -(defun emit-one-class-reader (class-slot-p) - (emit-reader/writer :reader 1 class-slot-p)) - -(defun emit-one-class-writer (class-slot-p) - (emit-reader/writer :writer 1 class-slot-p)) - -(defun emit-two-class-reader (class-slot-p) - (emit-reader/writer :reader 2 class-slot-p)) - -(defun emit-two-class-writer (class-slot-p) - (emit-reader/writer :writer 2 class-slot-p)) - -(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p) - (let ((instance nil) - (arglist nil) - (closure-variables nil) - (field (wrapper-field 'number))) - ; we need some field to do the fast - ; obsolete check - (ecase reader/writer - (:reader (setq instance (dfun-arg-symbol 0) - arglist - (list instance))) - (:writer (setq instance (dfun-arg-symbol 1) - arglist - (list (dfun-arg-symbol 0) - instance)))) - (ecase 1-or-2-class - (1 (setq closure-variables '(wrapper-0 index miss-fn))) - (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn)))) - (generating-lap - closure-variables arglist - (with-lap-registers ((inst t) - ; reg for the instance - (wrapper vector) - ; reg for the wrapper - (cache-no index)) - ; reg for the cache no - (let ((index cache-no) - ; This register is used for different - ; values at different times. - (slots (and (null class-slot-p) - (allocate-register 'vector))) - (csv (and class-slot-p (allocate-register t)))) - (prog1 (flatten-lap (opcode :move (operand :arg instance) - inst) - ; get the instance - (opcode :std-instance-p inst 'std-instance) - ; if not either std-inst - (opcode :fsc-instance-p inst 'fsc-instance) - ; or fsc-instance then - (opcode :go 'trap) - ; we lose - (opcode :label 'fsc-instance) - (opcode :move (operand :fsc-wrapper inst) - wrapper) - (and slots (opcode :move (operand :fsc-slots inst) - slots)) - (opcode :go 'have-wrapper) - (opcode :label 'std-instance) - (opcode :move (operand :std-wrapper inst) - wrapper) - (and slots (opcode :move (operand :std-slots inst) - slots)) - (opcode :label 'have-wrapper) - (opcode :move (operand :cref wrapper field) - cache-no) - (opcode :izerop cache-no 'trap) - ; obsolete wrapper? - (ecase 1-or-2-class - (1 (emit-check-1-class-wrapper wrapper 'wrapper-0 - 'trap)) - (2 (emit-check-2-class-wrapper wrapper 'wrapper-0 - 'wrapper-1 - 'trap))) - (if class-slot-p - (flatten-lap (opcode :move (operand :cvar 'index) - csv) - (ecase reader/writer - (:reader (emit-get-class-slot csv 'trap inst)) - (:writer (emit-set-class-slot csv (car arglist) - inst)))) - (flatten-lap (opcode :move (operand :cvar 'index) - index) - (ecase reader/writer - (:reader (emit-get-slot slots index - 'trap inst)) - (:writer (emit-set-slot slots index - (car arglist) - inst))))) - (opcode :label 'trap) - (emit-miss 'miss-fn)) - (when slots (deallocate-register slots)) - (when csv (deallocate-register csv)))))))) - -(defun emit-one-index-readers (class-slot-p) - (let ((arglist (list (dfun-arg-symbol 0)))) - (generating-lap '(field cache mask size index miss-fn) - arglist - (with-lap-registers ((slots vector)) - (emit-dlap arglist '(standard-instance) - 'trap - (with-lap-registers ((index index)) - (flatten-lap (opcode :move (operand :cvar 'index) - index) - (if class-slot-p - (emit-get-class-slot index 'trap slots) - (emit-get-slot slots index 'trap)))) - (flatten-lap (opcode :label 'trap) - (emit-miss 'miss-fn)) - nil - (and (null class-slot-p) - (list slots))))))) - -(defun emit-one-index-writers (class-slot-p) - (let ((arglist (list (dfun-arg-symbol 0) - (dfun-arg-symbol 1)))) - (generating-lap '(field cache mask size index miss-fn) - arglist - (with-lap-registers ((slots vector)) - (emit-dlap arglist '(t standard-instance) - 'trap - (with-lap-registers ((index index)) - (flatten-lap (opcode :move (operand :cvar 'index) - index) - (if class-slot-p - (emit-set-class-slot index (dfun-arg-symbol 0) - slots) - (emit-set-slot slots index (dfun-arg-symbol 0))))) - (flatten-lap (opcode :label 'trap) - (emit-miss 'miss-fn)) - nil - (and (null class-slot-p) - (list nil slots))))))) - -(defun emit-n-n-readers nil (let ((arglist (list (dfun-arg-symbol 0)))) - (generating-lap '(field cache mask size miss-fn) - arglist - (with-lap-registers ((slots vector) - (index index)) - (emit-dlap arglist '(standard-instance) - 'trap - (emit-get-slot slots index 'trap) - (flatten-lap (opcode :label 'trap) - (emit-miss 'miss-fn)) - index - (list slots)))))) - -(defun emit-n-n-writers nil (let ((arglist (list (dfun-arg-symbol 0) - (dfun-arg-symbol 1)))) - (generating-lap '(field cache mask size miss-fn) - arglist - (with-lap-registers ((slots vector) - (index index)) - (flatten-lap (emit-dlap arglist '(t standard-instance) - 'trap - (emit-set-slot slots index - (dfun-arg-symbol 0)) - (flatten-lap (opcode :label - 'trap) - (emit-miss 'miss-fn)) - index - (list nil slots))))))) - -(defun emit-checking (metatypes applyp) - (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) - (generating-lap '(field cache mask size function miss-fn) - dlap-lambda-list - (emit-dlap (remove '&rest dlap-lambda-list) - metatypes - 'trap - (with-lap-registers (#'t) - (flatten-lap (opcode :move (operand :cvar 'function) - function) - (opcode :jmp function))) - (with-lap-registers ((miss-function t)) - (flatten-lap (opcode :label 'trap) - (opcode :move (operand :cvar 'miss-fn) - miss-function) - (opcode :jmp miss-function))) - nil)))) - -(defun emit-caching (metatypes applyp) - (let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))) - (generating-lap '(field cache mask size miss-fn) - dlap-lambda-list - (with-lap-registers (#'t) - (emit-dlap (remove '&rest dlap-lambda-list) - metatypes - 'trap - (flatten-lap (opcode :jmp function)) - (with-lap-registers ((miss-function t)) - (flatten-lap (opcode :label 'trap) - (opcode :move (operand :cvar 'miss-fn) - miss-function) - (opcode :jmp miss-function))) - function))))) - -(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label) - (with-lap-registers ((cwrapper vector)) - (flatten-lap (opcode :move (operand :cvar cwrapper-0) - cwrapper) - (opcode :neq wrapper cwrapper miss-label)))) - - ; wrappers not eq, trap - - -(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label) - (with-lap-registers ((cwrapper vector)) - (flatten-lap (opcode :move (operand :cvar cwrapper-0) - cwrapper) - ; This is an OR. Isn't - (opcode :eq wrapper cwrapper 'hit-internal) - ; assembly code fun - (opcode :move (operand :cvar cwrapper-1) - cwrapper) - ; - (opcode :neq wrapper cwrapper miss-label) - ; - (opcode :label 'hit-internal)))) - -(defun emit-get-slot (slots index trap-label &optional temp) - (let ((slot-unbound (operand :constant *slot-unbound*))) - (with-lap-registers ((val t :reuse temp)) - (flatten-lap (opcode :move (operand :iref slots index) - val) - ; get slot value - (opcode :eq val slot-unbound trap-label) - ; is the slot unbound? - (opcode :return val))))) - - ; return the slot value - - -(defun emit-set-slot (slots index new-value-arg &optional temp) - (with-lap-registers ((new-val t :reuse temp)) - (flatten-lap (opcode :move (operand :arg new-value-arg) - new-val) - ; get new value into a reg - (opcode :move new-val (operand :iref slots index)) - ; set slot value - (opcode :return new-val)))) - -(defun emit-get-class-slot (index trap-label &optional temp) - (let ((slot-unbound (operand :constant *slot-unbound*))) - (with-lap-registers ((val t :reuse temp)) - (flatten-lap (opcode :move (operand :cdr index) - val) - (opcode :eq val slot-unbound trap-label) - (opcode :return val))))) - -(defun emit-set-class-slot (index new-value-arg &optional temp) - (with-lap-registers ((new-val t :reuse temp)) - (flatten-lap (opcode :move (operand :arg new-value-arg) - new-val) - (opcode :move new-val (operand :cdr index)) - (opcode :return new-val)))) - -(defun emit-miss (miss-fn) - (with-lap-registers ((miss-fn-reg t)) - (flatten-lap (opcode :move (operand :cvar miss-fn) - miss-fn-reg) - ; get the miss function - (opcode :jmp miss-fn-reg)))) - - ; and call it - - -(defun dlap-wrappers (metatypes) - (mapcar #'(lambda (x) - (and (neq x 't) - (allocate-register 'vector))) - metatypes)) - -(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs) - (gathering1 (collecting) - (iterate ((mt (list-elements metatypes)) - (arg (list-elements args)) - (wrapper (list-elements wrappers)) - (i (interval :from 0))) - (when wrapper - (gather1 (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs))))) - )) - -(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs) - (let* ((wrappers (dlap-wrappers metatypes)) - (nwrappers (remove nil wrappers)) - (wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs))) - (prog1 (emit-dlap-internal nwrappers wrapper-moves hit miss miss-label value-reg) - (mapc #'deallocate-register nwrappers)))) - -(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg) - (cond ((cdr wrapper-regs) - (emit-greater-than-1-dlap wrapper-regs wrapper-moves hit miss miss-label value-reg)) - ((null value-reg) - (emit-1-nil-dlap (car wrapper-regs) - (car wrapper-moves) - hit miss miss-label)) - (t (emit-1-t-dlap (car wrapper-regs) - (car wrapper-moves) - hit miss miss-label value-reg)))) - -(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label) - (with-lap-registers ((location index) - (primary index) - (cache vector)) - (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache) - cache) - (with-lap-registers ((wrapper-cache-no index)) - (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper - primary wrapper-cache-no) - (opcode :move primary location) - (emit-check-1-wrapper-in-cache cache location wrapper hit) - ; inline hit code - (opcode :izerop wrapper-cache-no miss-label))) - (with-lap-registers ((size index)) - (flatten-lap (opcode :move (operand :cvar 'size) - size) - (opcode :label 'loop) - (opcode :move (operand :i1+ location) - location) - (opcode :fix= location primary miss-label) - (opcode :fix= location size 'set-location-to-min) - (opcode :label 'continue) - (emit-check-1-wrapper-in-cache cache location wrapper hit) - (opcode :go 'loop) - (opcode :label 'set-location-to-min) - (opcode :izerop primary miss-label) - (opcode :move (operand :constant (index-value->index 0)) - location) - (opcode :go 'continue))) - miss))) - - -;;; The function below implements CACHE-LOCK-COUNT as the first entry in a cache (svref cache 0). -;;; This should probably be abstracted. - - -(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value) - (with-lap-registers ((location index) - (primary index) - (cache vector) - (initial-lock-count t)) - (flatten-lap wrapper-move (opcode :move (operand :cvar 'cache) - cache) - (with-lap-registers ((wrapper-cache-no index)) - (flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper - primary wrapper-cache-no) - (opcode :move primary location) - (opcode :move (operand :cref cache 0) - initial-lock-count) - ; get lock-count - (emit-check-cache-entry cache location wrapper 'hit-internal) - (opcode :izerop wrapper-cache-no miss-label))) - ; check for obsolescence - (with-lap-registers ((size index)) - (flatten-lap (opcode :move (operand :cvar 'size) - size) - (opcode :label 'loop) - (opcode :move (operand :i1+ location) - location) - (opcode :move (operand :i1+ location) - location) - (opcode :label 'continue) - (opcode :fix= location primary miss-label) - (opcode :fix= location size 'set-location-to-min) - (emit-check-cache-entry cache location wrapper 'hit-internal) - (opcode :go 'loop) - (opcode :label 'set-location-to-min) - (opcode :izerop primary miss-label) - (opcode :move (operand :constant (index-value->index 2)) - location) - (opcode :go 'continue))) - (opcode :label 'hit-internal) - (opcode :move (operand :i1+ location) - location) - ; position for getting value - (opcode :move (emit-cache-ref cache location) - value) - (emit-lock-count-test initial-lock-count cache 'hit) - miss - (opcode :label 'hit) - hit))) - -(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value) - (let ((cache-line-size (compute-line-size (+ (length wrappers) - (if value - 1 - 0))))) - (with-lap-registers ((location index) - (primary index) - (cache vector) - (initial-lock-count t) - (next-location index) - (line-size index)) - ; Line size holds a constant that can - ; be folded in if there was a way to - ; add a constant to an index register - (flatten-lap (apply #'flatten-lap wrapper-moves) - (opcode :move (operand :constant cache-line-size) - line-size) - (opcode :move (operand :cvar 'cache) - cache) - (emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label) - (opcode :move primary location) - (opcode :move location next-location) - (opcode :move (operand :cref cache 0) - initial-lock-count) - ; get the lock-count - (with-lap-registers ((size index)) - (flatten-lap (opcode :move (operand :cvar 'size) - size) - (opcode :label 'continue) - (opcode :move (operand :i+ location line-size) - next-location) - (emit-check-cache-line cache location wrappers 'hit) - (emit-adjust-location location next-location primary size - 'continue miss-label) - (opcode :label 'hit) - (and value (opcode :move (emit-cache-ref cache location) - value)) - (emit-lock-count-test initial-lock-count cache 'hit-internal) - miss - (opcode :label 'hit-internal) - hit)))))) - - -;;; Cache related lap code - - -(defun emit-check-1-wrapper-in-cache (cache location wrapper hit-code) - (let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache"))) - (with-lap-registers ((cwrapper vector)) - (flatten-lap (opcode :move (emit-cache-ref cache location) - cwrapper) - (opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache) - hit-code - (opcode :label exit-emit-check-1-wrapper-in-cache))))) - -(defun emit-check-cache-entry (cache location wrapper hit-label) - (with-lap-registers ((cwrapper vector)) - (flatten-lap (opcode :move (emit-cache-ref cache location) - cwrapper) - (opcode :eq cwrapper wrapper hit-label)))) - -(defun emit-check-cache-line (cache location wrappers hit-label) - (let ((checks (flatten-lap (gathering1 (flattening-lap) - (iterate ((wrapper (list-elements wrappers))) - (with-lap-registers ((cwrapper vector)) - (gather1 (flatten-lap (opcode :move - (emit-cache-ref - cache location) - cwrapper) - (opcode :neq cwrapper wrapper - - ' - exit-emit-check-cache-line - ) - (opcode :move (operand :i1+ - location) - location))))))))) - (flatten-lap checks (opcode :go hit-label) - (opcode :label 'exit-emit-check-cache-line)))) - -(defun emit-lock-count-test (initial-lock-count cache hit-label) - - ;; jumps to hit-label if cache-lock-count consistent, otherwise, continues - (with-lap-registers ((new-lock-count t)) - (flatten-lap (opcode :move (operand :cref cache 0) - new-lock-count) - ; get new cache-lock-count - (opcode :fix= new-lock-count initial-lock-count hit-label)))) - -(defun emit-adjust-location (location next-location primary size cont-label miss-label) - (flatten-lap (opcode :move next-location location) - (opcode :fix= location size 'at-end-of-cache) - (opcode :fix= location primary miss-label) - (opcode :go cont-label) - (opcode :label 'at-end-of-cache) - (opcode :fix= primary (operand :constant (index-value->index 1)) - miss-label) - (opcode :move (operand :constant (index-value->index 1)) - location) - (opcode :go cont-label))) diff --git a/obsolete/clos/2.0/env.lisp b/obsolete/clos/2.0/env.lisp deleted file mode 100644 index 15bf87f2..00000000 --- a/obsolete/clos/2.0/env.lisp +++ /dev/null @@ -1,200 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; Basic environmental stuff. -;;; - -(in-package 'clos) - - - -;;; -;;; -;;; - -(defgeneric describe-object (object stream)) - - -(defmethod describe-object ((object standard-object) stream) - (let* ((class (class-of object)) - (slotds (slots-to-inspect class object)) - (max-slot-name-length 0) - (instance-slotds ()) - (class-slotds ()) - (other-slotds ())) - (flet ((adjust-slot-name-length (name) - (setq max-slot-name-length - (max max-slot-name-length - (length (the string (symbol-name name)))))) - (describe-slot (name value &optional (allocation () alloc-p)) - (if alloc-p - (format stream - "~% ~A ~S ~VT ~S" - name allocation (+ max-slot-name-length 7) value) - (format stream - "~% ~A~VT ~S" - name max-slot-name-length value)))) - ;; Figure out a good width for the slot-name column. - (dolist (slotd slotds) - (adjust-slot-name-length (slotd-name slotd)) - (case (slotd-allocation slotd) - (:instance (push slotd instance-slotds)) - (:class (push slotd class-slotds)) - (otherwise (push slotd other-slotds)))) - (setq max-slot-name-length (min (+ max-slot-name-length 3) 30)) - (format stream "~%~S is an instance of class ~S:" object class) - - (when instance-slotds - (format stream "~% The following slots have :INSTANCE allocation:") - (dolist (slotd (nreverse instance-slotds)) - (describe-slot (slotd-name slotd) - (slot-value-or-default object (slotd-name slotd))))) - - (when class-slotds - (format stream "~% The following slots have :CLASS allocation:") - (dolist (slotd (nreverse class-slotds)) - (describe-slot (slotd-name slotd) - (slot-value-or-default object (slotd-name slotd))))) - - (when other-slotds - (format stream "~% The following slots have allocation as shown:") - (dolist (slotd (nreverse other-slotds)) - (describe-slot (slotd-name slotd) - (slot-value-or-default object (slotd-name slotd)) - (slotd-allocation slotd)))) - (values)))) - -(defmethod slots-to-inspect ((class std-class) (object standard-object)) - (class-slots class)) - -;;; -;;; -;;; -(defmethod describe-object ((class class) stream) - (flet ((pretty-class (c) (or (class-name c) c))) - (macrolet ((ft (string &rest args) `(format stream ,string ,@args))) - (ft "~&~S is a class, it is an instance of ~S.~%" - class (pretty-class (class-of class))) - (let ((name (class-name class))) - (if name - (if (eq class (find-class name nil)) - (ft "Its proper name is ~S.~%" name) - (ft "Its name is ~S, but this is not a proper name.~%" name)) - (ft "It has no name (the name is NIL).~%"))) - (ft "The direct superclasses are: ~:S, and the direct~%~ - subclasses are: ~:S. The class precedence list is:~%~S~%~ - There are ~D methods specialized for this class." - (mapcar #'pretty-class (class-direct-superclasses class)) - (mapcar #'pretty-class (class-direct-subclasses class)) - (mapcar #'pretty-class (class-precedence-list class)) - (length (specializer-methods class)))))) - - - -;;; -;;; trace-method and untrace-method accept method specs as arguments. A -;;; method-spec should be a list like: -;;; ( qualifiers* (specializers*)) -;;; where should be either a symbol or a list -;;; of (SETF ). -;;; -;;; For example, to trace the method defined by: -;;; -;;; (defmethod foo ((x spaceship)) 'ss) -;;; -;;; You should say: -;;; -;;; (trace-method '(foo (spaceship))) -;;; -;;; You can also provide a method object in the place of the method -;;; spec, in which case that method object will be traced. -;;; -;;; For untrace-method, if an argument is given, that method is untraced. -;;; If no argument is given, all traced methods are untraced. -;;; -(defclass traced-method (method) - ((method :initarg :method) - (function :initarg :function - :reader method-function) - (generic-function :initform nil - :accessor method-generic-function))) - -(defmethod method-lambda-list ((m traced-method)) - (with-slots (method) m (method-lambda-list method))) - -(defmethod method-specializers ((m traced-method)) - (with-slots (method) m (method-specializers method))) - -(defmethod method-qualifiers ((m traced-method)) - (with-slots (method) m (method-qualifiers method))) - -(defmethod method-qualifiers ((m traced-method)) - (with-slots (method) m (method-qualifiers method))) - -(defmethod accessor-method-slot-name ((m traced-method)) - (with-slots (method) m (accessor-method-slot-name method))) - -(defvar *traced-methods* ()) - -(defun trace-method (spec &rest options) - (multiple-value-bind (gf omethod name) - (parse-method-or-spec spec) - (let* ((tfunction (trace-method-internal (method-function omethod) - name - options)) - (tmethod (make-instance 'traced-method - :method omethod - :function tfunction))) - (remove-method gf omethod) - (add-method gf tmethod) - (pushnew tmethod *traced-methods*) - tmethod))) - -(defun untrace-method (&optional spec) - (flet ((untrace-1 (m) - (let ((gf (method-generic-function m))) - (when gf - (remove-method gf m) - (add-method gf (slot-value m 'method)) - (setq *traced-methods* (remove m *traced-methods*)))))) - (if (not (null spec)) - (multiple-value-bind (gf method) - (parse-method-or-spec spec) - (declare (ignore gf)) - (if (memq method *traced-methods*) - (untrace-1 method) - (error "~S is not a traced method?" method))) - (dolist (m *traced-methods*) (untrace-1 m))))) - -(defun trace-method-internal (ofunction name options) - (eval `(untrace ,name)) - (setf (symbol-function name) ofunction) - (eval `(trace ,name ,@options)) - (symbol-function name)) - - - - -;(defun compile-method (spec) -; (multiple-value-bind (gf method name) -; (parse-method-or-spec spec) -; (declare (ignore gf)) -; (compile name (method-function method)) -; (setf (method-function method) (symbol-function name)))) - -(defmacro undefmethod (&rest args) - #+(or (not :lucid) :lcl3.0) - (declare (arglist name {method-qualifier}* specializers)) - `(undefmethod-1 ',args)) - -(defun undefmethod-1 (args) - (multiple-value-bind (gf method) - (parse-method-or-spec args) - (when (and gf method) - (remove-method gf method) - method))) - diff --git a/obsolete/clos/2.0/fin.lisp b/obsolete/clos/2.0/fin.lisp deleted file mode 100644 index c8de5102..00000000 --- a/obsolete/clos/2.0/fin.lisp +++ /dev/null @@ -1,235 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;; File converted on 26-Mar-91 10:33:34 from source fin -;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>fin.;3 created 19-Feb-91 16:21:49 - -;;;. Copyright (c) 1991 by Venue - - - - -(in-package "CLOS") - -;;; Shadow, Export, Require, Use-package, and Import forms should follow here - - - - - - -;; - - - -;;; FUNCALLABLE INSTANCES - - - -;; - - - -;;; The first part of the file contains the implementation dependent code to implement funcallable -;;; instances. Each implementation must provide the following functions and macros: -;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () should create and return a new funcallable instance. The -;;; funcallable-instance-data slots must be initialized to NIL. This is called by -;;; allocate-funcallable-instance and by the bootstrapping code. FUNCALLABLE-INSTANCE-P (x) the -;;; obvious predicate. This should be an INLINE function. it must be funcallable, but it would be -;;; nice if it compiled open. SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) change the fin so -;;; that when it is funcalled, the new-value function is called. Note that it is legal for -;;; new-value to be copied before it is installed in the fin, specifically there is no accessor for -;;; a FIN's function so this function does not have to preserve the actual new value. The new-value -;;; argument can be any funcallable thing, a closure, lambda compiled code etc. This function must -;;; coerce those values if necessary. NOTE: new-value is almost always a compiled closure. This is -;;; the important case to optimize. FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) should return the -;;; value of the data named data-name in the fin. data-name is one of the symbols in the list which -;;; is the value of funcallable-instance-data. Since data-name is almost always a quoted symbol and -;;; funcallable-instance-data is a constant, it is possible (and worthwhile) to optimize the -;;; computation of data-name's offset in the data part of the fin. This must be SETF'able. - - -(defconstant funcallable-instance-data '(wrapper slots) - "These are the 'data-slots' which funcallable instances have so that - the meta-class funcallable-standard-class can store class, and static - slots in them.") - -(defmacro funcallable-instance-data-position (data) - (if (and (consp data) - (eq (car data) - 'quote) - (boundp 'funcallable-instance-data)) - (or (position (cadr data) - funcallable-instance-data :test #'eq) - (progn (warn "Unknown funcallable-instance data: ~S." (cadr data)) - `(error "Unknown funcallable-instance data: ~S." ',(cadr data)))) - `(position ,data funcallable-instance-data :test #'eq))) - -(defun called-fin-without-function nil (error "Attempt to funcall a funcallable-instance without first~%~ - setting its funcallable-instance-function.")) - - -;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and CCODEP. The environment -;;; is represented as a block. There is space in the top 8 bits of the pointers to the CCODE and -;;; the environment to use to mark the closure as being a FIN. To help the debugger figure out when -;;; it has found a FIN on the stack, we reserve the last element of the closure environment to use -;;; to point back to the actual fin. Note that there is code in xerox-low which lets us access the -;;; fields of compiled-closures and which defines the closure-overlay record. That code is there -;;; because there are some clients of it in that file. - - - -;; Don't be fooled. We actually allocate one bigger than this to have a place to store the -;; backpointer to the fin. -smL - - -(defconstant funcallable-instance-closure-size 15) - -(defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) - t))) - - -;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL - - -(defstruct fin-env-pointer (pointer nil :type il:fullxpointer)) - -(defun fin-env-fin (fin-env) - (fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2)))) - -(defun |set fin-env-fin| (fin-env new-value) - (il:\\rplptr fin-env (* funcallable-instance-closure-size 2) - (make-fin-env-pointer :pointer new-value)) - new-value) - -(defsetf fin-env-fin |set fin-env-fin|) - - -;; The finalization function that will clean up the backpointer from the fin-env to the fin. This -;; needs to be careful to not cons at all. This depends on there being no other finalization -;; function on compiled-closures, since there is only one finalization function per datatype. Too -;; bad. -smL - - -(defun finalize-fin (fin) - - ;; This could use the fn funcallable-instance-p, but if we get here we know that this is a - ;; closure, so we can skip that test. - (when (il:fetch (closure-overlay funcallable-instance-p) - il:of fin) - (let ((env (il:fetch (il:compiled-closure il:environment) - il:of fin))) - (when env - (setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2))) - (when (typep env 'fin-env-pointer) - (setf (fin-env-pointer-pointer env) - nil))))) - nil) - -(eval-when (load) - - ;; Install the above finalization function. - (when (fboundp 'finalize-fin) - (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin))) - -(defun allocate-funcallable-instance-1 nil (let* ((env (il:\\allocblock (1+ - funcallable-instance-closure-size - ) - t)) - (fin (il:make-compiled-closure nil env))) - (setf (fin-env-fin env) - fin) - (il:replace (closure-overlay funcallable-instance-p) - il:of fin il:with 't) - (set-funcallable-instance-function - fin - #'(lambda (&rest ignore) - (declare (ignore ignore)) - (called-fin-without-function))) - fin)) - -(xcl:definline funcallable-instance-p (x) - (and (typep x 'il:compiled-closure) - (il:fetch (closure-overlay funcallable-instance-p) - il:of x))) - -(defun set-funcallable-instance-function (fin new) - (cond ((not (funcallable-instance-p fin)) - (error "~S is not a funcallable-instance" fin)) - ((not (functionp new)) - (error "~S is not a function." new)) - ((typep new 'il:compiled-closure) - (let* ((fin-env (il:fetch (il:compiled-closure il:environment) - il:of fin)) - (new-env (il:fetch (il:compiled-closure il:environment) - il:of new)) - (new-env-size (if new-env - (il:\\#blockdatacells new-env) - 0)) - (fin-env-size (- funcallable-instance-closure-size (length - funcallable-instance-data - )))) - (cond ((and new-env (<= new-env-size fin-env-size)) - (dotimes (i fin-env-size) - (il:\\rplptr fin-env (* i 2) - (if (< i new-env-size) - (il:\\getbaseptr new-env (* i 2)) - nil))) - (setf (compiled-closure-fnheader fin) - (compiled-closure-fnheader new))) - (t (set-funcallable-instance-function fin (make-trampoline new)))))) - (t (set-funcallable-instance-function fin (make-trampoline new))))) - -(defun make-trampoline (function) - #'(lambda (&rest args) - (apply function args))) - -(defmacro funcallable-instance-data-1 (fin data) - `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) - il:of - ,fin) - (* (- funcallable-instance-closure-size (funcallable-instance-data-position - ,data) - 1) - ; Reserve last element to point back to - ; actual FIN! - 2))) - -(defsetf funcallable-instance-data-1 (fin data) - (new-value) - `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) - il:of - ,fin) - (* (- funcallable-instance-closure-size (funcallable-instance-data-position - ,data) - 1) - 2) - ,new-value)) - - ; end of #+Xerox - - - -;;; - - -(defmacro fsc-instance-p (fin) - `(funcallable-instance-p ,fin)) - -(defmacro fsc-instance-class (fin) - `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper))) - -(defmacro fsc-instance-wrapper (fin) - `(funcallable-instance-data-1 ,fin 'wrapper)) - -(defmacro fsc-instance-slots (fin) - `(funcallable-instance-data-1 ,fin 'slots)) - -(defun allocate-funcallable-instance (wrapper number-of-static-slots) - (let ((fin (allocate-funcallable-instance-1)) - (slots (%allocate-static-slot-storage--class number-of-static-slots))) - (setf (fsc-instance-wrapper fin) - wrapper - (fsc-instance-slots fin) - slots) - fin)) diff --git a/obsolete/clos/2.0/fixup.lisp b/obsolete/clos/2.0/fixup.lisp deleted file mode 100644 index 13d1c52c..00000000 --- a/obsolete/clos/2.0/fixup.lisp +++ /dev/null @@ -1,15 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;;. Copyright (c) 1991 by Venue - -(in-package "CLOS") - - -(eval-when (compile load eval) - (fix-early-generic-functions) - (setq *boot-state* 'complete)) - -(defun print-std-instance (instance stream depth) - (declare (ignore depth)) - (print-object instance stream)) diff --git a/obsolete/clos/2.0/fngen.lisp b/obsolete/clos/2.0/fngen.lisp deleted file mode 100644 index 09e6d0da..00000000 --- a/obsolete/clos/2.0/fngen.lisp +++ /dev/null @@ -1,172 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - -;;;. Copyright (c) 1991 by Venue - -(in-package "CLOS") - - - -;;; GET-FUNCTION is the main user interface to this code. If it is called with a lambda expression -;;; only, it will return a corresponding function. The optional constant-converter argument, can be -;;; a function which will be called to convert each constant appearing in the lambda to whatever -;;; value should appear in the function. Whether the returned function is actually compiled depends -;;; on whether the compiler is present (see COMPILE-LAMBDA) and whether this shape of code was -;;; precompiled. - - -(defun get-function (lambda &optional (test-converter #'default-test-converter) - (code-converter #'default-code-converter) - (constant-converter #'default-constant-converter)) - (apply (get-function-generator lambda test-converter code-converter) - (compute-constants lambda constant-converter))) - -(defun default-test-converter (form) - (if (not (constantp form)) - form - '.constant.)) - -(defun default-code-converter (form) - (if (not (constantp form)) - form - (let ((gensym (gensym))) - (values gensym (list gensym))))) - -(defun default-constant-converter (form) - (and (constantp form) - (list (if (and (consp form) - (eq (car form) - 'quote)) - ; This had better - (cadr form) - ; do the same as - form)))) - - ; EVAL would have. - - - -;;; *fgens* is a list of all the function generators we have so far. Each element is a FGEN -;;; structure as implemented below. Don't ever touch this list by hand, use STORE-FGEN. - - -(defvar *fgens* nil) - -(defun store-fgen (fgen) - (setq *fgens* (nconc *fgens* (list fgen)))) - -(defun lookup-fgen (test) - (find test (the list *fgens*) - :key - #'fgen-test :test #'equal)) - -(defun make-fgen (test gensyms generator generator-lambda system) - (let ((new (make-array 6))) - (setf (svref new 0) - test - (svref new 1) - gensyms - (svref new 2) - generator - (svref new 3) - generator-lambda - (svref new 4) - system) - new)) - -(defun fgen-test (fgen) - (svref fgen 0)) - -(defun fgen-gensyms (fgen) - (svref fgen 1)) - -(defun fgen-generator (fgen) - (svref fgen 2)) - -(defun fgen-generator-lambda (fgen) - (svref fgen 3)) - -(defun fgen-system (fgen) - (svref fgen 4)) - -(defun get-function-generator (lambda test-converter code-converter) - (let* ((test (compute-test lambda test-converter)) - (fgen (lookup-fgen test))) - (if fgen - (fgen-generator fgen) - (get-new-function-generator lambda test code-converter)))) - -(defun get-new-function-generator (lambda test code-converter) - (multiple-value-bind (gensyms generator-lambda) - (get-new-function-generator-internal lambda code-converter) - (let* ((generator (compile-lambda generator-lambda)) - (fgen (make-fgen test gensyms generator generator-lambda nil))) - (store-fgen fgen) - generator))) - -(defun get-new-function-generator-internal (lambda code-converter) - (multiple-value-bind (code gensyms) - (compute-code lambda code-converter) - (values gensyms `(lambda ,gensyms #',code)))) - -(defun compute-test (lambda test-converter) - (walk-form lambda nil #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((converted (funcall test-converter f))) - (values converted (neq converted f))))))) - -(defun compute-code (lambda code-converter) - (let ((gensyms nil)) - (values (walk-form lambda nil #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (multiple-value-bind - (converted gens) - (funcall code-converter f) - (when gens - (setq gensyms (append gensyms gens))) - (values converted (neq converted f)))))) - gensyms))) - -(defun compute-constants (lambda constant-converter) - (macrolet ((appending nil `(let ((result nil)) - (values #'(lambda (value) - (setq result (append result value))) - #'(lambda nil result))))) - (gathering1 (appending) - (walk-form lambda nil #'(lambda (f c e) - (declare (ignore e)) - (if (neq c :eval) - f - (let ((consts (funcall constant-converter f)) - ) - (if consts - (progn (gather1 consts) - (values f t)) - f)))))))) - - -;;; - - -(defmacro - precompile-function-generators - (&optional system) - (make-top-level-form - `(precompile-function-generators ,system) - '(load) - `(progn ,@(gathering1 (collecting) - (dolist (fgen *fgens*) - (when (or (null (fgen-system fgen)) - (eq (fgen-system fgen) - system)) - (gather1 `(load-function-generator ',(fgen-test fgen) - ',(fgen-gensyms fgen) - #',(fgen-generator-lambda fgen) - ',(fgen-generator-lambda fgen) - ',system)))))))) - -(defun load-function-generator (test gensyms generator generator-lambda system) - (store-fgen (make-fgen test gensyms generator generator-lambda system))) diff --git a/obsolete/clos/2.0/fsc.lisp b/obsolete/clos/2.0/fsc.lisp deleted file mode 100644 index a2670af9..00000000 --- a/obsolete/clos/2.0/fsc.lisp +++ /dev/null @@ -1,72 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - -;;;. Copyright (c) 1991 by Venue - - -(in-package "CLOS") - - -;;; This file contains the -;;; definition of the FUNCALLABLE-STANDARD-CLASS metaclass. Much of the implementation of this -;;; metaclass is actually defined on the class STD-CLASS. What appears in this file is a modest -;;; number of simple methods related to the low-level differences in the implementation of standard -;;; and funcallable-standard instances. As it happens, none of these differences are the ones -;;; reflected in the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS share all -;;; their specified methods at STD-CLASS. workings of this metaclass and the standard-class -;;; metaclass. - - -(defmethod wrapper-fetcher ((class funcallable-standard-class)) - 'fsc-instance-wrapper) - -(defmethod slots-fetcher ((class funcallable-standard-class)) - 'fsc-instance-slots) - -(defmethod raw-instance-allocator ((class funcallable-standard-class)) - 'allocate-funcallable-instance-1) - - -;;; - - -(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class) - (class standard-class)) - (null (wrapper-instance-slots-layout (class-wrapper class)))) - -(defmethod allocate-instance ((class funcallable-standard-class) - &rest initargs) - (declare (ignore initargs)) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (let ((class-wrapper (class-wrapper class))) - (allocate-funcallable-instance class-wrapper (class-no-of-instance-slots class)))) - -(defmethod make-reader-method-function ((class funcallable-standard-class) - slot-name) - (make-std-reader-method-function slot-name)) - -(defmethod make-writer-method-function ((class funcallable-standard-class) - slot-name) - (make-std-writer-method-function slot-name)) - - ; See the comment about - ; reader-function--std and - ; writer-function--sdt. - ; (define-function-template - ; reader-function--fsc () '(slot-name) - ; `(function (lambda (instance) - ; (slot-value-using-class - ; (wrapper-class (get-wrapper - ; instance)) instance slot-name)))) - ; (define-function-template - ; writer-function--fsc () '(slot-name) - ; `(function (lambda (nv instance) - ; (setf (slot-value-using-class - ; (wrapper-class (get-wrapper - ; instance)) instance slot-name) nv)))) - ; (eval-when (load) - ; (pre-make-templated-function-constructor - ; reader-function--fsc) - ; (pre-make-templated-function-constructor - ; writer-function--fsc)) - diff --git a/obsolete/clos/2.0/init.lisp b/obsolete/clos/2.0/init.lisp deleted file mode 100644 index d44e50ef..00000000 --- a/obsolete/clos/2.0/init.lisp +++ /dev/null @@ -1,183 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - -;;;. Copyright (c) 1991 by Venue - -(in-package "CLOS") - -;;; this file defines the -;;; initialization and related protocols. - - -(defmethod make-instance ((class std-class) - &rest initargs) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (setq initargs (default-initargs class initargs)) - (when initargs - (when (and (eq *boot-state* 'complete) - (let ((tail initargs)) - (loop (unless tail (return t)) - (when (eq (car tail) - ':allow-other-keys) - (return nil)) - (setq tail (cddr tail))))) - (check-initargs-1 class initargs (append (compute-applicable-methods - #'allocate-instance (list class)) - (compute-applicable-methods - #'initialize-instance - (list (class-prototype class))) - (compute-applicable-methods - #'shared-initialize - (list (class-prototype class) - t)))))) - (let ((instance (apply #'allocate-instance class initargs))) - (apply #'initialize-instance instance initargs) - instance)) - -(defmethod make-instance ((class-name symbol) - &rest initargs) - (apply #'make-instance (find-class class-name) - initargs)) - -(defvar *default-initargs-flag* (list nil)) - -(defmethod default-initargs ((class std-class) - supplied-initargs) - - ;; This implementation of default initargs is critically dependent on all-default-initargs - ;; not having any duplicate initargs in it. - (let ((all-default (class-default-initargs class)) - (miss *default-initargs-flag*)) - (flet ((getf* (plist key) - (do nil - ((null plist) - miss) - (if (eq (car plist) - key) - (return (cadr plist)) - (setq plist (cddr plist)))))) - (labels ((default-1 (tail) - (if (null tail) - nil - (if (eq (getf* supplied-initargs (caar tail)) - miss) - (list* (caar tail) - (funcall (cadar tail)) - (default-1 (cdr tail))) - (default-1 (cdr tail)))))) - (append supplied-initargs (default-1 all-default)))))) - -(defmethod initialize-instance ((instance standard-object) - &rest initargs) - (apply #'shared-initialize instance t initargs)) - -(defmethod reinitialize-instance ((instance standard-object) - &rest initargs) - (when initargs - (when (eq *boot-state* 'complete) - (check-initargs-1 (class-of instance) - initargs - (append (compute-applicable-methods #'reinitialize-instance (list instance)) - (compute-applicable-methods #'shared-initialize (list instance t)))))) - (apply #'shared-initialize instance nil initargs) - instance) - -(defmethod update-instance-for-different-class ((previous standard-object) - (current standard-object) - &rest initargs) - (when initargs - (check-initargs-1 (class-of current) - initargs - (append (compute-applicable-methods #'update-instance-for-different-class - (list previous current)) - (compute-applicable-methods #'shared-initialize (list current t))))) - - ;; First we must compute the newly added slots. The spec defines newly added slots as "those - ;; local slots for which no slot of the same name exists in the previous class." - (let ((added-slots 'nil) - (current-slotds (class-slots (class-of current))) - (previous-slot-names (mapcar #'slotd-name (class-slots (class-of previous))))) - (dolist (slotd current-slotds) - (if (and (not (memq (slotd-name slotd) - previous-slot-names)) - (eq (slotd-allocation slotd) - ':instance)) - (push (slotd-name slotd) - added-slots))) - (apply #'shared-initialize current added-slots initargs))) - -(defmethod update-instance-for-redefined-class ((instance standard-object) - added-slots discarded-slots property-list &rest - initargs) - (declare (ignore discarded-slots property-list)) - (when initargs - (check-initargs-1 (class-of instance) - initargs - (append (compute-applicable-methods #'update-instance-for-redefined-class - (list instance)) - (compute-applicable-methods #'shared-initialize (list instance nil))))) - (apply #'shared-initialize instance added-slots initargs)) - -(defmethod shared-initialize ((instance standard-object) - slot-names &rest initargs) - - ;; initialize the instance's slots in a two step process 1) A slot for which one of the - ;; initargs in initargs can set the slot, should be set by that initarg. If more than one - ;; initarg in initargs can set the slot, the leftmost one should set it. 2) Any slot not set - ;; by step 1, may be set from its initform by step 2. Only those slots specified by the - ;; slot-names argument are set. If slot-names is: T any slot not set in step 1 is set from - ;; its initform any slot in the list, and not set in step 1 is set from - ;; its initform () no slots are set from initforms - (let* ((class (class-of instance)) - (slotds (class-slots class))) - (dolist (slotd slotds) - (let ((slot-name (slotd-name slotd)) - (slot-initargs (slotd-initargs slotd))) - (flet ((from-initargs nil - - ;; Try to initialize the slot from one of the initargs. If we - ;; succeed return T, otherwise return nil. - (doplist (initarg val) - initargs - (when (memq initarg slot-initargs) - (setf (slot-value instance slot-name) - val) - (return 't)))) - (from-initforms nil - - ;; Try to initialize the slot from its initform. This returns - ;; no meaningful value. - (if (and slot-names (or (eq slot-names 't) - (memq slot-name slot-names)) - (not (slot-boundp instance slot-name))) - (let ((initfunction (slotd-initfunction slotd))) - (when initfunction - (setf (slot-value instance slot-name) - (funcall initfunction))))))) - (or (from-initargs) - (from-initforms)))))) - instance) - - -;;; if initargs are valid return nil, otherwise signal an error - - -(defun check-initargs-1 (class initargs methods) - (let ((legal (apply #'append (mapcar #'slotd-initargs (class-slots class))))) - (unless (getf initargs :allow-other-keys) - - ;; Add to the set of slot-filling initargs the set of initargs that are accepted by - ;; the methods. If at any point we come across &allow-other-keys, we can just quit. - (dolist (method methods) - (multiple-value-bind (keys allow-other-keys) - (function-keywords method) - (when allow-other-keys (return-from check-initargs-1 nil)) - (setq legal (append keys legal)))) - - ;; Now check the supplied-initarg-names and the default initargs against the total - ;; set that we know are legal. - (doplist (key val) - initargs - (unless (memq key legal) - (error "Invalid initialization argument ~S for class ~S" key (class-name - class))))))) diff --git a/obsolete/clos/2.0/iterate.lisp b/obsolete/clos/2.0/iterate.lisp deleted file mode 100644 index 212f819c..00000000 --- a/obsolete/clos/2.0/iterate.lisp +++ /dev/null @@ -1,1080 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE ITERATE USE (QUOTE (LISP WALKER))) -BASE 10) -(IL:FILECREATED "19-Feb-91 13:55:29"  -IL:|{DSK}local>users>welch>lisp>clos>rev4>il-format>ITERATE.;2| 65656 - - IL:|changes| IL:|to:| (IL:VARS IL:ITERATECOMS) - - IL:|previous| IL:|date:| " 6-Feb-91 11:00:58" -IL:|{DSK}local>users>welch>lisp>clos>rev4>il-format>ITERATE.;1|) - - -; Copyright (c) 1991 by Venue. All rights reserved. - -(IL:PRETTYCOMPRINT IL:ITERATECOMS) - -(IL:RPAQQ IL:ITERATECOMS - ( - -(IL:* IL:|;;;| "************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 ") - - (IL:P (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER)) - (EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS - LIST-ELEMENTS LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL - COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING *ITERATE-WARNINGS*) - )) - (IL:VARIABLES *ITERATE-WARNINGS*) - - -(IL:* IL:|;;;| "ITERATE macro") - - (IL:FUNCTIONS ITERATE SIMPLE-EXPAND-ITERATE-FORM) - (IL:VARIABLES *ITERATE-TEMP-VARS-LIST*) - (IL:FUNCTIONS OPTIMIZE-ITERATE-FORM EXPAND-INTO-LET VARIABLES-FROM-LET - ITERATE-TRANSFORM-BODY PARSE-DECLARATIONS EXTRACT-SPECIAL-BINDINGS - FUNCTION-LAMBDA-P RENAME-LET-BINDINGS RENAME-VARIABLES MV-SETQ VARIABLE-SAME-P - MAYBE-WARN) - - (IL:* IL:|;;| "Sample iterators") - - (IL:FUNCTIONS INTERVAL LIST-ELEMENTS LIST-TAILS ELEMENTS PLIST-ELEMENTS SEQUENCE-ACCESSOR) - - (IL:* IL:|;;| "These \"iterators\" may be withdrawn") - - (IL:FUNCTIONS EACHTIME WHILE UNTIL) - (IL:* IL:\; "GATHERING macro") - (IL:FUNCTIONS GATHERING WITH-GATHERING SIMPLE-EXPAND-GATHERING-FORM) - (IL:VARIABLES *ACTIVE-GATHERERS* *ANONYMOUS-GATHERING-SITE*) - (IL:FUNCTIONS OPTIMIZE-GATHERING-FORM RENAME-AND-CAPTURE-VARIABLES WALK-GATHERING-BODY) - - (IL:* IL:|;;| "Sample gatherers") - - (IL:FUNCTIONS COLLECTING JOINING MAXIMIZING MINIMIZING SUMMING) - (IL:* IL:\; - "Easier to read expanded code if PROG1 gets left alone ") - (XCL:FILE-ENVIRONMENTS "ITERATE"))) - - - -(IL:* IL:|;;;| -"************************************************************************* Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. All rights reserved. Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws. This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification. Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to: CommonLoops Coordinator Xerox PARC 3333 Coyote Hill Rd. Palo Alto, CA 94304 (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) Suggestions, comments and requests for improvements are also welcome. ************************************************************************* Original source {pooh/n}vanmelle>lisp>iterate;4 created 27-Sep-88 12:35:33 " -) - - -(IN-PACKAGE :ITERATE :USE '(:LISP :WALKER)) - -(EXPORT '(ITERATE ITERATE* GATHERING GATHER WITH-GATHERING INTERVAL ELEMENTS LIST-ELEMENTS - LIST-TAILS PLIST-ELEMENTS EACHTIME WHILE UNTIL COLLECTING JOINING MAXIMIZING - MINIMIZING SUMMING *ITERATE-WARNINGS*)) - -(DEFVAR *ITERATE-WARNINGS* :ANY "Controls whether warnings are issued for iterate/gather forms that aren't optimized. -NIL => never; :USER => those resulting from user code; T => always, even if it's the iteration macro that's suboptimal." -) - - - -(IL:* IL:|;;;| "ITERATE macro") - - -(DEFMACRO ITERATE (CLAUSES &BODY BODY &ENVIRONMENT ENV) - (OPTIMIZE-ITERATE-FORM CLAUSES BODY ENV)) - -(DEFUN SIMPLE-EXPAND-ITERATE-FORM (CLAUSES BODY) - - (IL:* IL:|;;| - "Expand ITERATE. This is the \"formal semantics\" expansion, which we never use. ") - - (LET* - ((BLOCK-NAME (GENSYM)) - (BOUND-VAR-LISTS (MAPCAR #'(LAMBDA (CLAUSE) - (LET ((NAMES (FIRST CLAUSE))) - (IF (LISTP NAMES) - NAMES - (LIST NAMES)))) - CLAUSES)) - (GENERATOR-VARS (MAPCAR #'(LAMBDA (CLAUSE) - (DECLARE (IGNORE CLAUSE)) - (GENSYM)) - CLAUSES))) - `(BLOCK ,BLOCK-NAME - (LET* - ,(MAPCAN #'(LAMBDA (GVAR CLAUSE VAR-LIST) (IL:* IL:\; - "For each clause, bind a generator temp to the clause, then bind the specified var(s) ") - (CONS (LIST GVAR (SECOND CLAUSE)) - (COPY-LIST VAR-LIST))) - GENERATOR-VARS CLAUSES BOUND-VAR-LISTS) - - (IL:* IL:|;;| "Note bug in formal semantics: there can be declarations in the head of BODY; they go here, rather than inside loop ") - - (LOOP ,@(MAPCAR #'(LAMBDA (VAR-LIST GEN-VAR) (IL:* IL:\; - "Set each bound variable (or set of vars) to the result of calling the corresponding generator ") - `(MULTIPLE-VALUE-SETQ ,VAR-LIST - (FUNCALL ,GEN-VAR #'(LAMBDA NIL (RETURN-FROM ,BLOCK-NAME)) - ))) - BOUND-VAR-LISTS GENERATOR-VARS) - ,@BODY))))) - -(DEFPARAMETER *ITERATE-TEMP-VARS-LIST* '(ITERATE-TEMP-1 ITERATE-TEMP-2 ITERATE-TEMP-3 - ITERATE-TEMP-4 ITERATE-TEMP-5 ITERATE-TEMP-6 - ITERATE-TEMP-7 ITERATE-TEMP-8) - "Temp var names used by ITERATE expansions.") - -(DEFUN OPTIMIZE-ITERATE-FORM (CLAUSES BODY ITERATE-ENV) - (LET* - ((TEMP-VARS *ITERATE-TEMP-VARS-LIST*) - (BLOCK-NAME (GENSYM)) - (FINISH-FORM `(RETURN-FROM ,BLOCK-NAME)) - (BOUND-VARS (MAPCAN #'(LAMBDA (CLAUSE) - (LET ((NAMES (FIRST CLAUSE))) - (IF (LISTP NAMES) - (COPY-LIST NAMES) - (LIST NAMES)))) - CLAUSES)) - ITERATE-DECLS GENERATOR-DECLS UPDATE-FORMS BINDINGS LEFTOVER-BODY) - (DO ((TAIL BOUND-VARS (CDR TAIL))) - ((NULL TAIL)) (IL:* IL:\; "Check for duplicates") - (WHEN (MEMBER (CAR TAIL) - (CDR TAIL)) - (WARN "Variable appears more than once in ITERATE: ~S" (CAR TAIL)))) - (FLET - ((GET-ITERATE-TEMP NIL - - (IL:* IL:|;;| "Make temporary var. Note that it is ok to re-use these symbols in each iterate, because they are not used within BODY. ") - - (OR (POP TEMP-VARS) - (GENSYM)))) - (DOLIST (CLAUSE CLAUSES) - (COND - ((OR (NOT (CONSP CLAUSE)) - (NOT (CONSP (CDR CLAUSE)))) - (WARN "Bad syntax in ITERATE: clause not of form (var iterator): ~S" CLAUSE)) - (T - (UNLESS (NULL (CDDR CLAUSE)) - (WARN "Probable parenthesis error in ITERATE clause--more than 2 elements: ~S" - CLAUSE)) - (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS - EXTRA-BODY) - (EXPAND-INTO-LET (SECOND CLAUSE) - 'ITERATE ITERATE-ENV) - - (IL:* IL:|;;| - "We have expanded the generator clause and parsed it into its LET pieces. ") - - (PROG* ((VARS (FIRST CLAUSE)) - GEN-ARGS RENAMED-VARS) - (SETQ VARS (IF (LISTP VARS) - (COPY-LIST VARS) - (LIST VARS))) (IL:* IL:\; - "VARS is now a (fresh) list of all iteration vars bound in this clause ") - (COND - ((EQ LET-BODY :ABORT) (IL:* IL:\; - "Already issued a warning about malformedness ") - ) - ((NULL (SETQ LET-BODY (FUNCTION-LAMBDA-P LET-BODY 1))) - (IL:* IL:\; "Not of the expected form") - (LET ((GENERATOR (SECOND CLAUSE))) - (COND - ((AND (CONSP GENERATOR) - (FBOUNDP (CAR GENERATOR))) - (IL:* IL:\; "It looks ok--a macro or function here--so the guy who wrote it just didn't do it in an optimizable way ") - (MAYBE-WARN :DEFINITION "Could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))" - GENERATOR)) - (T (IL:* IL:\; - "Perhaps it's just a misspelling? Probably user error ") - (MAYBE-WARN :USER - "Iterate operator in clause ~S is not fboundp." GENERATOR - ))) - (SETQ LET-BODY :ABORT))) - (T - - (IL:* IL:|;;| "We have something of the form #'(LAMBDA (finisharg) ...), possibly with some LET bindings around it. LET-BODY = ((finisharg) ...). ") - - (SETQ LET-BODY (CDR LET-BODY)) - (SETQ GEN-ARGS (POP LET-BODY)) - (WHEN LET-BINDINGS - - (IL:* IL:|;;| "The first transformation we want to perform is \"LET-eversion\": turn (let* ((generator (let (..bindings..) #'(lambda ...)))) ..body..) into (let* (..bindings.. (generator #'(lambda ...))) ..body..). This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var). Of course, none of those vars can be special, but we already checked for that above. ") - - (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS) - (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE ITERATE-ENV - LEFTOVER-BODY #'GET-ITERATE-TEMP)) - (SETQ LEFTOVER-BODY NIL) (IL:* IL:\; - "If there was any leftover from previous, it is now consumed ") - ) - - (IL:* IL:|;;| "The second transformation is substituting the body of the generator (LAMBDA (finish-arg) . gen-body) for its appearance in the update form (funcall generator #'(lambda () finish-form)), then simplifying that form. The requirement for this part is that the generator body not refer to any variables that are bound between the generator binding and the appearance in the loop body. The only variables bound in that interval are generator temporaries, which have unique names so are no problem, and the iteration variables remaining for subsequent clauses. We'll discover the story as we walk the body. ") - - (MULTIPLE-VALUE-BIND (FINISHDECL OTHER REST) - (PARSE-DECLARATIONS LET-BODY GEN-ARGS) - (DECLARE (IGNORE FINISHDECL))(IL:* IL:\; "Pull out declares, if any, separating out the one(s) referring to the finish arg, which we will throw away ") - (WHEN OTHER (IL:* IL:\; - "Combine remaining decls with decls extracted from the LET, if any ") - (SETQ OTHERDECLS (NCONC OTHERDECLS OTHER))) - (SETQ LET-BODY (COND - (OTHERDECLS (IL:* IL:\; - "There are interesting declarations, so have to keep it wrapped. ") - `(LET NIL (DECLARE ,@OTHERDECLS) - ,@REST)) - ((NULL (CDR REST)) - (IL:* IL:\; "Only one form left") - (FIRST REST)) - (T `(PROGN ,@REST))))) - (UNLESS (EQ (SETQ LET-BODY (ITERATE-TRANSFORM-BODY LET-BODY ITERATE-ENV - RENAMED-VARS (FIRST GEN-ARGS) - FINISH-FORM BOUND-VARS CLAUSE)) - :ABORT) - - (IL:* IL:|;;| "Skip the rest if transformation failed. Warning has already been issued. Note possible further optimization: if LET-BODY expanded into (prog1 oldvalue prepare-for-next-iteration), as so many do, then we could in most cases split the PROG1 into two pieces: do the (setq var oldvalue) here, and do the prepare-for-next-iteration at the bottom of the loop. This does a slight optimization of the PROG1 and also rearranges the code in a way that a reasonably clever compiler might detect how to get rid of redundant variables altogether (such as happens with INTERVAL and LIST-TAILS); that would make the whole thing closer to what you might have coded by hand. However, to do this optimization, we need to assure that (a) the prepare-for-next-iteration refers freely to no vars other than the internal vars we have extracted from the LET, and (b) that the code has no side effects. These are both true for all the iterators defined by this module, but how shall we represent side-effect info and/or tap into the compiler's knowledge of same? ") - - (WHEN LOCALDECLS (IL:* IL:\; "There were declarations for the generator locals--have to keep them for later, and rename the vars mentioned ") - (SETQ - GENERATOR-DECLS - (NCONC - GENERATOR-DECLS - (MAPCAR - #'(LAMBDA (DECL) - (LET ((HEAD (CAR DECL))) - (CONS HEAD (IF (EQ HEAD 'TYPE) - (CONS (SECOND DECL) - (SUBLIS RENAMED-VARS - (CDDR DECL))) - (SUBLIS RENAMED-VARS (CDR DECL))))) - ) - LOCALDECLS))))))) - - (IL:* IL:|;;| "Finished analyzing clause now. LET-BODY is the form which, when evaluated, returns updated values for the iteration variable(s) VARS. ") - - (WHEN (EQ LET-BODY :ABORT) - - (IL:* IL:|;;| "Some punt case: go with the formal semantics: bind a var to the generator, then call it in the update section ") - - (LET ((GVAR (GET-ITERATE-TEMP)) - (GENERATOR (SECOND CLAUSE))) - (SETQ LET-BINDINGS - (LIST (LIST GVAR - (COND - (LEFTOVER-BODY - (IL:* IL:\; "Have to use this up") - `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ - LEFTOVER-BODY - NIL)) - GENERATOR)) - (T GENERATOR))))) - (SETQ LET-BODY `(FUNCALL ,GVAR #'(LAMBDA NIL ,FINISH-FORM))))) - (PUSH (MV-SETQ (COPY-LIST VARS) - LET-BODY) - UPDATE-FORMS) - (DOLIST (V VARS) - (DECLARE (IGNORE V)) (IL:* IL:\; "Pop off the vars we have now bound from the list of vars to watch out for--we'll bind them right now ") - (POP BOUND-VARS)) - (SETQ BINDINGS (NCONC BINDINGS LET-BINDINGS - (COND - (EXTRA-BODY (IL:* IL:\; - "There was some computation to do after the bindings--here's our chance ") - (CONS (LIST (FIRST VARS) - `(PROGN ,@EXTRA-BODY NIL)) - (REST VARS))) - (T VARS)))))))))) - (DO ((TAIL BODY (CDR TAIL))) - ((NOT (AND (CONSP TAIL) - (CONSP (CAR TAIL)) - (EQ (CAAR TAIL) - 'DECLARE))) - - (IL:* IL:|;;| "TAIL now points at first non-declaration. If there were declarations, pop them off so they appear in the right place ") - - (UNLESS (EQ TAIL BODY) - (SETQ ITERATE-DECLS (LDIFF BODY TAIL)) - (SETQ BODY TAIL)))) - `(BLOCK ,BLOCK-NAME - (LET* ,BINDINGS ,@(AND GENERATOR-DECLS `((DECLARE ,@GENERATOR-DECLS))) - ,@ITERATE-DECLS - ,@LEFTOVER-BODY - (LOOP ,@(NREVERSE UPDATE-FORMS) - ,@BODY))))) - -(DEFUN EXPAND-INTO-LET (CLAUSE PARENT-NAME ENV) - - (IL:* IL:|;;| "Return values: Body, LET[*], bindings, localdecls, otherdecls, extra body, where BODY is a single form. If multiple forms in a LET, the preceding forms are returned as extra body. Returns :ABORT if it issued a punt warning. ") - - (PROG ((EXPANSION CLAUSE) - EXPANDEDP BINDING-TYPE LET-BINDINGS LET-BODY) - EXPAND - (MULTIPLE-VALUE-SETQ (EXPANSION EXPANDEDP) - (MACROEXPAND-1 EXPANSION ENV)) - (COND - ((NOT (CONSP EXPANSION)) (IL:* IL:\; "Shouldn't happen") - ) - ((SYMBOLP (SETQ BINDING-TYPE (FIRST EXPANSION))) - (CASE BINDING-TYPE - ((LET LET*) - (SETQ LET-BINDINGS (SECOND EXPANSION)) (IL:* IL:\; - "List of variable bindings") - (SETQ LET-BODY (CDDR EXPANSION)) - (GO HANDLE-LET)))) - ((AND (CONSP BINDING-TYPE) - (EQ (CAR BINDING-TYPE) - 'LAMBDA) - (NOT (FIND-IF #'(LAMBDA (X) - (MEMBER X LAMBDA-LIST-KEYWORDS)) - (SETQ LET-BINDINGS (SECOND BINDING-TYPE)))) - (EQL (LENGTH (SECOND EXPANSION)) - (LENGTH LET-BINDINGS)) - (NULL (CDDR EXPANSION))) (IL:* IL:\; - "A simple LAMBDA form can be treated as LET ") - (SETQ LET-BODY (CDDR BINDING-TYPE)) - (SETQ LET-BINDINGS (MAPCAR #'LIST LET-BINDINGS (SECOND EXPANSION))) - (SETQ BINDING-TYPE 'LET) - (GO HANDLE-LET))) - - (IL:* IL:|;;| "Fall thru if not a LET") - - (COND - (EXPANDEDP (IL:* IL:\; "try expanding again") - (GO EXPAND)) - (T (IL:* IL:\; - "Boring--return form as the body ") - (RETURN EXPANSION))) - HANDLE-LET - (RETURN (LET ((LOCALS (VARIABLES-FROM-LET LET-BINDINGS)) - EXTRA-BODY SPECIALS) - (MULTIPLE-VALUE-BIND (LOCALDECLS OTHERDECLS LET-BODY) - (PARSE-DECLARATIONS LET-BODY LOCALS) - (COND - ((SETQ SPECIALS (EXTRACT-SPECIAL-BINDINGS LOCALS LOCALDECLS)) - (MAYBE-WARN (COND - ((FIND-IF #'VARIABLE-GLOBALLY-SPECIAL-P SPECIALS) - (IL:* IL:\; - "This could be the fault of a user proclamation ") - :USER) - (T :DEFINITION)) - - "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)" - PARENT-NAME CLAUSE SPECIALS) - :ABORT) - (T (VALUES (COND - ((NOT (CONSP LET-BODY)) - (IL:* IL:\; - "Null body of LET? unlikely, but someone else will likely complain ") - NIL) - ((NULL (CDR LET-BODY)) - (IL:* IL:\; - "A single expression, which we hope is (function (lambda...)) ") - (FIRST LET-BODY)) - (T - - (IL:* IL:|;;| "More than one expression. These are forms to evaluate after the bindings but before the generator form is returned. Save them to evaluate in the next convenient place. Note that this is ok, as there is no construct that can cause a LET to return prematurely (without returning also from some surrounding construct). ") - - (SETQ EXTRA-BODY (BUTLAST LET-BODY)) - (CAR (LAST LET-BODY)))) - BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY)))))) - )) - -(DEFUN VARIABLES-FROM-LET (BINDINGS) - - (IL:* IL:|;;| "Return a list of the variables bound in the first argument to LET[*].") - - (MAPCAR #'(LAMBDA (BINDING) - (IF (CONSP BINDING) - (FIRST BINDING) - BINDING)) - BINDINGS)) - -(DEFUN ITERATE-TRANSFORM-BODY (LET-BODY ITERATE-ENV RENAMED-VARS FINISH-ARG FINISH-FORM - BOUND-VARS CLAUSE) - -(IL:* IL:|;;;| "This is the second major transformation for a single iterate clause. LET-BODY is the body of the iterator after we have extracted its local variables and declarations. We have two main tasks: (1) Substitute internal temporaries for occurrences of the LET variables; the alist RENAMED-VARS specifies this transformation. (2) Substitute evaluation of FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we check for forms that would invalidate these transformations: occurrence of FINISH-ARG outside of a funcall, and free reference to any element of BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type (ITERATE or ITERATE*), for purpose of error messages. On success, we return the transformed body; on failure, :ABORT. ") - - (WALK-FORM LET-BODY ITERATE-ENV #'(LAMBDA (FORM CONTEXT ENV) - (DECLARE (IGNORE CONTEXT)) - - (IL:* IL:|;;| - "Need to substitute RENAMED-VARS, as well as turn (FUNCALL finish-arg) into the finish form ") - - (COND - ((SYMBOLP FORM) - (LET (RENAMING) - (COND - ((AND (EQ FORM FINISH-ARG) - (VARIABLE-SAME-P FORM ENV - ITERATE-ENV)) - (IL:* IL:\; - "An occurrence of the finish arg outside of FUNCALL context--I can't handle this ") - (MAYBE-WARN :DEFINITION "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it." - (SECOND CLAUSE)) - (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT)) - ((AND (SETQ RENAMING (ASSOC FORM RENAMED-VARS - )) - (VARIABLE-SAME-P FORM ENV - ITERATE-ENV)) - (IL:* IL:\; - "Reference to one of the vars we're renaming ") - (CDR RENAMING)) - ((AND (MEMBER FORM BOUND-VARS) - (VARIABLE-SAME-P FORM ENV - ITERATE-ENV)) - (IL:* IL:\; "FORM is a var that is bound in this same ITERATE, or bound later in this ITERATE*. This is a conflict. ") - (MAYBE-WARN :USER "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable." - (SECOND CLAUSE) - FORM) - (RETURN-FROM ITERATE-TRANSFORM-BODY :ABORT)) - (T FORM)))) - ((AND (CONSP FORM) - (EQ (FIRST FORM) - 'FUNCALL) - (EQ (SECOND FORM) - FINISH-ARG) - (VARIABLE-SAME-P (SECOND FORM) - ENV ITERATE-ENV)) - (IL:* IL:\; - "(FUNCALL finish-arg) => finish-form ") - (UNLESS (NULL (CDDR FORM)) - (MAYBE-WARN :DEFINITION - "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored." - (SECOND CLAUSE) - (CDDR FORM))) - FINISH-FORM) - (T FORM))))) - -(DEFUN PARSE-DECLARATIONS (TAIL LOCALS) - - (IL:* IL:|;;| "Extract the declarations from the head of TAIL and divide them into 2 classes: declares about variables in the list LOCALS, and all other declarations. Returns 3 values: those 2 lists plus the remainder of TAIL. ") - - (LET - (LOCALDECLS OTHERDECLS FORM) - (LOOP - (UNLESS (AND TAIL (CONSP (SETQ FORM (CAR TAIL))) - (EQ (CAR FORM) - 'DECLARE)) - (RETURN (VALUES LOCALDECLS OTHERDECLS TAIL))) - (MAPC - #'(LAMBDA (DECL) - (CASE (FIRST DECL) - ((INLINE NOTINLINE OPTIMIZE) (IL:* IL:\; - "These don't talk about vars") - (PUSH DECL OTHERDECLS)) - (T (IL:* IL:\; - "Assume all other kinds are for vars ") - (LET* ((VARS (IF (EQ (FIRST DECL) - 'TYPE) - (CDDR DECL) - (CDR DECL))) - (L (INTERSECTION LOCALS VARS)) - OTHER) - (COND - ((NULL L) (IL:* IL:\; "None talk about LOCALS") - (PUSH DECL OTHERDECLS)) - ((NULL (SETQ OTHER (SET-DIFFERENCE VARS L))) - (IL:* IL:\; "All talk about LOCALS") - (PUSH DECL LOCALDECLS)) - (T (IL:* IL:\; "Some of each") - (LET ((HEAD (CONS 'TYPE (AND (EQ (FIRST DECL) - 'TYPE) - (LIST (SECOND DECL)))))) - (PUSH (APPEND HEAD OTHER) - OTHERDECLS) - (PUSH (APPEND HEAD L) - LOCALDECLS)))))))) - (CDR FORM)) - (POP TAIL)))) - -(DEFUN EXTRACT-SPECIAL-BINDINGS (VARS DECLS) - - (IL:* IL:|;;| -"Return the subset of VARS that are special, either globally or because of a declaration in DECLS ") - - (LET ((SPECIALS (REMOVE-IF-NOT #'VARIABLE-GLOBALLY-SPECIAL-P VARS))) - (DOLIST (D DECLS) - (WHEN (EQ (CAR D) - 'SPECIAL) - (SETQ SPECIALS (UNION SPECIALS (INTERSECTION VARS (CDR D)))))) - SPECIALS)) - -(DEFUN FUNCTION-LAMBDA-P (FORM &OPTIONAL NARGS) - - (IL:* IL:|;;| "If FORM is #'(LAMBDA bindings . body) and bindings is of length NARGS, return the lambda expression ") - - (LET (ARGS BODY) - (AND (CONSP FORM) - (EQ (CAR FORM) - 'FUNCTION) - (CONSP (SETQ FORM (CDR FORM))) - (NULL (CDR FORM)) - (CONSP (SETQ FORM (CAR FORM))) - (EQ (CAR FORM) - 'LAMBDA) - (CONSP (SETQ BODY (CDR FORM))) - (LISTP (SETQ ARGS (CAR BODY))) - (OR (NULL NARGS) - (EQL (LENGTH ARGS) - NARGS)) - FORM))) - -(DEFUN RENAME-LET-BINDINGS (LET-BINDINGS BINDING-TYPE ENV LEFTOVER-BODY &OPTIONAL TEMPVARFN) - - (IL:* IL:|;;| "Perform the alpha conversion required for \"LET eversion\" of (LET[*] LET-BINDINGS . body)--rename each of the variables to an internal name. Returns 2 values: a new set of LET bindings and the alist of old var names to new (so caller can walk the body doing the rest of the renaming). BINDING-TYPE is one of LET or LET*. LEFTOVER-BODY is optional list of forms that must be eval'ed before the first binding happens. ENV is the macro expansion environment, in case we have to walk a LET*. TEMPVARFN is a function of no args to return a temporary var; if omitted, we use GENSYM. ") - - (LET (RENAMED-VARS) - (VALUES (MAPCAR #'(LAMBDA (BINDING) - (LET ((VALUEFORM (COND - ((NOT (CONSP BINDING)) - (IL:* IL:\; "No initial value") - NIL) - ((OR (EQ BINDING-TYPE 'LET) - (NULL RENAMED-VARS)) - (IL:* IL:\; - "All bindings are in parallel, so none can refer to others ") - (SECOND BINDING)) - (T (IL:* IL:\; - "In a LET*, have to substitute vars in the 2nd and subsequent initialization forms ") - (RENAME-VARIABLES (SECOND BINDING) - RENAMED-VARS ENV)))) - (NEWVAR (IF TEMPVARFN - (FUNCALL TEMPVARFN) - (GENSYM)))) - (PUSH (CONS (IF (CONSP BINDING) - (FIRST BINDING) - BINDING) - NEWVAR) - RENAMED-VARS) (IL:* IL:\; - "Add new variable to the list AFTER we have walked the initial value form ") - (WHEN LEFTOVER-BODY - - (IL:* IL:|;;| "Previous clause had some computation to do after its bindings. Here is the first opportunity to do it ") - - (SETQ VALUEFORM `(PROGN ,@LEFTOVER-BODY ,VALUEFORM)) - (SETQ LEFTOVER-BODY NIL)) - (LIST NEWVAR VALUEFORM))) - LET-BINDINGS) - RENAMED-VARS))) - -(DEFUN RENAME-VARIABLES (FORM ALIST ENV) - - (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values. ENV is FORM's environment, so we can make sure we are talking about the same variables. ") - - (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV) - (DECLARE (IGNORE CONTEXT)) - (LET (PAIR) - (COND - ((AND (SYMBOLP FORM) - (SETQ PAIR (ASSOC FORM ALIST)) - (VARIABLE-SAME-P FORM SUBENV ENV)) - (CDR PAIR)) - (T FORM)))))) - -(DEFUN MV-SETQ (VARS EXPR) - - (IL:* IL:|;;| "Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some of the simple cases for benefit of compilers that don't, and I don't care what the value is, and I know that the variables need not be set in parallel, since they can't be used free in EXPR ") - - (COND - ((NULL VARS) (IL:* IL:\; "EXPR is a side-effect") - EXPR) - ((NOT (CONSP VARS)) (IL:* IL:\; - "This is an error, but I'll let MULTIPLE-VALUE-SETQ report it ") - `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR)) - ((AND (LISTP EXPR) - (EQ (CAR EXPR) - 'VALUES)) - - (IL:* IL:|;;| "(mv-setq (a b c) (values x y z)) can be reduced to a parallel setq (psetq returns nil, but I don't care about returned value). Do this even for the single variable case so that we catch (mv-setq (a) (values x y)) ") - - (POP EXPR) (IL:* IL:\; "VALUES") - `(SETQ ,@(MAPCON #'(LAMBDA (TAIL) - (LIST (CAR TAIL) - (COND - ((OR (CDR TAIL) - (NULL (CDR EXPR))) - (IL:* IL:\; - "One result expression for this var ") - (POP EXPR)) - (T (IL:* IL:\; - "More expressions than vars, so arrange to evaluate all the rest now. ") - (CONS 'PROG1 EXPR))))) - VARS))) - ((NULL (CDR VARS)) (IL:* IL:\; "Simple one variable case") - `(SETQ ,(CAR VARS) - ,EXPR)) - (T (IL:* IL:\; - "General case--I know nothing") - `(MULTIPLE-VALUE-SETQ ,VARS ,EXPR)))) - -(DEFUN VARIABLE-SAME-P (VAR ENV1 ENV2) - (EQ (VARIABLE-LEXICAL-P VAR ENV1) - (VARIABLE-LEXICAL-P VAR ENV2))) - -(DEFUN MAYBE-WARN (TYPE &REST WARN-ARGS) - - (IL:* IL:|;;| "Issue a warning about not being able to optimize this thing. TYPE is one of :DEFINITION, meaning the definition is at fault, and :USER, meaning the user's code is at fault. ") - - (WHEN (CASE *ITERATE-WARNINGS* - ((NIL) NIL) - ((:USER) (EQ TYPE :USER)) - (T T)) - (APPLY #'WARN WARN-ARGS))) - - - -(IL:* IL:|;;| "Sample iterators") - - -(DEFMACRO INTERVAL (&WHOLE WHOLE &KEY FROM DOWNFROM TO DOWNTO ABOVE BELOW BY TYPE) - (COND - ((AND FROM DOWNFROM) - (ERROR "Can't use both FROM and DOWNFROM in ~S" WHOLE)) - ((CDR (REMOVE NIL (LIST TO DOWNTO ABOVE BELOW))) - (ERROR "Can't use more than one limit keyword in ~S" WHOLE)) - (T - (LET* - ((DOWN (OR DOWNFROM DOWNTO ABOVE)) - (LIMIT (OR TO DOWNTO ABOVE BELOW)) - (INC (COND - ((NULL BY) - 1) - ((CONSTANTP BY) (IL:* IL:\; - "Can inline this increment") - BY)))) - `(LET ((FROM ,(OR FROM DOWNFROM 0)) - ,@(AND LIMIT `((TO ,LIMIT))) - ,@(AND (NULL INC) - `((BY ,BY)))) - ,@(AND TYPE `((DECLARE (TYPE ,TYPE FROM ,@(AND LIMIT '(TO)) - ,@(AND (NULL INC) - `(BY)))))) - #'(LAMBDA (FINISH) - ,@(COND - ((NULL LIMIT) (IL:* IL:\; - "We won't use the FINISH arg") - '((DECLARE (IGNORE FINISH))))) - (PROG1 ,(COND - (LIMIT (IL:* IL:\; - "Test the limit. If ok, return current value and increment, else quit ") - `(IF (,(COND - (ABOVE '>) - (BELOW '<) - (DOWN '>=) - (T '<=)) - FROM TO) - FROM - (FUNCALL FINISH))) - (T (IL:* IL:\; "No test") - 'FROM)) - (SETQ FROM (,(IF DOWN - '- - '+) - FROM - ,(OR INC 'BY)))))))))) - -(DEFMACRO LIST-ELEMENTS (LIST &KEY (BY '#'CDR)) - `(LET ((TAIL ,LIST)) - #'(LAMBDA (FINISH) - (PROG1 (IF (ENDP TAIL) - (FUNCALL FINISH) - (FIRST TAIL)) - (SETQ TAIL (FUNCALL ,BY TAIL)))))) - -(DEFMACRO LIST-TAILS (LIST &KEY (BY '#'CDR)) - `(LET ((TAIL ,LIST)) - #'(LAMBDA (FINISH) - (PROG1 (IF (ENDP TAIL) - (FUNCALL FINISH) - TAIL) - (SETQ TAIL (FUNCALL ,BY TAIL)))))) - -(DEFMACRO ELEMENTS (SEQUENCE) - "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type." - (LET* ((TYPE (AND (CONSP SEQUENCE) - (EQ (FIRST SEQUENCE) - 'THE) - (SECOND SEQUENCE))) - (ACCESSOR (IF TYPE - (SEQUENCE-ACCESSOR TYPE) - 'ELT)) - (LISTP (EQ TYPE 'LIST))) - - (IL:* IL:|;;| "If type is given via THE, we may be able to generate a good accessor here for the benefit of implementations that aren't smart about (ELT (THE STRING FOO)). I'm not bothering to keep the THE inside the body, however, since I assume any compiler that would understand (AREF (THE SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I bound S to (THE SIMPLE-ARRAY foo) and never modified it. If sequence is declared to be a list, it's better to cdr down it, so we have some extra cases here. Normally folks would write LIST-ELEMENTS, but maybe they wanted to get the index for free... ") - - `(LET* ((INDEX 0) - (S ,SEQUENCE) - ,@(AND (NOT LISTP) - '((SIZE (LENGTH S))))) - #'(LAMBDA (FINISH) - (VALUES (COND - ,(IF LISTP - '((NOT (ENDP S)) - (POP S)) - `((< INDEX SIZE) - (,ACCESSOR S INDEX))) - (T (FUNCALL FINISH))) - (PROG1 INDEX - (SETQ INDEX (1+ INDEX)))))))) - -(DEFMACRO PLIST-ELEMENTS (PLIST) - "Generates each time 2 items, the indicator and the value." - `(LET ((TAIL ,PLIST)) - #'(LAMBDA (FINISH) - (VALUES (IF (ENDP TAIL) - (FUNCALL FINISH) - (FIRST TAIL)) - (PROG1 (IF (ENDP (SETQ TAIL (CDR TAIL))) - (FUNCALL FINISH) - (FIRST TAIL)) - (SETQ TAIL (CDR TAIL))))))) - -(DEFUN SEQUENCE-ACCESSOR (TYPE) - - (IL:* IL:|;;| - "returns the function with which most efficiently to make accesses to a sequence of type TYPE. ") - - (CASE (IF (CONSP TYPE) (IL:* IL:\; "e.g., (VECTOR FLOAT *)") - (CAR TYPE) - TYPE) - ((ARRAY SIMPLE-ARRAY VECTOR) 'AREF) - (SIMPLE-VECTOR 'SVREF) - (STRING 'CHAR) - (SIMPLE-STRING 'SCHAR) - (BIT-VECTOR 'BIT) - (SIMPLE-BIT-VECTOR 'SBIT) - (T 'ELT))) - - - -(IL:* IL:|;;| "These \"iterators\" may be withdrawn") - - -(DEFMACRO EACHTIME (EXPR) - `#'(LAMBDA (FINISH) - (DECLARE (IGNORE FINISH)) - ,EXPR)) - -(DEFMACRO WHILE (EXPR) - `#'(LAMBDA (FINISH) - (UNLESS ,EXPR (FUNCALL FINISH)))) - -(DEFMACRO UNTIL (EXPR) - `#'(LAMBDA (FINISH) - (WHEN ,EXPR (FUNCALL FINISH)))) - - - -(IL:* IL:\; "GATHERING macro") - - -(DEFMACRO GATHERING (CLAUSES &BODY BODY &ENVIRONMENT ENV) - (OR (OPTIMIZE-GATHERING-FORM CLAUSES BODY ENV) - (SIMPLE-EXPAND-GATHERING-FORM CLAUSES BODY ENV))) - -(DEFMACRO WITH-GATHERING (CLAUSES GATHER-BODY &BODY USE-BODY) - "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour." - - (IL:* IL:|;;| "We may optimize this a little better later for those compilers that don't do a good job on (m-v-bind vars (... (values ...)) ...). ") - - `(MULTIPLE-VALUE-BIND ,(MAPCAR #'CAR CLAUSES) - (GATHERING ,CLAUSES ,GATHER-BODY) - ,@USE-BODY)) - -(DEFUN SIMPLE-EXPAND-GATHERING-FORM (CLAUSES BODY ENV) - (DECLARE (IGNORE ENV)) - - (IL:* IL:|;;| - "The \"formal semantics\" of GATHERING. We use this only in cases that can't be optimized. ") - - (LET - ((ACC-NAMES (MAPCAR #'FIRST (IF (SYMBOLP CLAUSES) (IL:* IL:\; - "Shorthand using anonymous gathering site ") - (SETQ CLAUSES `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES)))) - CLAUSES))) - (REALIZER-NAMES (MAPCAR #'(LAMBDA (BINDING) - (DECLARE (IGNORE BINDING)) - (GENSYM)) - CLAUSES))) - `(MULTIPLE-VALUE-CALL - #'(LAMBDA ,(MAPCAN #'LIST ACC-NAMES REALIZER-NAMES) - (FLET ((GATHER (VALUE &OPTIONAL (ACCUMULATOR *ANONYMOUS-GATHERING-SITE*)) - (FUNCALL ACCUMULATOR VALUE))) - ,@BODY - (VALUES ,@(MAPCAR #'(LAMBDA (RNAME) - `(FUNCALL ,RNAME)) - REALIZER-NAMES)))) - ,@(MAPCAR #'SECOND CLAUSES)))) - -(DEFVAR *ACTIVE-GATHERERS* NIL - "List of GATHERING bindings currently active during macro expansion)") - -(DEFVAR *ANONYMOUS-GATHERING-SITE* NIL - "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site)." -) - -(DEFUN OPTIMIZE-GATHERING-FORM (CLAUSES BODY GATHERING-ENV) - (LET* - (ACC-INFO LEFTOVER-BODY TOP-BINDINGS FINISH-FORMS TOP-DECLS) - (DOLIST (CLAUSE (IF (SYMBOLP CLAUSES) (IL:* IL:\; "A shorthand") - `((*ANONYMOUS-GATHERING-SITE* (,CLAUSES))) - CLAUSES)) - (MULTIPLE-VALUE-BIND (LET-BODY BINDING-TYPE LET-BINDINGS LOCALDECLS OTHERDECLS EXTRA-BODY) - (EXPAND-INTO-LET (SECOND CLAUSE) - 'GATHERING GATHERING-ENV) - (PROG* ((ACC-VAR (FIRST CLAUSE)) - RENAMED-VARS ACCUMULATOR REALIZER) - (WHEN (AND (CONSP LET-BODY) - (EQ (CAR LET-BODY) - 'VALUES) - (CONSP (SETQ LET-BODY (CDR LET-BODY))) - (SETQ ACCUMULATOR (FUNCTION-LAMBDA-P (CAR LET-BODY))) - (CONSP (SETQ LET-BODY (CDR LET-BODY))) - (SETQ REALIZER (FUNCTION-LAMBDA-P (CAR LET-BODY) - 0)) - (NULL (CDR LET-BODY))) - - (IL:* IL:|;;| "Macro returned something of the form (VALUES #'(lambda (value)") - - (IL:* IL:|;;| - "..) #'(lambda () ...)), a function to accumulate values and a function to realize the result. ") - - (WHEN BINDING-TYPE - - (IL:* IL:|;;| "Gatherer expanded into a LET") - - (COND - (OTHERDECLS (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S" - (SECOND CLAUSE) - `(DECLARE ,@OTHERDECLS)) - (GO PUNT))) - (WHEN LET-BINDINGS - - (IL:* IL:|;;| "The first transformation we want to perform is a variant of \"LET-eversion\": turn (mv-bind (acc real) (let (..bindings..) (values #'(lambda ...) #'(lambda ") - - (IL:* IL:|;;| "..))) ..body..) into (let* (..bindings.. (acc #'(lambda ...)) (real #'(lambda ...))) ..body..). This transformation is valid if nothing in body refers to any of the bindings, something we can assure by alpha-converting the inner let (substituting new names for each var). Of course, none of those vars can be special, but we already checked for that above. ") - - (MULTIPLE-VALUE-SETQ (LET-BINDINGS RENAMED-VARS) - (RENAME-LET-BINDINGS LET-BINDINGS BINDING-TYPE GATHERING-ENV - LEFTOVER-BODY)) - (SETQ TOP-BINDINGS (NCONC TOP-BINDINGS LET-BINDINGS)) - (SETQ LEFTOVER-BODY NIL) (IL:* IL:\; - "If there was any leftover from previous, it is now consumed ") - )) - (SETQ LEFTOVER-BODY (NCONC LEFTOVER-BODY EXTRA-BODY)) - (IL:* IL:\; - "Computation to do after these bindings ") - (PUSH (CONS ACC-VAR (RENAME-AND-CAPTURE-VARIABLES ACCUMULATOR RENAMED-VARS - GATHERING-ENV)) - ACC-INFO) - (SETQ REALIZER (RENAME-VARIABLES REALIZER RENAMED-VARS GATHERING-ENV)) - (PUSH (COND - ((NULL (CDDDR REALIZER)) (IL:* IL:\; - "Simple (LAMBDA () expr) => expr ") - (THIRD REALIZER)) - (T (IL:* IL:\; - "There could be declarations or something, so leave as a LET ") - (CONS 'LET (CDR REALIZER)))) - FINISH-FORMS) - (UNLESS (NULL LOCALDECLS) (IL:* IL:\; - "Declarations about the LET variables also has to percolate up ") - (SETQ TOP-DECLS (NCONC TOP-DECLS (SUBLIS RENAMED-VARS LOCALDECLS)))) - (RETURN)) - (MAYBE-WARN :DEFINITION "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))" - (SECOND CLAUSE)) - PUNT - (LET ((GS (GENSYM)) - (EXPANSION `(MULTIPLE-VALUE-LIST ,(SECOND CLAUSE)))) - (IL:* IL:\; - "Slow way--bind gensym to the macro expansion, and we will funcall it in the body ") - (PUSH (LIST ACC-VAR GS) - ACC-INFO) - (PUSH `(FUNCALL (CADR ,GS)) - FINISH-FORMS) - (SETQ TOP-BINDINGS - (NCONC TOP-BINDINGS - (LIST (LIST GS - (COND - (LEFTOVER-BODY - `(PROGN ,@(PROG1 LEFTOVER-BODY (SETQ LEFTOVER-BODY - NIL)) - ,EXPANSION)) - (T EXPANSION)))))))))) - (SETQ BODY (WALK-GATHERING-BODY BODY GATHERING-ENV ACC-INFO)) - (COND - ((EQ BODY :ABORT) (IL:* IL:\; - "Couldn't finish expansion") - NIL) - (T `(LET* ,TOP-BINDINGS ,@(AND TOP-DECLS `((DECLARE ,@TOP-DECLS))) - ,BODY - ,(COND - ((NULL (CDR FINISH-FORMS)) (IL:* IL:\; "just a single value") - (CAR FINISH-FORMS)) - (T `(VALUES ,@(REVERSE FINISH-FORMS))))))))) - -(DEFUN RENAME-AND-CAPTURE-VARIABLES (FORM ALIST ENV) - - (IL:* IL:|;;| "Walks FORM, renaming occurrences of the key variables in ALIST with their corresponding values, and capturing any other free variables. Returns a list of the new form and the list of other closed-over vars. ENV is FORM's environment, so we can make sure we are talking about the same variables. ") - - (LET (CLOSED) - (LIST (WALK-FORM FORM ENV #'(LAMBDA (FORM CONTEXT SUBENV) - (DECLARE (IGNORE CONTEXT)) - (LET (PAIR) - (COND - ((OR (NOT (SYMBOLP FORM)) - (NOT (VARIABLE-SAME-P FORM SUBENV ENV))) - (IL:* IL:\; - "non-variable or one that has been rebound ") - FORM) - ((SETQ PAIR (ASSOC FORM ALIST)) - (IL:* IL:\; "One to rename") - (CDR PAIR)) - (T (IL:* IL:\; "var is free") - (PUSHNEW FORM CLOSED) - FORM))))) - CLOSED))) - -(DEFUN WALK-GATHERING-BODY (BODY GATHERING-ENV ACC-INFO) - - (IL:* IL:|;;| "Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV. ACC-INFO is a list of information about each of the gathering \"bindings\" in the form, in the form (var gatheringfn freevars env) ") - - (LET ((*ACTIVE-GATHERERS* (NCONC (MAPCAR #'CAR ACC-INFO) - *ACTIVE-GATHERERS*))) - - (IL:* IL:|;;| "*ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER targets. This is so that when we encounter a GATHER not belonging to us we can know whether to warn about it. ") - - (WALK-FORM - (CONS 'PROGN BODY) - GATHERING-ENV - #'(LAMBDA (FORM CONTEXT ENV) - (DECLARE (IGNORE CONTEXT)) - (LET (INFO SITE) - (COND - ((CONSP FORM) - (COND - ((NOT (EQ (CAR FORM) - 'GATHER)) (IL:* IL:\; - "We only care about GATHER") - (WHEN (AND (EQ (CAR FORM) - 'FUNCTION) - (EQ (CADR FORM) - 'GATHER)) (IL:* IL:\; - "Passed as functional--can't macroexpand ") - (MAYBE-WARN :USER - "Can't optimize GATHERING because of reference to #'GATHER." - ) - (RETURN-FROM WALK-GATHERING-BODY :ABORT)) - FORM) - ((SETQ INFO (ASSOC (SETQ SITE (IF (NULL (CDDR FORM)) - '*ANONYMOUS-GATHERING-SITE* - (THIRD FORM))) - ACC-INFO)) (IL:* IL:\; - "One of ours--expand (GATHER value var). INFO = (var gatheringfn freevars env) ") - (UNLESS (NULL (CDDDR FORM)) - (WARN "Extra arguments (> 2) in ~S discarded." FORM)) - (LET ((FN (SECOND INFO))) - (COND - ((SYMBOLP FN) (IL:* IL:\; "Unoptimized case--just call the gatherer. FN is the gensym that we bound to the list of two values returned from the gatherer. ") - `(FUNCALL (CAR ,FN) - ,(SECOND FORM))) - (T (IL:* IL:\; - "FN = (lambda (value) ...)") - (DOLIST (S (THIRD INFO)) - (UNLESS (OR (VARIABLE-SAME-P S ENV GATHERING-ENV) - (AND (VARIABLE-SPECIAL-P S ENV) - (VARIABLE-SPECIAL-P S GATHERING-ENV))) - - (IL:* IL:|;;| "Some var used free in the LAMBDA form has been rebound between here and the parent GATHERING form, so can't substitute the lambda. Ok if it's a special reference both here and in the LAMBDA, because then it's not closed over. ") - - (MAYBE-WARN :USER "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it." - S) - (RETURN-FROM WALK-GATHERING-BODY :ABORT))) - - (IL:* IL:|;;| "Return ((lambda (value) ...) actual-value). In many cases we could simplify this further by substitution, but we'd have to be careful (for example, we would need to alpha-convert any LET we found inside). Any decent compiler will do it for us. ") - - (LIST FN (SECOND FORM)))))) - ((AND (SETQ INFO (MEMBER SITE *ACTIVE-GATHERERS*)) - (OR (EQ SITE '*ANONYMOUS-GATHERING-SITE*) - (VARIABLE-SAME-P SITE ENV (FOURTH INFO)))) - (IL:* IL:\; "Some other GATHERING will take care of this form, so pass it up for now. Environment check is to make sure nobody shadowed it between here and there ") - FORM) - (T (IL:* IL:\; - "Nobody's going to handle it") - (IF (EQ SITE '*ANONYMOUS-GATHERING-SITE*) - (IL:* IL:\; - "More likely that she forgot to mention the site than forget to write an anonymous gathering. ") - (WARN "There is no gathering site specified in ~S." FORM) - (WARN - "The site ~S in ~S is not defined in an enclosing GATHERING form." - SITE FORM)) (IL:* IL:\; - "Turn it into something else so we don't warn twice in the nested case ") - `(%ORPHANED-GATHER ,@(CDR FORM))))) - ((AND (SYMBOLP FORM) - (SETQ INFO (ASSOC FORM ACC-INFO)) - (VARIABLE-SAME-P FORM ENV GATHERING-ENV)) - (IL:* IL:\; - "A variable reference to a gather binding from environment TEM ") - (MAYBE-WARN :USER - "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form." - FORM) - (RETURN-FROM WALK-GATHERING-BODY :ABORT)) - (T FORM))))))) - - - -(IL:* IL:|;;| "Sample gatherers") - - -(DEFMACRO COLLECTING (&KEY INITIAL-VALUE) - `(LET* ((HEAD ,INITIAL-VALUE) - (TAIL ,(AND INITIAL-VALUE `(LAST HEAD)))) - (VALUES #'(LAMBDA (VALUE) - (IF (NULL HEAD) - (SETQ HEAD (SETQ TAIL (LIST VALUE))) - (SETQ TAIL (CDR (RPLACD TAIL (LIST VALUE)))))) - #'(LAMBDA NIL HEAD)))) - -(DEFMACRO JOINING (&KEY INITIAL-VALUE) - `(LET ((RESULT ,INITIAL-VALUE)) - (VALUES #'(LAMBDA (VALUE) - (SETQ RESULT (NCONC RESULT VALUE))) - #'(LAMBDA NIL RESULT)))) - -(DEFMACRO MAXIMIZING (&KEY INITIAL-VALUE) - `(LET ((RESULT ,INITIAL-VALUE)) - (VALUES #'(LAMBDA (VALUE) - (WHEN ,(COND - ((AND (CONSTANTP INITIAL-VALUE) - (NOT (NULL (EVAL INITIAL-VALUE)))) - (IL:* IL:\; - "Initial value is given and we know it's not NIL, so leave out the null check ") - '(> VALUE RESULT)) - (T '(OR (NULL RESULT) - (> VALUE RESULT)))) - (SETQ RESULT VALUE))) - #'(LAMBDA NIL RESULT)))) - -(DEFMACRO MINIMIZING (&KEY INITIAL-VALUE) - `(LET ((RESULT ,INITIAL-VALUE)) - (VALUES #'(LAMBDA (VALUE) - (WHEN ,(COND - ((AND (CONSTANTP INITIAL-VALUE) - (NOT (NULL (EVAL INITIAL-VALUE)))) - (IL:* IL:\; - "Initial value is given and we know it's not NIL, so leave out the null check ") - '(< VALUE RESULT)) - (T '(OR (NULL RESULT) - (< VALUE RESULT)))) - (SETQ RESULT VALUE))) - #'(LAMBDA NIL RESULT)))) - -(DEFMACRO SUMMING (&KEY (INITIAL-VALUE 0)) - `(LET ((SUM ,INITIAL-VALUE)) - (VALUES #'(LAMBDA (VALUE) - (SETQ SUM (+ SUM VALUE))) - #'(LAMBDA NIL SUM)))) - - - -(IL:* IL:\; "Easier to read expanded code if PROG1 gets left alone ") - - -(XCL:DEFINE-FILE-ENVIRONMENT "ITERATE" :PACKAGE (IN-PACKAGE :ITERATE :USE '(:LISP :WALKER)) - :READTABLE "XCL" - :BASE 10 - :COMPILER :COMPILE-FILE) -(IL:PUTPROPS IL:ITERATE IL:COPYRIGHT ("Venue" 1991)) -(IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL))) -IL:STOP diff --git a/obsolete/clos/2.0/lap.lisp b/obsolete/clos/2.0/lap.lisp deleted file mode 100644 index 4dceda84..00000000 --- a/obsolete/clos/2.0/lap.lisp +++ /dev/null @@ -1,364 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;;. Copyright (c) 1991 by Venue - -(in-package "CLOS") - -;;; This file defines CLOS's interface to the LAP mechanism. The file is divided into two parts. The -;;; first part defines the interface used by CLOS to create abstract LAP code vectors. CLOS never -;;; creates lists that represent LAP code directly, it always calls this mechanism to do so. This -;;; provides a layer of error checking on the LAP code before it gets to the implementation-specific -;;; assembler. Note that this error checking is syntactic only, but even so is useful to have. -;;; Because of it, no specific LAP assembler should worry itself with checking the syntax of the LAP -;;; code. The second part of the file defines the LAP assemblers for each CLOS port. These are -;;; included together in the same file to make it easier to change them all should some random -;;; change be made in the LAP mechanism. - - -(defvar *make-lap-closure-generator*) - -(defvar *precompile-lap-closure-generator*) - -(defvar *lap-in-lisp*) - -(defun make-lap-closure-generator (closure-variables arguments iregs vregs tregs lap-code) - (funcall *make-lap-closure-generator* closure-variables arguments iregs vregs tregs lap-code)) - -(defmacro precompile-lap-closure-generator (cvars args i-regs v-regs t-regs lap) - (funcall *precompile-lap-closure-generator* cvars args i-regs v-regs t-regs lap)) - -(defmacro lap-in-lisp (cvars args iregs vregs tregs lap) - (declare (ignore cvars args)) - `(locally (declare (optimize (safety 0) - (speed 3))) - ,(make-lap-prog iregs vregs tregs (flatten-lap lap (opcode :label 'exit-lap-in-lisp))) - )) - - -;;; The following functions and macros are used by CLOS when generating LAP code: GENERATING-LAP -;;; WITH-LAP-REGISTERS ALLOCATE-REGISTER DEALLOCATE-REGISTER LAP-FLATTEN OPCODE OPERAND - - -(proclaim '(special *generating-lap*)) - - ; CAR - alist of free registers CADR - ; - alist of allocated registers CADDR - ; - max reg number allocated in each - ; alist, the entries have the form: - ; (type . (:REG )) - - - -;;; This goes around the generation of any lap code. should return a lap code sequence, this -;;; macro will take care of converting that to a lap closure generator. - - -(defmacro generating-lap (closure-variables arguments &body body) - `(let* ((*generating-lap* (list nil nil -1))) - (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body)))) - -(defmacro generating-lap-in-lisp (closure-variables arguments &body body) - `(let* ((*generating-lap* (list nil nil -1))) - (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body)))) - - -;;; Each register specification looks like: ( &key :reuse ) - - -(defmacro with-lap-registers (register-specifications &body body) - - ;; Given that, for now, there is only one keyword argument and that, for now, we do no error - ;; checking, we can be pretty sleazy about how this works. - (flet ((make-allocations - nil - (gathering1 (collecting) - (dolist (spec register-specifications) - (gather1 `(,(car spec) - (or ,(cadddr spec) - (allocate-register ',(cadr spec)))))))) - (make-deallocations nil (gathering1 - (collecting) - (dolist (spec register-specifications) - (gather1 `(unless ,(cadddr spec) - (deallocate-register ,(car spec)))))))) - `(let ,(make-allocations) - (multiple-value-prog1 (progn ,@body) - ,@(make-deallocations))))) - -(defun allocate-register (type) - (destructuring-bind (free allocated) - *generating-lap* - (let ((entry (assoc type free))) - (cond (entry (setf (car *generating-lap*) - (delete entry free) - (cadr *generating-lap*) - (cons entry allocated)) - (cdr entry)) - (t (let ((new `(,type :reg ,(incf (caddr *generating-lap*))))) - (setf (cadr *generating-lap*) - (cons new allocated)) - (cdr new))))))) - -(defun deallocate-register (reg) - (let ((entry (rassoc reg (cadr *generating-lap*)))) - (unless entry (error "Attempt to free an unallocated register.")) - (push entry (car *generating-lap*)) - (setf (cadr *generating-lap*) - (delete entry (cadr *generating-lap*))))) - -(defvar *precompiling-lap* nil) - -(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code) - (when (cadr *generating-lap*) - (error "Registers still allocated when lap being finalized.")) - (let ((iregs nil) - (vregs nil) - (tregs nil)) - (dolist (entry (car *generating-lap*)) - (ecase (car entry) - (index (push (caddr entry) - iregs)) - (vector (push (caddr entry) - vregs)) - ((t) (push (caddr entry) - tregs)))) - (cond (in-lisp-p (macroexpand `(lap-in-lisp ,closure-variables ,arguments ,iregs - ,vregs - ,tregs - ,lap-code))) - (*precompiling-lap* (values closure-variables arguments iregs vregs tregs lap-code) - ) - (t (make-lap-closure-generator closure-variables arguments iregs vregs tregs - lap-code))))) - -(defun flatten-lap (&rest opcodes-or-sequences) - (let ((result nil)) - (dolist (opcode-or-sequence opcodes-or-sequences result) - (cond ((null opcode-or-sequence)) - ((not (consp (car opcode-or-sequence))) - ; its an opcode - (setf result (append result (list opcode-or-sequence)))) - (t (setf result (append result opcode-or-sequence))))))) - -(defmacro flattening-lap nil '(let ((result nil)) - (values #'(lambda (value) - (push value result)) - #'(lambda nil (apply #'flatten-lap (reverse result)))))) - - -;;; This code deals with the syntax of the individual opcodes and operands. The first two of these -;;; variables are documented to all ports. They are lists of the symbols which name the lap opcodes -;;; and operands. They can be useful to determine whether a port has implemented all the required -;;; opcodes and operands. The third of these variables is for use of the emitter only. - - -(defvar *lap-operands* nil) - -(defvar *lap-opcodes* nil) - -(defvar *lap-emitters* (make-hash-table :test #'eq :size 30)) - -(defun opcode (name &rest args) - (let ((emitter (gethash name *lap-emitters*))) - (if emitter - (apply emitter args) - (error "No opcode named ~S." name)))) - -(defun operand (name &rest args) - (let ((emitter (gethash name *lap-emitters*))) - (if emitter - (apply emitter args) - (error "No operand named ~S." name)))) - -(defmacro defopcode (name types) - (let ((fn-name (symbol-append "LAP Opcode " name *the-clos-package*)) - (lambda-list (mapcar #'(lambda (x) - (declare (ignore x)) - (gensym)) - types))) - `(progn (eval-when (load eval) - (load-defopcode ',name ',fn-name)) - (defun ,fn-name ,lambda-list (defopcode-1 ',name ',types ,@lambda-list))))) - -(defmacro defoperand (name types) - (let ((fn-name (symbol-append "LAP Operand " name *the-clos-package*)) - (lambda-list (mapcar #'(lambda (x) - (declare (ignore x)) - (gensym)) - types))) - `(progn (eval-when (load eval) - (load-defoperand ',name ',fn-name)) - (defun ,fn-name ,lambda-list (defoperand-1 ',name ',types ,@lambda-list))))) - -(defun load-defopcode (name fn-name) - (if* (memq name *lap-operands*) - (error "LAP opcodes and operands must have disjoint names.") - (setf (gethash name *lap-emitters*) - fn-name) - (pushnew name *lap-opcodes*))) - -(defun load-defoperand (name fn-name) - (if* (memq name *lap-opcodes*) - (error "LAP opcodes and operands must have disjoint names.") - (setf (gethash name *lap-emitters*) - fn-name) - (pushnew name *lap-operands*))) - -(defun defopcode-1 (name operand-types &rest args) - (iterate ((arg (list-elements args)) - (type (list-elements operand-types))) - (check-opcode-arg name arg type)) - (cons name (copy-list args))) - -(defun defoperand-1 (name operand-types &rest args) - (iterate ((arg (list-elements args)) - (type (list-elements operand-types))) - (check-operand-arg name arg type)) - (cons name (copy-list args))) - -(defun check-opcode-arg (name arg type) - (labels ((usual (x) - (and (consp arg) - (eq (car arg) - x))) - (check (x) - (ecase x - ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x)) - (:label (symbolp arg)) - (:operand (and (consp arg) - (memq (car arg) - *lap-operands*)))))) - (unless (if (consp type) - (if (eq (car type) - 'or) - (some #'check (cdr type)) - (error "What type is this?")) - (check type)) - (error "The argument ~S to the opcode ~A is not of type ~S." arg name type)))) - -(defun check-operand-arg (name arg type) - (flet ((check (x) - (ecase x - (:symbol (symbolp arg)) - (:register-number (and (integerp arg) - (>= x 0))) - (:t t) - (:reg (and (consp arg) - (eq (car arg) - :reg))) - (:fixnum (typep arg 'fixnum))))) - (unless (if (consp type) - (if (eq (car type) - 'or) - (some #'check (cdr type)) - (error "What type is this?")) - (check type)) - (error "The argument ~S to the operand ~A is not of type ~S." arg name type)))) - - -;;; The actual opcodes. - - -(defopcode :break nil) - - ; For debugging only. Not - - -(defopcode :beep nil) - - ; all ports are required to - - -(defopcode :print (:reg)) - - ; implement this. - - -(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable))) - -(defopcode :eq ((or :reg :constant) - (or :reg :constant) - :label)) - -(defopcode :neq ((or :reg :constant) - (or :reg :constant) - :label)) - -(defopcode :fix= ((or :reg :constant) - (or :reg :constant) - :label)) - -(defopcode :izerop (:reg :label)) - -(defopcode :std-instance-p (:reg :label)) - -(defopcode :fsc-instance-p (:reg :label)) - -(defopcode :built-in-instance-p (:reg :label)) - -(defopcode :structure-instance-p (:reg :label)) - -(defopcode :jmp ((or :reg :constant))) - -(defopcode :label (:label)) - -(defopcode :go (:label)) - -(defopcode :return ((or :reg :constant))) - -(defopcode :exit-lap-in-lisp nil) - - -;;; The actual operands. - - -(defoperand :reg (:register-number)) - -(defoperand :cvar (:symbol)) - -(defoperand :arg (:symbol)) - -(defoperand :cdr (:reg)) - -(defoperand :constant (:t)) - -(defoperand :std-wrapper (:reg)) - -(defoperand :fsc-wrapper (:reg)) - -(defoperand :built-in-wrapper (:reg)) - -(defoperand :structure-wrapper (:reg)) - -(defoperand :other-wrapper (:reg)) - -(defoperand :std-slots (:reg)) - -(defoperand :fsc-slots (:reg)) - -(defoperand :cref (:reg :fixnum)) - -(defoperand :iref (:reg :reg)) - -(defoperand :iset (:reg :reg :reg)) - -(defoperand :i1+ (:reg)) - -(defoperand :i+ (:reg :reg)) - -(defoperand :i- (:reg :reg)) - -(defoperand :ilogand (:reg :reg)) - -(defoperand :ilogxor (:reg :reg)) - -(defoperand :ishift (:reg :fixnum)) - -(defoperand :lisp (:t)) - -(defoperand :lisp-variable (:symbol)) - - -;;; LAP tests (there need to be a lot more of these) - diff --git a/obsolete/clos/2.0/load-clos.lisp b/obsolete/clos/2.0/load-clos.lisp deleted file mode 100644 index 8ba7e9a2..00000000 --- a/obsolete/clos/2.0/load-clos.lisp +++ /dev/null @@ -1,42 +0,0 @@ -;;; -*- Mode: Lisp; Package: xcl-User ; Base: 10.; Syntax: Common-Lisp -*- -;;; - -(in-package "CLOS" :use (list (or (find-package :walker) - (make-package :walker :use '(:lisp))) - (or (find-package :iterate) - (make-package :iterate - :use '(:lisp :walker))) - (find-package :lisp))) -(export (intern (symbol-name :iterate) ;Have to do this here, - (find-package :iterate)) ;because in the defsystem - (find-package :iterate)) ;(later in this file) - ;we use the symbol iterate - ;to name the file - -(defun load-truename (&optional (errorp nil)) - (flet ((bad-time () - (when errorp - (error "LOAD-TRUENAME called but a file isn't being loaded.")))) - (let ((filename (pathname (il:fullname *standard-input*)))) - (if filename - (make-pathname :host (pathname-host filename) :device - (pathname-device filename) :directory - (pathname-directory filename) :name "") - (bad-time))))) - -(defvar *clos-directory* (load-truename)) - -(defun load-clos (&optional pathname) - (defvar *clos-system-date* "7/14/91 Medley 2.0 (interim)") - (defvar *the-clos-package* (find-package :clos)) - (dolist (filename '(patch pkg walk iterate macros low low2 fin - defclass defs fngen lap plap cache dlap boot - vector slots init std-class cpl braid fsc methods - combin dfun precom1 precom2 precom4 fixup - defcombin ctypes construct env)) - - (load (merge-pathnames - (make-pathname :name (string-downcase filename) :type - "dfasl") (or pathname *clos-directory*)))) - (pushnew :clos cl:*features*)) - diff --git a/obsolete/clos/2.0/low.lisp b/obsolete/clos/2.0/low.lisp deleted file mode 100644 index dcd28cef..00000000 --- a/obsolete/clos/2.0/low.lisp +++ /dev/null @@ -1,194 +0,0 @@ - -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;; File converted on 26-Mar-91 10:29:45 from source low -;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>low.;4 created 27-Feb-91 17:16:47 - -;;;. Copyright (c) 1991 by Venue - - - -(in-package "CLOS") - -;;; Shadow, Export, Require, Use-package, and Import forms should follow here - - - -;;; -;;;************************************************************************* -;;;Copyright (c) 1991 Venue -;;; This file contains portable versions of low-level functions and macros which are ripe for -;;; implementation specific customization. None of the code in this file *has* to be customized for -;;; a particular Common Lisp implementation. Moreover, in some implementations it may not make any -;;; sense to customize some of this code. ks. - - -(defmacro %svref (vector index) - `(locally (declare (optimize (speed 3) - (safety 0)) - (inline svref)) - (svref (the simple-vector ,vector) - (the fixnum ,index)))) - -(defsetf %svref (vector index) - (new-value) - `(locally (declare (optimize (speed 3) - (safety 0)) - (inline svref)) - (setf (svref (the simple-vector ,vector) - (the fixnum ,index)) - ,new-value))) - - -;;; without-interrupts OK, Common Lisp doesn't have this and for good reason. But For all of the -;;; Common Lisp's that CLOS runs on today, there is a meaningful way to implement this. WHAT I MEAN -;;; IS: I want the body to be evaluated in such a way that no other code that is running CLOS can be -;;; run during that evaluation. I agree that the body won't take *long* to evaluate. That is to -;;; say that I will only use without interrupts around relatively small computations. INTERRUPTS-ON -;;; should turn interrupts back on if they were on. INTERRUPTS-OFF should turn interrupts back off. -;;; These are only valid inside the body of WITHOUT-INTERRUPTS. OK? - - - -;;; AKW: IT'S CALLED, BUT NEVER REALLY USED, SO I'VE REPLACED IT WITH THE PROGN. IF WE REALLY NEED -;;; IT, CAN BE TRIVIALLY DONE WITH IL:MONITORS - - -(defmacro without-interrupts (&body body) - `(progn ,.body)) - - -;;; Very Low-Level representation of instances with meta-class standard-class. - - -(defmacro std-instance-wrapper (x) - `(%std-instance-wrapper ,x)) - -(defmacro std-instance-slots (x) - `(%std-instance-slots ,x)) - -(defun print-std-instance (instance stream depth) - ; A temporary definition used - (declare (ignore depth)) - ; for debugging the bootstrap - (printing-random-thing (instance stream) - ; code of CLOS (See high.lisp). - (format stream "#"))) - -(defmacro %allocate-instance--class (no-of-slots) - `(let ((instance (%%allocate-instance--class))) - (%allocate-instance--class-1 ,no-of-slots instance) - instance)) - -(defmacro %allocate-instance--class-1 (no-of-slots instance) - (once-only (instance) - `(progn (setf (std-instance-slots ,instance) - (%allocate-static-slot-storage--class ,no-of-slots))))) - - -;;; This is the value that we stick into a slot to tell us that it is unbound. It may seem gross, -;;; but for performance reasons, we make this an interned symbol. That means that the fast check to -;;; see if a slot is unbound is to say (EQ '..SLOT-UNBOUND..). That is considerably faster -;;; than looking at the value of a special variable. Be careful, there are places in the code which -;;; actually use ..slot-unbound.. rather than this variable. So much for modularity - - -(defvar *slot-unbound* '..slot-unbound..) - -(defmacro %allocate-static-slot-storage--class (no-of-slots) - `(make-array ,no-of-slots :initial-element *slot-unbound*)) - -(defmacro std-instance-class (instance) - `(wrapper-class (std-instance-wrapper ,instance))) - - -;; - - - -;;; FUNCTION-ARGLIST - - - -;; - - - -;;; [COMMENTED OUT AKW. NEVER CALLED] Given something which is functionp, function-arglist should -;;; return the argument list for it. CLOS does not count on having this available, but -;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of function-arglist for each -;;; specific port of clos should be put in the appropriate xxx-low file. This is what it should look -;;; like: - - - ; (defun function-arglist (function) - ; ( - ; function)) - - - -;; (FUNCTIONS CLOS::FUNCTION-PRETTY-ARGLIST) (SETFS CLOS::FUNCTION-PRETTY-ARGLIST) (FUNCTIONS -;; CLOS::SET-FUNCTION-PRETTY-ARGLIST) - - - -;;; set-function-name When given a function should give this function the name . Note that -;;; is sometimes a list. Some lisps get the upset in the tummy when they start thinking -;;; about functions which have lists as names. To deal with that there is set-function-name-intern -;;; which takes a list spec for a function name and turns it into a symbol if need be. When given a -;;; funcallable instance, set-function-name MUST side-effect that FIN to give it the name. When -;;; given any other kind of function set-function-name is allowed to return new function which is -;;; the 'same' except that it has the name. In all cases, set-function-name must return the new (or -;;; same) function. - - -(defun set-function-name #'new-name (declare (notinline set-function-name-1 intern-function-name)) - (set-function-name-1 function (intern-function-name new-name) - new-name)) - -(defun set-function-name-1 (fn new-name uninterned-name) - (cond ((typep fn 'il:compiled-closure) - (il:\\rplptr (compiled-closure-fnheader fn) - 4 new-name) - (when (and (consp uninterned-name) - (eq (car uninterned-name) - 'method)) - (let ((debug (si::compiled-function-debugging-info fn))) - (when debug - (setf (cdr debug) - uninterned-name))))) - (t nil)) - fn) - -(defun intern-function-name (name) - (cond ((symbolp name) - name) - ((listp name) - (intern (let ((*package* *the-clos-package*) - (*print-case* :upcase) - (*print-gensym* 't)) - (format nil "~S" name)) - *the-clos-package*)))) - - -;;; COMPILE-LAMBDA This is like the Common Lisp function COMPILE. In fact, that is what it ends up -;;; calling. - - -(defun compile-lambda (lambda &rest desirability) - (declare (ignore desirability)) - (compile nil lambda)) - -(defmacro precompile-random-code-segments (&optional system) - `(progn - (precompile-function-generators ,system) - (precompile-dfun-constructors ,system))) - - - -(defun record-definition (type spec &rest args) - (declare (ignore type spec args)) - ()) - -(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun) \ No newline at end of file diff --git a/obsolete/clos/2.0/low2.lisp b/obsolete/clos/2.0/low2.lisp deleted file mode 100644 index 0c648b9b..00000000 --- a/obsolete/clos/2.0/low2.lisp +++ /dev/null @@ -1,144 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;; File converted on 26-Mar-91 10:30:44 from source xerox-low -;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>xerox-low.;3 created 27-Feb-91 16:37:43 - -;;;. Copyright (c) 1991 by Venue - - - -(in-package "CLOS") - -;;; Shadow, Export, Require, Use-package, and Import forms should follow here - - - -;;; ************************************************************************* This is the 1100 -;;; (Xerox version) of the file portable-low. - - -(defmacro load-time-eval (form) - `(il:loadtimeconstant ,form)) - - -;;; make the pointer from an instance to its class wrapper be an xpointer. this prevents instance -;;; creation from spending a lot of time incrementing the large refcount of the class-wrapper. This -;;; is safe because there will always be some other pointer to the wrapper to keep it around. - - -(defstruct (std-instance (:predicate std-instance-p) - (:conc-name %std-instance-) - (:constructor %%allocate-instance--class nil) - (:fast-accessors t) - (:print-function %print-std-instance)) - (wrapper nil :type il:fullxpointer) - (slots nil)) - -(defun %print-std-instance (instance &optional stream depth) - - ;; See the IRM, section 25.3.3. Unfortunatly, that documentation is not correct. In - ;; particular, it makes no mention of the third argument. - (cond ((streamp stream) - - ;; Use the standard CLOS printing method, then return T to tell the printer that we - ;; have done the printing ourselves. - (print-std-instance instance stream depth) - t) - (t - ;; Internal printing (again, see the IRM section 25.3.3). Return a list containing - ;; the string of characters that would be printed, if the object were being printed - ;; for real. - (list (with-output-to-string (stream) - (print-std-instance instance stream depth)))))) - - -;; - - - -;;; FUNCTION-ARGLIST - - - -;; - - -(defun function-arglist (x) - - ;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and strings instead of - ;; symbols. How silly. - (let ((arglist (il:arglist x))) - (when (symbolp arglist) - - ;; This could be due to trying to extract the arglist of an interpreted function - ;; (though why that should be hard is beyond me). On the other hand, if the - ;; function is compiled, it helps to ask for the "smart" arglist. - (setq arglist (if (consp (symbol-function x)) - (second (symbol-function x)) - (il:arglist x t)))) - (if (symbolp arglist) - - ;; Probably never get here, but just in case - (list '&rest 'rest) - - ;; Make sure there are no strings where there should be symbols - (if (some #'stringp arglist) - (mapcar #'(lambda (a) - (if (symbolp a) - a - (intern a))) - arglist) - arglist)))) - -(defun printing-random-thing-internal (thing stream) - (let ((*print-base* 8)) - (princ (il:\\hiloc thing) - stream) - (princ "," stream) - (princ (il:\\loloc thing) - stream))) - -(defun record-definition (name type &optional parent-name parent-type) - (declare (ignore type parent-name)) - nil) - - -;;; FIN uses this too! - - -(eval-when (compile load eval) - (il:datatype il:compiled-closure (il:fnheader il:environment)) - (il:blockrecord closure-overlay ((funcallable-instance-p il:flag)))) - -(defun compiled-closure-fnheader (compiled-closure) - (il:fetch (il:compiled-closure il:fnheader) - il:of compiled-closure)) - -(defun set-compiled-closure-fnheader (compiled-closure nv) - (il:replace (il:compiled-closure il:fnheader) - il:of compiled-closure nv)) - -(defsetf compiled-closure-fnheader set-compiled-closure-fnheader) - - -;;; In Lyric, and until the format of FNHEADER changes, getting the name from a compiled closure -;;; looks like this: (fetchfield '(nil 4 pointer) (fetch (compiled-closure fnheader) closure)) Of -;;; course this is completely non-robust, but it will work for now. This is not the place to go -;;; into a long tyrade about what is wrong with having record package definitions go away when you -;;; ship the sysout; there isn't enough diskspace. - - -(defun set-function-name-1 (fn new-name uninterned-name) - (cond ((typep fn 'il:compiled-closure) - (il:\\rplptr (compiled-closure-fnheader fn) - 4 new-name) - (when (and (consp uninterned-name) - (eq (car uninterned-name) - 'method)) - (let ((debug (si::compiled-function-debugging-info fn))) - (when debug - (setf (cdr debug) - uninterned-name))))) - (t nil)) - fn) diff --git a/obsolete/clos/2.0/macros.lisp b/obsolete/clos/2.0/macros.lisp deleted file mode 100644 index 4f6a294d..00000000 --- a/obsolete/clos/2.0/macros.lisp +++ /dev/null @@ -1,355 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;; File converted on 26-Mar-91 10:27:21 from source macros -;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>macros.;3 created 19-Feb-91 13:51:21 - -;;;. Copyright (c) 1991 Venue - - - -(in-package "CLOS") - - -;;;Macros global variable -;;; definitions, and other random support stuff used by the rest of the system. For simplicity (not -;;; having to use eval-when a lot), this file must be loaded before it can be compiled. - - -(in-package 'clos) - -(proclaim '(declaration values arglist indentation class variable-rebinding clos-fast-call)) - - -;;; Age old functions which CommonLisp cleaned-up away. They probably exist in other packages in -;;; all CommonLisp implementations, but I will leave it to the compiler to optimize into calls to -;;; them. Common Lisp BUG: Some Common Lisps define these in the Lisp package which causes all sorts -;;; of lossage. Common Lisp should explictly specify which symbols appear in the Lisp package. - - -(eval-when (compile load eval) - (defmacro memq (item list) - `(member ,item ,list :test #'eq)) - (defmacro assq (item list) - `(assoc ,item ,list :test #'eq)) - (defmacro rassq (item list) - `(rassoc ,item ,list :test #'eq)) - (defmacro delq (item list) - `(delete ,item ,list :test #'eq)) - (defmacro posq (item list) - `(position ,item ,list :test #'eq)) - (defmacro neq (x y) - `(not (eq ,x ,y))) - (defun make-caxr (n form) - (if (< n 4) - `(,(nth n '(car cadr caddr cadddr)) - ,form) - (make-caxr (- n 4) - `(cddddr ,form)))) - (defun make-cdxr (n form) - (cond ((zerop n) - form) - ((< n 5) - `(,(nth n '(identity cdr cddr cdddr cddddr)) - ,form)) - (t (make-cdxr (- n 4) - `(cddddr ,form)))))) - -(defun zero (&rest ignore) - (declare (ignore ignore)) - 0) - -(defun make-plist (keys vals) - (if (null vals) - nil - (list* (car keys) - (car vals) - (make-plist (cdr keys) - (cdr vals))))) - -(defun remtail (list tail) - (if (eq list tail) - nil - (cons (car list) - (remtail (cdr list) - tail)))) - - -;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just lifted it from there -;;; but I am honest. Not only that but this one is written in Common Lisp. I feel a lot like -;;; bootstrapping, or maybe more like rebuilding Rome. - - -(defmacro once-only (vars &body body) - (let ((gensym-var (gensym)) - (run-time-vars (gensym)) - (run-time-vals (gensym)) - (expand-time-val-forms nil)) - (dolist (var vars) - (push `(if (or (symbolp ,var) - (numberp ,var) - (and (listp ,var) - (member (car ,var) - ''function))) - ,var - (let ((,gensym-var (gensym))) - (push ,gensym-var ,run-time-vars) - (push ,var ,run-time-vals) - ,gensym-var)) - expand-time-val-forms)) - `(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars - (reverse - expand-time-val-forms - )) - ,@body))) - `(let ,(mapcar #'list (reverse ,run-time-vars) - (reverse ,run-time-vals)) - ,wrapped-body)))) - -(eval-when - (compile load eval) - (defun extract-declarations (body &optional environment) - (declare (values documentation declarations body)) - (let (documentation declarations form) - (when (and (stringp (car body)) - (cdr body)) - (setq documentation (pop body))) - (block outer - (loop (when (null body) - (return-from outer nil)) - (setq form (car body)) - (when (block inner - (loop (cond ((not (listp form)) - (return-from outer nil)) - ((eq (car form) - 'declare) - (return-from inner 't)) - (t (multiple-value-bind - (newform macrop) - (macroexpand-1 form environment) - (if (or (not (eq newform form)) - macrop) - (setq form newform) - (return-from outer nil))))))) - (pop body) - (dolist (declaration (cdr form)) - (push declaration declarations))))) - (values documentation (and declarations `((declare ,.(nreverse declarations)))) - body)))) - -(defvar *keyword-package* (find-package 'keyword)) - -(defun make-keyword (symbol) - (intern (symbol-name symbol) - *keyword-package*)) - -(eval-when (compile load eval) - (defun string-append (&rest strings) - (setq strings (copy-list strings)) - ; The explorer can't even rplaca an - ; &rest arg? - (do ((string-loc strings (cdr string-loc))) - ((null string-loc) - (apply #'concatenate 'string strings)) - (rplaca string-loc (string (car string-loc)))))) - -(defun symbol-append (sym1 sym2 &optional (package *package*)) - (intern (string-append sym1 sym2) - package)) - -(defmacro check-member (place list &key (test #'eql) - (pretty-name place)) - (once-only (place list) - `(or (member ,place ,list :test ,test) - (error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list)))) - -(defmacro alist-entry (alist key make-entry-fn) - (once-only (alist key) - `(or (assq ,key ,alist) - (progn (setf ,alist (cons (,make-entry-fn ,key) - ,alist)) - (car ,alist))))) - -(defmacro collecting-once (&key initial-value) - `(let* ((head ,initial-value) - (tail ,(and initial-value `(last head)))) - (values #'(lambda (value) - (if (null head) - (setq head (setq tail (list value))) - (unless (memq value head) - (setq tail (cdr (rplacd tail (list value))))))) - #'(lambda nil head)))) - -(defmacro doplist ((key val) - plist &body body &environment env) - (multiple-value-bind (doc decls bod) - (extract-declarations body env) - (declare (ignore doc)) - `(let ((.plist-tail. ,plist) - ,key - ,val) - ,@decls - (loop (when (null .plist-tail.) - (return nil)) - (setq ,key (pop .plist-tail.)) - (when (null .plist-tail.) - (error "Malformed plist in doplist, odd number of elements.")) - (setq ,val (pop .plist-tail.)) - (progn ,@bod))))) - -(defmacro if* (condition true &rest false) - `(if ,condition - ,true - (progn ,@false))) - - -;; - - - -;;; printing-random-thing - - - -;; - - - -;;; Similar to printing-random-object in the lisp machine but much simpler and machine independent. - - -(defmacro printing-random-thing ((thing stream) - &body body) - (once-only (stream) - `(progn (format ,stream "#<") - ,@body - (format ,stream " ") - (printing-random-thing-internal ,thing ,stream) - (format ,stream ">")))) - -(defun printing-random-thing-internal (thing stream) - (let ((*print-base* 8)) - (princ (il:\\hiloc thing) - stream) - (princ "," stream) - (princ (il:\\loloc thing) - stream))) - - -;; - - - -;;; - - - -;; - - -(defun capitalize-words (string &optional (dashes-p t)) - (let ((string (copy-seq (string string)))) - (declare (string string)) - (do* ((flag t flag) - (length (length string) - length) - (char nil char) - (i 0 (+ i 1))) - ((= i length) - string) - (setq char (elt string i)) - (cond ((both-case-p char) - (if flag - (and (setq flag (lower-case-p char)) - (setf (elt string i) - (char-upcase char))) - (and (not flag) - (setf (elt string i) - (char-downcase char)))) - (setq flag nil)) - ((char-equal char #\-) - (setq flag t) - (unless dashes-p - (setf (elt string i) - #\Space))) - (t (setq flag nil)))))) - - -;;; FIND-CLASS This is documented in the CLOS specification. - - -(defvar *find-class* (make-hash-table :test #'eq)) - -(defun legal-class-name-p (x) - (and (symbolp x) - (not (keywordp x)))) - -(defun find-class (symbol &optional (errorp t) - environment) - (declare (ignore environment)) - (or (gethash symbol *find-class*) - (cond ((null errorp) - nil) - ((legal-class-name-p symbol) - (error "No class named: ~S." symbol)) - (t (error "~S is not a legal class name." symbol))))) - -(defsetf find-class (symbol &optional (errorp t) - environment) - (new-value) - (declare (ignore errorp environment)) - `(|SETF CLOS FIND-CLASS| ,new-value ,symbol)) - -(defun |SETF CLOS FIND-CLASS| (new-value symbol) - (if (legal-class-name-p symbol) - (setf (gethash symbol *find-class*) - new-value) - (error "~S is not a legal class name." symbol))) - -(defun find-wrapper (symbol) - (class-wrapper (find-class symbol))) - -(defmacro gathering1 (gatherer &body body) - `(gathering ((.gathering1. ,gatherer)) - (macrolet ((gather1 (x) - `(gather ,x .gathering1.))) - ,@body))) - - -;;; - - -(defmacro vectorizing (&key (size 0)) - `(let* ((limit ,size) - (result (make-array limit)) - (index 0)) - (values #'(lambda (value) - (if (= index limit) - (error "vectorizing more elements than promised.") - (progn (setf (svref result index) - value) - (incf index) - value))) - #'(lambda nil result)))) - - -;;; These are augmented definitions of list-elements and list-tails from iterate.lisp. These -;;; versions provide the extra :by keyword which can be used to specify the step function through -;;; the list. - - -(defmacro *list-elements (list &key (by #'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (if (endp tail) - (funcall finish) - (prog1 (car tail) - (setq tail (funcall ,by tail))))))) - -(defmacro *list-tails (list &key (by #'cdr)) - `(let ((tail ,list)) - #'(lambda (finish) - (prog1 (if (endp tail) - (funcall finish) - tail) - (setq tail (funcall ,by tail)))))) diff --git a/obsolete/clos/2.0/methods.lisp b/obsolete/clos/2.0/methods.lisp deleted file mode 100644 index fa52befe..00000000 --- a/obsolete/clos/2.0/methods.lisp +++ /dev/null @@ -1,1304 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;;. Copyright (c) 1991 by Venue - -(in-package "CLOS") - - - -;;; METHODS Methods themselves are simple inanimate objects. Most properties of methods are -;;; immutable, methods cannot be reinitialized. The following properties of methods can be changed: -;;; METHOD-GENERIC-FUNCTION METHOD-FUNCTION ?? - -(defclass method (metaobject) ()) - -(defclass standard-method (definition-source-mixin documentation-mixin method) - ((generic-function - :initform nil - :accessor method-generic-function) -; (qualifiers -; :initform () -; :initarg :qualifiers -; :reader method-qualifiers) - (specializers - :initform () - :initarg :specializers - :reader method-specializers) - (lambda-list - :initform () - :initarg :lambda-list - :reader method-lambda-list) - (function - :initform nil - :initarg :function - :reader method-function) ;writer defined by hand -; (documentation -; :initform "" -; :initarg :documentation) - )) - -(defclass standard-accessor-method (standard-method) - ((slot-name :initform nil - :initarg :slot-name))) - - -;;; This method has to be defined by hand! Don't try to define it using :accessor or :reader. It -;;; can't be an automatically generated reader method because that would break the way the special -;;; discriminator code which uses this feature works. -- Probably false now 8/21 - - -(defmethod accessor-method-slot-name ((m standard-accessor-method)) - (slot-value m 'slot-name)) - -(defclass standard-reader-method (standard-accessor-method) ()) -(defclass standard-writer-method (standard-accessor-method) ()) - -(defmethod print-object ((method standard-method) - stream) - (printing-random-thing (method stream) - (let ((generic-function (method-generic-function method)) - (class-name (capitalize-words (class-name (class-of method))))) - (format stream "~A ~S ~{~S ~}~:S" class-name (and generic-function ( - generic-function-name - - generic-function - )) - (method-qualifiers method) - (unparse-specializers method))))) - -(defmethod print-object ((method standard-accessor-method) - stream) - (printing-random-thing (method stream) - (let ((generic-function (method-generic-function method)) - (class-name (capitalize-words (class-name (class-of method))))) - (format stream "~A ~S, slot:~S, ~:S" class-name (and generic-function ( - generic-function-name - - generic-function - )) - (accessor-method-slot-name method) - (unparse-specializers method))))) - - -;;; INITIALIZATION Error checking is done in before methods. Because of the simplicity of standard -;;; method objects the standard primary method can fill the slots. Methods are not reinitializable. - - -(defmethod reinitialize-instance ((method standard-method) - &rest initargs) - (declare (ignore initargs)) - (error - "Attempt to reinitialize the method ~S.~%~ - Method objects cannot be reinitialized." method)) - -(defmethod shared-initialize :before ((method standard-method) - slot-names &key qualifiers lambda-list specializers function - documentation) - (declare (ignore slot-names)) - (flet ((lose (initarg value string) - (error "When initializing the method ~S:~%~ - The ~S initialization argument was: ~S.~%~ - which ~A." method initarg value string))) - (let ((check-qualifiers (legal-std-qualifiers-p qualifiers)) - (check-lambda-list (legal-std-lambda-list-p lambda-list)) - (check-specializers (legal-std-specializers-p specializers)) - (check-function (legal-std-method-function-p function)) - (check-documentation (legal-std-documentation-p documentation))) - (unless (eq check-qualifiers t) - (lose :qualifiers qualifiers check-qualifiers)) - (unless (eq check-lambda-list t) - (lose :lambda-list lambda-list check-lambda-list)) - (unless (eq check-specializers t) - (lose :specializers specializers check-specializers)) - (unless (eq check-function t) - (lose :function function check-function)) - (unless (eq check-documentation t) - (lose :documentation documentation check-documentation))))) - -(defmethod shared-initialize :before ((method standard-accessor-method) - slot-names &key slot-name) - (declare (ignore slot-names)) - (let ((legalp (legal-std-slot-name-p slot-name))) - (unless (eq legalp t) - (error "The value of the :SLOT-NAME initarg ~A." legalp)))) - -(defmethod shared-initialize :after ((method standard-method) - slot-names &key qualifiers) - (setf (plist-value method 'qualifiers) - qualifiers)) - -(defmethod method-qualifiers ((method standard-method)) - (plist-value method 'qualifiers)) - -(defclass generic-function (dependent-update-mixin - definition-source-mixin - metaobject) - () - (:metaclass funcallable-standard-class)) - -(defclass standard-generic-function (generic-function) - ((name - :initform nil - :initarg :name - :accessor generic-function-name) - (methods - :initform () - :accessor generic-function-methods) - (method-class - :initarg :method-class - :accessor generic-function-method-class) - (method-combination - :initarg :method-combination - :accessor generic-function-method-combination) - -; (permutation -; :accessor gf-permutation) - (arg-info - :initform () - :accessor gf-arg-info) - (dfun-state - :initform () - :accessor gf-dfun-state) - (effective-method-functions ;((methods . fn) ..) - :initform () - :accessor gf-effective-method-functions) - (valid-p - :initform nil - :accessor gf-valid-p) - (pretty-arglist - :initform () - :accessor gf-pretty-arglist) - ) - (:metaclass funcallable-standard-class) - (:default-initargs :method-class *the-class-standard-method* - :method-combination *standard-method-combination*)) - - -(define-gf-predicate generic-function-p generic-function) - -(define-gf-predicate method-p method) - -(define-gf-predicate standard-accessor-method-p standard-accessor-method) - -(define-gf-predicate standard-reader-method-p standard-reader-method) - -(define-gf-predicate standard-writer-method-p standard-writer-method) - -(defvar *the-class-method* (find-class 'method)) - -(defvar *the-class-standard-method* (find-class 'standard-method)) - -(defvar *the-class-generic-function* (find-class 'generic-function)) - -(defvar *the-class-standard-generic-function* (find-class 'standard-generic-function)) - -(defmethod print-object ((generic-function generic-function) - stream) - (named-object-print-function generic-function stream (list (length (generic-function-methods - generic-function))))) - -(defmethod shared-initialize :before ((generic-function standard-generic-function) - slot-names &key (name nil namep) - (lambda-list nil lambda-list-p) - argument-precedence-order declarations documentation - (method-class nil method-class-supplied-p) - (method-combination nil method-combination-supplied-p)) - (declare (ignore slot-names declarations argument-precedence-order lambda-list lambda-list-p - name)) - (when namep (set-function-name generic-function name)) - (flet ((initarg-error (initarg value string) - (error "When initializing the generic-function ~S:~%~ - The ~S initialization argument was: ~A.~%~ - It must be ~A." generic-function initarg value string))) - (cond (method-class-supplied-p (when (symbolp method-class) - (setq method-class (find-class method-class))) - (unless (and (classp method-class) - (*subtypep method-class *the-class-method*)) - (initarg-error :method-class method-class - "a subclass of the class METHOD")) - (setf (slot-value generic-function 'method-class) - method-class)) - ((slot-boundp generic-function 'method-class)) - (t (initarg-error :method-class "not supplied" "a subclass of the class METHOD"))) - (cond (method-combination-supplied-p (unless (method-combination-p method-combination) - (initarg-error :method-combination - method-combination - "a method combination object"))) - ((slot-boundp generic-function 'method-combination)) - (t (initarg-error :method-combination "not supplied" "a method combination object" - ))))) - -(defmethod initialize-instance :after ((gf standard-generic-function) - &key lambda-list argument-precedence-order) - (declare (ignore slot-names)) - (when lambda-list - (setf (gf-arg-info gf) - (new-arg-info-from-generic-function lambda-list argument-precedence-order)))) - -(defmethod reinitialize-instance ((generic-function standard-generic-function) - &rest initargs &key name lambda-list argument-precedence-order - declarations documentation method-class method-combination) - (declare (ignore documentation declarations argument-precedence-order lambda-list name - method-class method-combination)) - (macrolet ((add-initarg (check name slot-name) - `(unless ,check - (push (slot-value generic-function ,slot-name) - initargs) - (push ,name initargs)))) - ; (add-initarg name :name 'name) - ; (add-initarg lambda-list :lambda-list - ; 'lambda-list) (add-initarg - ; argument-precedence-order - ; :argument-precedence-order - ; 'argument-precedence-order) - ; (add-initarg declarations - ; :declarations 'declarations) - ; (add-initarg documentation - ; :documentation 'documentation) - ; (add-initarg method-class - ; :method-class 'method-class) - ; (add-initarg method-combination - ; :method-combination - ; 'method-combination) - (apply #'call-next-method generic-function initargs))) - - -;;; These three are scheduled for demolition. - - -(defmethod remove-named-method (generic-function-name argument-specifiers &optional extra) - (let ((generic-function nil) - (method nil)) - (cond ((or (null (fboundp generic-function-name)) - (not (generic-function-p (setq generic-function (symbol-function - generic-function-name)) - ))) - (error "~S does not name a generic-function." generic-function-name)) - ((null (setq method (get-method generic-function extra (parse-specializers - argument-specifiers) - nil))) - (error "There is no method for the generic-function ~S~%~ - which matches the argument-specifiers ~S." generic-function argument-specifiers)) - (t (remove-method generic-function method))))) - -(defun real-add-named-method (generic-function-name qualifiers specializers lambda-list function - &rest other-initargs) - - ;; What about changing the class of the generic-function if there is one. Whose job is that - ;; anyways. Do we need something kind of like class-for-redefinition? - (let* ((generic-function (ensure-generic-function generic-function-name :lambda-list - (method-ll->generic-function-ll lambda-list))) - (specs (parse-specializers specializers)) - ; (existing (get-method - ; generic-function qualifiers specs - ; nil)) - (proto (method-prototype-for-gf generic-function-name)) - (new (apply #'make-instance (class-of proto) - :qualifiers qualifiers :specializers specs :lambda-list lambda-list - :function function other-initargs))) - ; (when existing (remove-method - ; generic-function existing)) - (add-method generic-function new))) - -(defun make-specializable (function-name &key (arglist nil arglistp)) - (cond ((not (null arglistp))) - ((not (fboundp function-name))) - ((fboundp 'function-arglist) - - ;; function-arglist exists, get the arglist from it. - (setq arglist (function-arglist function-name))) - (t (error "The :arglist argument to make-specializable was not supplied~%~ - and there is no version of FUNCTION-ARGLIST defined for this~%~ - port of Portable CommonLoops.~%~ - You must either define a version of FUNCTION-ARGLIST (which~%~ - should be easy), and send it off to the Portable CommonLoops~%~ - people or you should call make-specializable again with the~%~ - :arglist keyword to specify the arglist."))) - (let ((original (and (fboundp function-name) - (symbol-function function-name))) - (generic-function (make-instance 'standard-generic-function :name function-name)) - (nrequireds 0)) - (if (generic-function-p original) - original - (progn (dolist (arg arglist) - (if (memq arg lambda-list-keywords) - (return) - (incf nrequireds))) - (setf (symbol-function function-name) - generic-function) - (set-function-name generic-function function-name) - (when arglistp - (setf (gf-pretty-arglist generic-function) - arglist)) - (when original - (add-named-method function-name nil (make-list nrequireds :initial-element - 't) - arglist original)) - generic-function)))) - -(defun real-get-method (generic-function qualifiers specializers &optional (errorp t)) - (let ((hit (dolist (method (generic-function-methods generic-function)) - (when (and (equal qualifiers (method-qualifiers method)) - (every #'same-specializer-p specializers (method-specializers method - ))) - (return method))))) - (cond (hit hit) - ((null errorp) - nil) - (t (error "No method on ~S with qualifiers ~:S and specializers ~:S." - generic-function qualifiers specializers))))) - - -;;; Compute various information about a generic-function's arglist by looking at the argument lists -;;; of the methods. The hair for trying not to use &rest arguments lives here. The values returned -;;; are: number-of-required-arguments the number of required arguments to this generic-function's -;;; discriminating function &rest-argument-p whether or not this generic-function's discriminating -;;; function takes an &rest argument. specialized-argument-positions a list of the positions of the -;;; arguments this generic-function specializes (e.g. for a classical generic-function this is the -;;; list: (1)). - - -(defmethod compute-discriminating-function-arglist-info ((generic-function standard-generic-function) - ) - (declare (values number-of-required-arguments &rest-argument-p specialized-argument-postions)) - (let ((number-required nil) - (restp nil) - (specialized-positions nil) - (methods (generic-function-methods generic-function))) - (dolist (method methods) - (multiple-value-setq (number-required restp specialized-positions) - (compute-discriminating-function-arglist-info-internal generic-function method - number-required restp specialized-positions))) - (values number-required restp (sort specialized-positions #'<)))) - -(defun compute-discriminating-function-arglist-info-internal (generic-function method - number-of-requireds restp - specialized-argument-positions) - (declare (ignore generic-function)) - (let ((requireds 0)) - - ;; Go through this methods arguments seeing how many are required, and whether there is - ;; an &rest argument. - (dolist (arg (method-lambda-list method)) - (cond ((eq arg '&aux) - (return)) - ((memq arg '(&optional &rest &key)) - (return (setq restp t))) - ((memq arg lambda-list-keywords)) - (t (incf requireds)))) - - ;; Now go through this method's type specifiers to see which argument positions are type - ;; specified. Treat T specially in the usual sort of way. For efficiency don't bother - ;; to keep specialized-argument-positions sorted, rather depend on our caller to do - ;; that. - (iterate ((type-spec (list-elements (method-specializers method))) - (pos (interval :from 0))) - (unless (eq type-spec *the-class-t*) - (pushnew pos specialized-argument-positions))) - - ;; Finally merge the values for this method into the values for the exisiting methods - ;; and return them. Note that if num-of-requireds is NIL it means this is the first - ;; method and we depend on that. - (values (min (or number-of-requireds requireds) - requireds) - (or restp (and number-of-requireds (/= number-of-requireds requireds))) - specialized-argument-positions))) - -(defun make-discriminating-function-arglist (number-required-arguments restp) - (nconc (gathering ((args (collecting))) - (iterate ((i (interval :from 0 :below number-required-arguments))) - (gather (intern (format nil "Discriminating Function Arg ~D" i)) - args))) - (when restp - `(&rest ,(intern "Discriminating Function &rest Arg"))))) - - -;;; - - -(defun make-arg-info (precedence metatypes number-optional key/rest-p keywords) - (let ((new (make-array 6 :adjustable nil))) - (setf (svref new 0) - 'arg-info - (svref new 1) - precedence - (svref new 2) - metatypes - (svref new 3) - number-optional - (svref new 4) - key/rest-p - (svref new 5) - keywords) - ; nil no keyword or rest - ; allowed (k1 k2 ..) each method must - ; accept these keyword arguments T - ; must have &key or &rest - new)) - -(defun check-arg-info (x) - (or (and (simple-vector-p x) - (= (array-dimension x 0) - 6) - (eq (svref x 0) - 'arg-info)) - (error "~S is not an ARG-INFO." x))) - -(defun arg-info-precedence (arg-info) - (check-arg-info arg-info) - (svref arg-info 1)) - -(defun arg-info-metatypes (arg-info) - (check-arg-info arg-info) - (svref arg-info 2)) - -(defun arg-info-number-optional (arg-info) - (check-arg-info arg-info) - (svref arg-info 3)) - -(defun arg-info-key/rest-p (arg-info) - (check-arg-info arg-info) - (svref arg-info 4)) - -(defun arg-info-keywords (arg-info) - (check-arg-info arg-info) - (svref arg-info 5)) - -(defun arg-info-applyp (arg-info) - (check-arg-info arg-info) - (or (plusp (arg-info-number-optional arg-info)) - (arg-info-key/rest-p arg-info))) - -(defun arg-info-number-required (arg-info) - (check-arg-info arg-info) - (length (arg-info-metatypes arg-info))) - -(defun arg-info-nkeys (arg-info) - (count-if #'(lambda (x) - (neq x 't)) - (arg-info-metatypes arg-info))) - -(defun new-arg-info-from-generic-function (lambda-list argument-precedence-order) - (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list lambda-list) - (declare (ignore allow-other-keys-p)) - (let ((metatypes (make-list nreq)) - (precedence (compute-precedence lambda-list nreq argument-precedence-order))) - (make-arg-info precedence metatypes nopt (or keysp restp) - keywords)))) - -(defun new-arg-info-from-method (method) - (multiple-value-bind (nreq nopt keysp restp) - (analyze-lambda-list (method-lambda-list method)) - (make-arg-info (compute-precedence (method-lambda-list method) - nreq nil) - (mapcar #'raise-metatype (make-list nreq) - (method-specializers method)) - nopt - (or keysp restp) - nil))) - -(defun add-arg-info (generic-function method arg-info) - (flet ((lose (string &rest args) - (error - "Attempt to add the method ~S to the generic function ~S.~%~ - But ~A" method generic-function (apply #'format nil string args))) - (compare (x y) - (if (> x y) - "more" - "fewer"))) - (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list (method-lambda-list method)) - (let ((gf-nreq (arg-info-number-required arg-info)) - (gf-nopt (arg-info-number-optional arg-info)) - (gf-key/rest-p (arg-info-key/rest-p arg-info)) - (gf-keywords (arg-info-keywords arg-info))) - (unless (= nreq gf-nreq) - (lose "the method has ~A required arguments than the generic function." - (compare nreq gf-nreq))) - (unless (= nopt gf-nopt) - (lose "the method has ~S optional arguments than the generic function." - (compare nopt gf-nopt))) - (unless (eq (or keysp restp) - gf-key/rest-p) - (error "the method and generic function differ in whether they accept~%~ - rest or keyword arguments.")) - (when gf-keywords - (unless (or (and restp (not keysp)) - allow-other-keys-p - (every #'(lambda (k) - (memq k keywords)) - gf-keywords)) - (error "the generic function requires each method to accept the keyword arguments~%~ - ~S. The method does not all of accept these." gf-keywords))) - (make-arg-info (arg-info-precedence arg-info) - (mapcar #'raise-metatype (arg-info-metatypes arg-info) - (method-specializers method)) - gf-nopt gf-key/rest-p gf-keywords))))) - -(defun remove-arg-info (generic-function method arg-info) - (declare (ignore generic-function method)) - arg-info) - - -;;; - - -(defun compute-precedence (lambda-list nreq argument-precedence-order) - (let ((nreq (analyze-lambda-list lambda-list))) - (if (null argument-precedence-order) - (let ((c -1)) - (gathering1 (collecting) - (dotimes (i nreq) - (gather1 (incf c))))) - (mapcar #'(lambda (x) - (position x lambda-list)) - argument-precedence-order)))) - -(defmethod no-applicable-method (generic-function &rest args) - (cerror "Retry call to ~S" - "No matching method for the generic-function ~S,~@ - when called with arguments ~S." generic-function args) - (let ((*invalid-dfuns-on-stack* (remove generic-function *invalid-dfuns-on-stack*))) - (invalidate-discriminating-function generic-function) - (apply generic-function args))) - -(defun real-add-method (generic-function method) - (if (method-generic-function method) - (error "The method ~S is already part of the generic~@ - function ~S. It can't be added to another generic~@ - function until it is removed from the first one." method (method-generic-function - method)) - (let* ((qualifiers (method-qualifiers method)) - (lambda-list (method-lambda-list method)) - (specializers (method-specializers method)) - (existing (get-method generic-function qualifiers specializers nil))) - - ;; If there is already a method like this one then we must get rid of it before - ;; proceeding. Note that we call the generic function remove-method to remove it - ;; rather than doing it in some internal way. - (when existing (remove-method generic-function existing)) - - ;; - (let ((arg-info (gf-arg-info generic-function))) - (setf (gf-arg-info generic-function) - (if (null arg-info) - (new-arg-info-from-method method) - (add-arg-info generic-function method arg-info))) - (setf (method-generic-function method) - generic-function) - (pushnew method (generic-function-methods generic-function)) - (dolist (specializer specializers) - (add-method-on-specializer method specializer)) - (invalidate-discriminating-function generic-function) - (maybe-update-constructors generic-function method) - method)))) - -(defun real-remove-method (generic-function method) - (if (neq generic-function (method-generic-function method)) - (error "The method ~S is attached to the generic function~@ - ~S. It can't be removed from the generic function~@ - to which it is not attached." method (method-generic-function method)) - (let* ((methods (generic-function-methods generic-function)) - (new-methods (remove method methods)) - (new-arg-info (remove-arg-info generic-function method (gf-arg-info - generic-function)))) - (setf (method-generic-function method) - nil) - (setf (generic-function-methods generic-function) - new-methods) - (dolist (specializer (method-specializers method)) - (remove-method-on-specializer method specializer)) - (setf (gf-arg-info generic-function) - new-arg-info) - (invalidate-discriminating-function generic-function) - (maybe-update-constructors generic-function method) - generic-function))) - - -;;; This is it. You have reached the special place where everything comes together. This is where -;;; we ensure that the metacircularity will bottom out properly. Remember once again that the source -;;; of the problem is that the specified behavior clearly calls for the process of method lookup to -;;; itself call generic functions. This implies that for a given generic function in the method -;;; lookup protocol (compute-applicable-methods for example), we can end up in the unfortunate -;;; situation of having to call that generic function in order to call it! So, we must arrange to -;;; snap this infinite regress. The strategy taken here is to identify a particular subset of calls -;;; to method lookup protocol generic functions and snap the recursion there. This subset of generic -;;; function calls has the following properties: - Any generic function call in the world will, -;;; eventually reach one of these generic function calls. That is we are sure that if we can -;;; arrange for these calls not to recurse we know we are all set. - These calls themselves don't -;;; recurse. We arrange, by magic, for the method lookup and application involved in these calls -;;; not to call any other generic functions. - - -(defvar *magic-generic-functions* '((compute-discriminating-function ((standard-generic-function) - (standard-generic-function))) - (compute-applicable-methods ((standard-generic-function t) - (generic-function t))) - (compute-applicable-methods-using-classes (( - standard-generic-function - t) - (generic-function - t))) - ; (same-specializer-p - ; ((standard-class standard-class) (t - ; t))) (specializer-applicable-p - ; ((standard-class t) (class t))) - (specializer-applicable-using-class-p ((standard-class t) - (class t)) - ((built-in-class t) - (class t))) - (order-specializers-using-class ((standard-class standard-class t - ) - (class class t))) - (compute-effective-method ((standard-generic-function - (eql *standard-method-combination*) - t) - (generic-function - standard-method-combination t)) - ) - (method-p ((standard-method) - (method)) - ((standard-reader-method) - (method)) - ((standard-writer-method) - (method))) - (standard-accessor-method-p ((standard-method) - (t)) - ((standard-reader-method) - (standard-accessor-method)) - ((standard-writer-method) - (standard-accessor-method))) - (standard-reader-method-p ((standard-method) - (t)) - ((standard-reader-method) - (standard-reader-method)) - ((standard-writer-method) - (t))) - (standard-writer-method-p ((standard-method) - (t)) - ((standard-reader-method) - (t)) - ((standard-writer-method) - (standard-writer-method))) - (method-qualifiers ((standard-method) - (standard-method)) - ((standard-reader-method) - (standard-method))) - (method-specializers ((standard-method) - (standard-method)) - ((standard-reader-method) - (standard-method))) - (method-lambda-list ((standard-method) - (standard-method)) - ((standard-reader-method) - (standard-method))) - (method-function ((standard-method) - (standard-method)) - ((standard-reader-method) - (standard-method))) - (accessor-method-slot-name ((standard-reader-method) - (standard-accessor-method)) - ((standard-writer-method) - (standard-accessor-method))) - (classp ((standard-class) - (class)) - ((built-in-class) - (class))) - (class-precedence-list ((standard-class) - (clos-class))) - (class-finalized-p ((standard-class) - (clos-class))) - (generic-function-methods ((standard-generic-function) - (standard-generic-function))) - (generic-function-method-combination ((standard-generic-function) - (standard-generic-function) - )) - (gf-arg-info ((standard-generic-function) - (standard-generic-function))) - (gf-dfun-state ((standard-generic-function) - (standard-generic-function))) - (gf-effective-method-functions ((standard-generic-function) - (standard-generic-function))) - ((setf gf-effective-method-functions) - ((t standard-generic-function) - (t standard-generic-function))) - ; (gf-permutation - ; ((standard-generic-function) - ; (standard-generic-function))) - (slot-value-using-class ((standard-class t - standard-effective-slot-definition - ) - ; the first t is a bug - (std-class standard-object - standard-effective-slot-definition - )) - ((funcallable-standard-class t - standard-effective-slot-definition) - (std-class standard-object - standard-effective-slot-definition))) - ((setf slot-value-using-class) - ((t standard-class t standard-effective-slot-definition) - (t std-class standard-object standard-effective-slot-definition - )) - ((t funcallable-standard-class t - standard-effective-slot-definition) - (t std-class standard-object standard-effective-slot-definition - ))))) - -(defvar *magic-generic-functions-1* nil) - -(defun - fixup-magic-generic-function - (gfspec early-methods gf methods) - (flet - ((get-specls (names convert-t-p) - (mapcar #'(lambda (s) - (cond ((consp s) - `(eql ,(eval (cadr s)))) - ((eq s t) - (if convert-t-p - (find-class t) - t)) - (t (find-class s)))) - names))) - (let - ((e (assoc gfspec *magic-generic-functions* :test #'equal))) - (when e - (push (list* gf (make-arg-info - nil - (apply #'mapcar #'(lambda (&rest args) - (if (every #'(lambda (arg) - (eq arg 't)) - args) - 't - 'standard-instance)) - (mapcar #'second (cdr e))) - nil nil nil) - (gathering1 (collecting) - (dolist (pair (cdr e)) - (iterate ((em (list-elements early-methods)) - (m (list-elements methods))) - (when (equal (early-method-specializers em t) - (get-specls (cadr pair) - t)) - (gather1 (list (get-specls (car pair) - nil) - (list m) - (early-method-function em))) - (return t)))))) - *magic-generic-functions-1*))))) - -(defun get-secondary-dispatch-function (generic-function args) - (declare (values compiled-secondary-dispatch-function methods arg-info)) - (multiple-value-bind (fn methods arg-info) - (get-magic-secondary-dispatch-function generic-function args) - (if fn - (values fn methods arg-info) - (get-normal-secondary-dispatch-function generic-function args)))) - -(defun get-magic-secondary-dispatch-function (generic-function args) - (let ((e (assq generic-function *magic-generic-functions-1*))) - (when e - (dolist (entry (cddr e)) - (destructuring-bind (specls appl function) - entry - (unless (iterate ((arg (list-elements args)) - (specl (list-elements specls))) - (let ((class (class-of arg))) - (unless (if (consp specl) - (eql (cadr specl) - arg) - (or (eq specl t) - (eq specl class))) - (return t)))) - (return (values function appl (cadr e))))))))) - -(defmacro protect-cache-miss-code (gf args &body body) - (let ((wrappers (gensym)) - (invalidp (gensym)) - #'(gensym) - (appl (gensym))) - (once-only (gf args) - `(if (memq ,gf *invalid-dfuns-on-stack*) - (multiple-value-bind (,wrappers ,invalidp ,function ,appl) - (cache-miss-values ,gf ,args) - (declare (ignore ,wrappers ,invalidp)) - (if (null ,appl) - (apply #'no-applicable-method ,gf ,args) - (apply ,function ,args))) - (let ((*invalid-dfuns-on-stack* (cons ,gf *invalid-dfuns-on-stack*))) - ,@body))))) - -(defmethod same-specializer-p (specl1 specl2) - (eq specl1 specl2)) - -(defmethod specializer-applicable-p ((specializer class) - object) - (memq specializer (class-precedence-list (class-of object)))) - -(defmethod specializer-applicable-using-class-p ((specializer class) - class) - (*subtypep class specializer)) - -(defmethod order-specializers-using-class ((specl1 class) - (specl2 class) - class) - (cond ((eq specl1 specl2) - nil) - ((memq specl2 (memq specl1 (class-precedence-list class))) - specl1) - (t specl2))) - -(defmethod compute-applicable-methods ((generic-function generic-function) - arguments) - (labels ((filter (method) - (let ((arguments-tail arguments)) - (dolist (m-spec (method-specializers method) - t) - (unless arguments-tail - (error "The function ~S requires at least ~D arguments" - (generic-function-name generic-function) - (arg-info-number-required (gf-arg-info generic-function)))) - (unless (specializer-applicable-p m-spec (pop arguments-tail)) - (return nil))))) - (sorter (method-1 method-2) - (dolist (index (arg-info-precedence (gf-arg-info generic-function))) - (let* ((specl1 (nth index (method-specializers method-1))) - (specl2 (nth index (method-specializers method-2))) - (class (class-of (nth index arguments))) - (order (order-specializers-using-class specl1 specl2 class))) - (when order - (return-from sorter (eq order specl1))))))) - (let ((methods (generic-function-methods generic-function))) - (stable-sort (copy-list (remove-if-not #'filter methods)) - #'sorter)))) - -(defmethod compute-applicable-methods-using-classes ((generic-function generic-function) - classes) - (labels ((filter (method) - (let ((classes-tail classes)) - (dolist (m-spec (method-specializers method) - t) - (unless classes-tail - (error "The function ~S requires at least ~D arguments" - (generic-function-name generic-function) - (arg-info-number-required (gf-arg-info generic-function)))) - (unless (specializer-applicable-using-class-p m-spec (pop - classes-tail - )) - (return nil))))) - (sorter (method-1 method-2) - (dolist (index (arg-info-precedence (gf-arg-info generic-function))) - (let* ((specl1 (nth index (method-specializers method-1))) - (specl2 (nth index (method-specializers method-2))) - (class (nth index classes)) - (order (order-specializers-using-class specl1 specl2 class))) - (when order - (return-from sorter (eq order specl1))))))) - (let ((methods (generic-function-methods generic-function))) - (stable-sort (copy-list (remove-if-not #'filter methods)) - #'sorter)))) - -(defun get-normal-secondary-dispatch-function (generic-function args) - (let* ((classes (mapcar #'(lambda (arg mt) - (declare (ignore mt)) - (class-of arg)) - args - (arg-info-metatypes (gf-arg-info generic-function)))) - (methods (compute-applicable-methods-using-classes generic-function classes)) - (net (generate-discrimination-net generic-function methods)) - (arg-info (gf-arg-info generic-function)) - (metatypes (arg-info-metatypes arg-info)) - (applyp (arg-info-applyp arg-info))) - (flet ((net-test-converter (form) - (if (and (consp form) - (eq (car form) - 'methods)) - '.methods. - (default-test-converter form))) - (net-code-converter (form) - (if (and (consp form) - (eq (car form) - 'methods)) - (let ((gensym (gensym))) - (values (make-dfun-call metatypes applyp gensym) - (list gensym))) - (default-code-converter form))) - (net-constant-converter (form) - (if (and (consp form) - (eq (car form) - 'methods)) - (list (get-effective-method-function generic-function (cdr form))) - (default-constant-converter form)))) - (if (eq (car net) - 'methods) - (and (cdr net) - (values (get-effective-method-function generic-function (cdr net)) - methods)) - (values (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) - ,net) - #'net-test-converter - #'net-code-converter - #'net-constant-converter) - methods))))) - -(defun get-effective-method-function (generic-function methods) - (let ((combin (generic-function-method-combination generic-function)) - (precomputed (gf-effective-method-functions generic-function))) - - ;; NOTE: We are assuming a restriction on user code that the method combination must not - ;; change once it is connected to the generic function. This has to be legal, because - ;; otherwise any kind of method lookup caching couldn't work. See this by saying that - ;; this cache, is just a backing cache for the fast cache. If that cache is legal, this - ;; one must be too. Should altering the set of methods flush this cache? - (let ((entry (assoc methods precomputed :test #'equal))) - (if entry - (values (cdr entry) - (car entry)) - (let* ((effective (compute-effective-method generic-function combin methods)) - (fn (make-effective-method-function generic-function effective))) - (setf (gf-effective-method-functions generic-function) - (cons (cons methods fn) - precomputed)) - (values fn methods)))))) - -(defun - generate-discrimination-net - (generic-function methods) - (let* ((arg-info (gf-arg-info generic-function)) - (nreq (arg-info-number-required arg-info)) - (metatypes (arg-info-metatypes arg-info))) - (labels ((do-column (position contenders) - (if (< position nreq) - (if (eq (nth position metatypes) - 't) - (do-column (1+ position) - contenders) - (do-methods position contenders nil nil)) - `(methods ,@contenders))) - (do-methods - (position contenders known-outcomes winners) - - ;; is a (sorted) list of methods that must be discriminated - ;; is a list of outcomes from tests already made on this argument - ;; each outcome looks like ( [t | nil]) is a (sorted) list - ;; of methods that are potentially applicable after the discrimination has been - ;; made. - (if (null contenders) - (do-column (1+ position) - winners) - (let* ((method (car contenders)) - (specl (nth position (method-specializers method)))) - (flet ((determined-to-be (truth-value) - (if (classp specl) - truth-value - (some #'(lambda (outcome) - (outcome-implies-p generic-function - (car outcome) - (cadr outcome) - specl truth-value)) - known-outcomes))) - (if-true nil (do-methods position (cdr contenders) - (if (not (classp specl)) - (cons `(,specl t) - known-outcomes) - known-outcomes) - (append winners `(,method)))) - (if-false nil (do-methods position (cdr contenders) - (if (not (classp specl)) - (cons `(,specl nil) - known-outcomes) - known-outcomes) - winners))) - (cond ((determined-to-be nil) - (if-false)) - ((determined-to-be t) - (if-true)) - (t `(if ,(compute-argument-test-form generic-function - (dfun-arg-symbol position) - specl) - ,(if-true) - ,(if-false))))))))) - (do-column 0 methods)))) - -(define-gf-predicate eql-specializer-p eql-specializer) - -(defmethod same-specializer-p ((specl1 eql-specializer) - (specl2 eql-specializer)) - (eql (eql-specializer-object specl1) - (eql-specializer-object specl2))) - -(defmethod specializer-applicable-p ((specializer eql-specializer) - object) - (eql (eql-specializer-object specializer) - object)) - -(defmethod specializer-applicable-using-class-p ((specializer eql-specializer) - class) - (eq class (class-of (eql-specializer-object specializer)))) - - ; It would be most egregious to use - ; *subtypep here. - - -(defmethod order-specializers-using-class ((specl1 eql-specializer) - (specl2 eql-specializer) - argument-class) - (declare (ignore argument-class)) - nil) - -(defmethod order-specializers-using-class ((specl1 class) - (specl2 eql-specializer) - argument-class) - (declare (ignore argument-class)) - specl2) - -(defmethod order-specializers-using-class ((specl1 eql-specializer) - (specl2 class) - argument-class) - (declare (ignore argument-class)) - specl1) - - -;;; Does a given pair of values for { } imply a given pair of values for -;;; { }. - - -(defmethod outcome-implies-p ((generic-function generic-function) - (specl1 eql-specializer) - value1 - (specl2 eql-specializer) - value2) - (flet ((same-truth-value (x y) - (or (and x y) - (and (not x) - (not y))))) - (let ((obj1 (eql-specializer-object specl1)) - (obj2 (eql-specializer-object specl2))) - (or (and (eql obj1 obj2) - (same-truth-value value1 value2)) - (and (not (eql obj1 obj2)) - value1 - (not value2)))))) - - -;;; Return a form which tests a given argument against a given specializer. - - -(defmethod compute-argument-test-form ((generic-function generic-function) - argument-form - (specializer eql-specializer)) - `(eql ,argument-form ',(eql-specializer-object specializer))) - - -;;; The value returned by compute-discriminating-function is a function object. It is called a -;;; discriminating function because it is called when the generic function is called and its role is -;;; to discriminate on the arguments to the generic function and then call appropriate method -;;; functions. A discriminating function can only be called when it is installed as the funcallable -;;; instance function of the generic function for which it was computed. More precisely, if -;;; compute-discriminating-function is called with an argument , and returns a result , -;;; that result must not be passed to apply or funcall directly. Rather, must be stored as -;;; the funcallable instance function of the same generic function (using -;;; set-funcallable-instance-function). Then the generic function can be passed to funcall or -;;; apply. An important exception is that methods on this generic function are permitted to return a -;;; function which itself ends up calling the value returned by a more specific method. This kind -;;; of `encapsulation' of discriminating function is critical to many uses of the MOP. As an -;;; example, the following canonical case is legal: (defmethod compute-discriminating-function ((gf -;;; my-generic-function)) (let ((std (call-next-method))) #'(lambda (arg) (print (list 'call-to-gf -;;; gf arg)) (funcall std arg)))) Because many discriminating functions would like to use a dynamic -;;; strategy in which the precise discriminating function changes with time it is important to -;;; specify how a discriminating function is permitted itself to change the funcallable instance -;;; function of the generic function. Discriminating functions are may set the funcallable instance -;;; function of the generic function, but the new value must be generated by making a call to -;;; COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any more specific methods which may -;;; have encapsulated the discriminating function will get a chance to encapsulate the new, inner -;;; discriminating function. This implies that if a discriminating function wants to modify itself -;;; it should first store some information in the generic function proper, and then call -;;; compute-discriminating-function. The appropriate method on compute-discriminating-function will -;;; see the information stored in the generic function and generate a discriminating function -;;; accordingly. The following is an example of a discriminating function which modifies itself in -;;; accordance with this protocol: (defmethod compute-discriminating-function ((gf -;;; my-generic-function)) #'(lambda (arg) (cond ( (set-funcallable-instance-function gf (compute-discriminating-function gf)) (funcall -;;; gf arg)) (t )))) Whereas this code would not be legal: (defmethod -;;; compute-discriminating-function ((gf my-generic-function)) #'(lambda (arg) (cond ( (set-funcallable-instance-function gf #'(lambda (a) ..)) (funcall gf arg)) (t -;;; )))) NOTE: All the examples above assume that all instances of the class -;;; my generic function accept only one argument. - - -(defmethod compute-discriminating-function ((gf standard-generic-function)) - (let* ((state (gf-dfun-state gf)) - (dfun (typecase state - (null (make-initial-dfun gf)) - (function state) - (cons (car state))))) - (doctor-dfun-for-the-debugger gf dfun))) - -(defun update-dfun (generic-function dfun &optional cache) - (let ((ostate (gf-dfun-state generic-function))) - (unless (typep ostate '(or null function)) - (free-cache (cdr ostate))) - (setf (gf-dfun-state generic-function) - (if cache - (cons dfun cache) - dfun)) - (invalidate-dfun-internal generic-function))) - -(defvar *generate-random-code-segments* nil) - -(defun invalidate-discriminating-function (generic-function) - (let ((ostate (gf-dfun-state generic-function))) - (unless (typep ostate '(or null function)) - (free-cache (cdr ostate))) - (setf (gf-dfun-state generic-function) - nil) - (setf (gf-effective-method-functions generic-function) - nil) - (invalidate-dfun-internal generic-function) - (when *generate-random-code-segments* - (let ((*generate-random-code-segments* nil)) - (generate-random-code-segments generic-function))))) - -(defun invalidate-dfun-internal (generic-function) - - ;; Set the funcallable instance function to something that just calls invalid-dfun, that is, - ;; arrange to use lazy evaluation to update the dfun later. - (set-funcallable-instance-function generic-function #'(lambda (&rest args) - (invalid-dfun generic-function - args))) - - ;; Except that during bootstrapping, we would like to update the dfun right away, and this - ;; arranges for that. - (when *invalidate-discriminating-function-force-p* - (let ((*invalid-dfuns-on-stack* (cons generic-function *invalid-dfuns-on-stack*))) - (set-funcallable-instance-function generic-function (compute-discriminating-function - generic-function))))) - -(defun invalid-dfun (gf args) - (protect-cache-miss-code gf args (let ((new-dfun (compute-discriminating-function gf))) - (set-funcallable-instance-function gf new-dfun) - (apply gf args)))) - - -;;; - - -(defmethod function-keywords ((method standard-method)) - (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list (method-lambda-list method)) - (declare (ignore nreq nopt keysp restp)) - (values keywords allow-other-keys-p))) - -(defun analyze-lambda-list (lambda-list) - (declare (values nrequired noptional keysp restp allow-other-keys-p keywords - keyword-parameters)) - (flet ((parse-keyword-argument (arg) - (if (listp arg) - (if (listp (car arg)) - (cadar arg) - (make-keyword (car arg))) - (make-keyword arg)))) - (let ((nrequired 0) - (noptional 0) - (keysp nil) - (restp nil) - (allow-other-keys-p nil) - (keywords nil) - (keyword-parameters nil) - (state 'required)) - (dolist (x lambda-list) - (if (memq x lambda-list-keywords) - (case x - (&optional (setq state 'optional)) - (&key (setq keysp 't state 'key)) - (&allow-other-keys (setq allow-other-keys-p 't)) - (&rest (setq restp 't state 'rest)) - (&aux (return t)) - (otherwise (error - "Encountered the non-standard lambda list keyword ~S." - x))) - (ecase state - (required (incf nrequired)) - (optional (incf noptional)) - (key - (push (parse-keyword-argument x) - keywords) - (push x keyword-parameters)) - (rest nil)))) - (values nrequired noptional keysp restp allow-other-keys-p (reverse keywords) - (reverse keyword-parameters))))) - -(defun method-ll->generic-function-ll (ll) - (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters) - (analyze-lambda-list ll) - (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords)) - (remove-if #'(lambda (s) - (or (memq s keyword-parameters) - (eq s '&allow-other-keys))) - ll))) - - -;;; This is based on the rules of method lambda list congruency defined in the spec. The lambda -;;; list it constructs is the pretty union of the lambda lists of all the methods. It doesn't take -;;; method applicability into account at all yet. - - -(defmethod generic-function-pretty-arglist ((generic-function standard-generic-function)) - (let ((methods (generic-function-methods generic-function)) - (arglist nil)) - (when methods - (multiple-value-bind (required optional rest key allow-other-keys) - (method-pretty-arglist (car methods)) - (dolist (m (cdr methods)) - (multiple-value-bind (method-key-keywords method-allow-other-keys method-key) - (function-keywords m) - - ;; we've modified function-keywords to return what we want as the third - ;; value, no other change here. - (declare (ignore method-key-keywords)) - (setq key (union key method-key)) - (setq allow-other-keys (or allow-other-keys method-allow-other-keys)))) - (when allow-other-keys - (setq arglist '(&allow-other-keys))) - (when key - (setq arglist (nconc (list '&key) - key arglist))) - (when rest - (setq arglist (nconc (list '&rest rest) - arglist))) - (when optional - (setq arglist (nconc (list '&optional) - optional arglist))) - (nconc required arglist))))) - -(defmethod method-pretty-arglist ((method standard-method)) - (let ((required nil) - (optional nil) - (rest nil) - (key nil) - (allow-other-keys nil) - (state 'required) - (arglist (method-lambda-list method))) - (dolist (arg arglist) - (cond ((eq arg '&optional) - (setq state 'optional)) - ((eq arg '&rest) - (setq state 'rest)) - ((eq arg '&key) - (setq state 'key)) - ((eq arg '&allow-other-keys) - (setq allow-other-keys 't)) - ((memq arg lambda-list-keywords)) - (t (ecase state - (required (push arg required)) - (optional (push arg optional)) - (key (push arg key)) - (rest (setq rest arg)))))) - (values (nreverse required) - (nreverse optional) - rest - (nreverse key) - allow-other-keys))) diff --git a/obsolete/clos/2.0/patch.lisp b/obsolete/clos/2.0/patch.lisp deleted file mode 100644 index eab79094..00000000 --- a/obsolete/clos/2.0/patch.lisp +++ /dev/null @@ -1,143 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CLIN-PACKAGE "XCL-USER") BASE 10) -(IL:FILECREATED "19-Feb-91 14:09:19"  -IL:|{DSK}local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;2| 9876 - - IL:|changes| IL:|to:| (IL:VARS IL:XEROX-PATCHESCOMS) - - IL:|previous| IL:|date:| " 6-Feb-91 10:55:16" -IL:|{DSK}local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;1|) - - -; Copyright (c) 1991 by Venue. All rights reserved. - -(IL:PRETTYCOMPRINT IL:XEROX-PATCHESCOMS) - -(IL:RPAQQ IL:XEROX-PATCHESCOMS ( - - - (IL:FUNCTIONS OPTIMIZE-LOGICAL-OP-1-ARG) - (OPTIMIZERS (LOGIOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG) - (LOGXOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG) - (LOGAND :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG) - (LOGEQV :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)) - - (IL:* IL:|;;| "A bug compiling LABELS") - - (IL:FUNCTIONS COMPILER::META-CALL-LABELS) - (FILE-ENVIRONMENTS "XEROX-PATCHES"))) - - - - - - -(IL:* IL:|;;;| -"Declare side-effects (actually, lack of side-effects) info for some internal arithmetic functions. These are needed because the compiler runs the optimizers before checking the side-effects, so side-effect declarations on the \"real\" functions are oft times ignored. Fix a nit in the compiler While no person would generate code like (logor x), macro can (and do). " -) - - -(DEFUN OPTIMIZE-LOGICAL-OP-1-ARG (FORM ENV CTXT) - (DECLARE (IGNORE ENV CTXT)) - (IF (= 2 (LENGTH FORM)) - (SECOND FORM) - 'COMPILER:PASS)) - -(DEFOPTIMIZER LOGIOR OPTIMIZE-LOGICAL-OP-1-ARG) - -(DEFOPTIMIZER LOGXOR OPTIMIZE-LOGICAL-OP-1-ARG) - -(DEFOPTIMIZER LOGAND OPTIMIZE-LOGICAL-OP-1-ARG) - -(DEFOPTIMIZER LOGEQV OPTIMIZE-LOGICAL-OP-1-ARG) - - - -(IL:* IL:|;;| "A bug compiling LABELS") - - -(DEFUN COMPILER::META-CALL-LABELS (COMPILER::NODE COMPILER:CONTEXT) - - (IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them. ") - - (LET ((COMPILER::*MADE-CHANGES* NIL)) - - (IL:* IL:|;;| "First, substitute the functions wherever possible.") - - (DOLIST (COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE) - (WHEN (NULL (COMPILER::NODE-META-P (COMPILER::LABELS-BODY COMPILER::NODE))) - (SETF (COMPILER::NODE-META-P COMPILER::NODE) - NIL) - (SETQ COMPILER::*MADE-CHANGES* T))) - (WHEN (COMPILER::SUBSTITUTABLE-P (CDR COMPILER::FN-PAIR) - (CAR COMPILER::FN-PAIR)) - (LET ((COMPILER::*SUBST-OCCURRED* NIL)) - - (IL:* IL:|;;| "First try substituting into the body.") - - (SETF (COMPILER::LABELS-BODY COMPILER::NODE) - (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR) - (CAR COMPILER::FN-PAIR) - (COMPILER::LABELS-BODY COMPILER::NODE))) - (WHEN (NOT COMPILER::*SUBST-OCCURRED*) - - (IL:* IL:|;;| "Wasn't in the body - try the other functions.") - - (DOLIST (COMPILER::TARGET-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)) - (UNLESS (EQ COMPILER::TARGET-PAIR COMPILER::FN-PAIR) - (SETF (CDR COMPILER::TARGET-PAIR) - (COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR) - (CAR COMPILER::FN-PAIR) - (CDR COMPILER::TARGET-PAIR))) - (WHEN COMPILER::*SUBST-OCCURRED* - (IL:* IL:\; - "Found it, we can stop now.") - (SETF (COMPILER::NODE-META-P COMPILER::NODE) - NIL) - (SETQ COMPILER::*MADE-CHANGES* T) - (RETURN))))) - - (IL:* IL:|;;| "May need to reanalyze the node, since things might have changed. Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost. ") - - (DOLIST (COMPILER::FNS (COMPILER::LABELS-FUNS COMPILER::NODE)) - (COMPILER::MEVAL (CDR COMPILER::FNS) - :ARGUMENT)) - (COMPILER::MEVAL (COMPILER::LABELS-BODY COMPILER::NODE) - :RETURN)))) - - (IL:* IL:|;;| "Now remove any functions that aren't referenced.") - - (DOLIST (COMPILER::FN-PAIR (PROG1 (COMPILER::LABELS-FUNS COMPILER::NODE) - (SETF (COMPILER::LABELS-FUNS COMPILER::NODE) - NIL))) - (COND - ((NULL (COMPILER::VARIABLE-READ-REFS (CAR COMPILER::FN-PAIR))) - (COMPILER::RELEASE-TREE (CDR COMPILER::FN-PAIR)) - (SETQ COMPILER::*MADE-CHANGES* T)) - (T (PUSH COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE))))) - - (IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.") - - (WHEN (NULL (COMPILER::LABELS-FUNS COMPILER::NODE)) - (LET ((COMPILER::BODY (COMPILER::LABELS-BODY COMPILER::NODE))) - (SETF (COMPILER::LABELS-BODY COMPILER::NODE) - NIL) - (COMPILER::RELEASE-TREE COMPILER::NODE) - (SETQ COMPILER::NODE COMPILER::BODY COMPILER::*MADE-CHANGES* T))) - - (IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.") - - (IF (NULL COMPILER::*MADE-CHANGES*) - (SETF (COMPILER::NODE-META-P COMPILER::NODE) - COMPILER:CONTEXT) - (SETF (COMPILER::NODE-META-P COMPILER::NODE) - NIL))) - COMPILER::NODE) - -(DEFINE-FILE-ENVIRONMENT "XEROX-PATCHES" :PACKAGE (IN-PACKAGE "XCL-USER") - :READTABLE "XCL" - :BASE 10 - :COMPILER :COMPILE-FILE) -(IL:PUTPROPS IL:XEROX-PATCHES IL:COPYRIGHT ("Venue" 1991)) -(IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL))) -IL:STOP diff --git a/obsolete/clos/2.0/pkg.lisp b/obsolete/clos/2.0/pkg.lisp deleted file mode 100644 index 7491df0d..00000000 --- a/obsolete/clos/2.0/pkg.lisp +++ /dev/null @@ -1,81 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;; File converted on 26-Mar-91 10:23:29 from source pkg -;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>pkg.;4 created 1-Mar-91 10:10:26 - -;;;. Copyright (c) 1991 by Venue - - -(in-package "CLOS") - - - -;;; Some CommonLisps have more symbols in the Lisp package than the ones that are explicitly -;;; specified in CLtL. This causes trouble. Any Lisp that has extra symbols in the Lisp package -;;; should shadow those symbols in the CLOS package. - - -(shadow 'cl:documentation) - - -;;; These come from the index pages of 88-002R. - -(eval-when (compile load eval) -(defvar *exports* - '(add-method built-in-class call-method call-next-method change-class class-name class-of - compute-applicable-methods defclass defgeneric define-method-combination defmethod - ensure-generic-function find-class find-method function-keywords generic-flet - generic-labels initialize-instance invalid-method-error make-instance - make-instances-obsolete method-combination-error method-qualifiers next-method-p - no-applicable-method no-next-method print-object reinitialize-instance remove-method - shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound - slot-value standard standard-class standard-generic-function standard-method - standard-object structure-class symbol-macrolet update-instance-for-different-class - update-instance-for-redefined-class with-accessors with-added-methods with-slots)) - -(import '(xcl:false xcl:destructuring-bind xcl:true) *the-clos-package*) - -(export *exports* *the-clos-package*) - -(import *exports* (find-package :lisp)) - -(export *exports* (find-package :lisp))) - - ; (defvar *chapter-3-exports* '( - ; get-setf-function - ; get-setf-function-name - ; class-prototype class object - - - -;; essential-class - - - ; class-name class-precedence-list - ; class-local-supers class-local-slots - ; class-direct-subclasses - ; class-direct-methods class-slots - ; method-arglist - ; method-argument-specifiers - ; method-function method-equal - ; slotd-name slot-missing - - - -;; define-meta-class %allocate-instance %instance-ref %instancep %instance-meta-class - - - ; allocate-instance optimize-slot-value - ; optimize-setf-of-slot-value - ; add-named-class - ; class-for-redefinition add-class - ; supers-changed slots-changed - ; check-super-metaclass-compatibility - ; make-slotd - ; compute-class-precedence-list - ; walk-method-body - ; walk-method-body-form - ; add-named-method remove-named-method - ; )) - diff --git a/obsolete/clos/2.0/plap.lisp b/obsolete/clos/2.0/plap.lisp deleted file mode 100644 index 49d8b833..00000000 --- a/obsolete/clos/2.0/plap.lisp +++ /dev/null @@ -1,309 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;;. Copyright (c) 1991 by Venue - -(in-package "CLOS") - - -;;; The portable implementation of the LAP assembler. The portable implementation of the LAP -;;; assembler works by translating LAP code back into Lisp code and then compiling that Lisp code. -;;; Note that this implementation is actually going to get a lot of use. Some implementations (KCL) -;;; won't implement a native LAP assembler at all. Other implementations may not implement native -;;; LAP assemblers for all of their ports. All of this implies that this portable LAP assembler -;;; needs to generate the best code it possibly can. - - -(defmacro - lap-case - (operand &body cases) - (once-only - (operand) - `(ecase (car ,operand) - ,@(mapcar #'(lambda (case) - `(,(car case) - (apply #'(lambda ,(cadr case) - ,@(cddr case)) - (cdr ,operand)))) - cases)))) - -(defvar *lap-args*) - -(defvar *lap-rest-p*) - -(defvar *lap-i-regs*) - -(defvar *lap-v-regs*) - -(defvar *lap-t-regs*) - -(defvar *lap-optimize-declaration* '((speed 3) - (safety 0) - (compilation-speed 0))) - -(eval-when (load eval) - (setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs - vector-regs t-regs lap-code) - (compile-lambda (make-lap-closure-generator-lambda - closure-var-names arg-names - index-regs vector-regs t-regs - lap-code))) - *precompile-lap-closure-generator* - #'(lambda (cvars args i-regs v-regs t-regs lap) - `#',(make-lap-closure-generator-lambda cvars args i-regs v-regs t-regs lap)) - *lap-in-lisp* - #'(lambda (cvars args iregs vregs tregs lap) - (declare (ignore cvars args)) - (make-lap-prog iregs vregs tregs (flatten-lap lap - ; (opcode :label 'exit-lap-in-lisp) - ))))) - -(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs t-regs lap) - (let* ((rest (memq '&rest args)) - (ldiff (and rest (ldiff args rest)))) - (when rest - (setq args (append ldiff '(&rest .lap-rest-arg.)))) - (let* ((*lap-args* (if rest - ldiff - args)) - (*lap-rest-p* (not (null rest)))) - `(lambda ,cvars #'(lambda ,args (declare (optimize . ,*lap-optimize-declaration*)) - ,(make-lap-prog-internal i-regs v-regs t-regs lap)))))) - -(defun make-lap-prog (i-regs v-regs t-regs lap) - (let* ((*lap-args* 'lap-in-lisp) - (*lap-rest-p* 'lap-in-lisp)) - (make-lap-prog-internal i-regs v-regs t-regs lap))) - -(defun make-lap-prog-internal (i-regs v-regs t-regs lap) - (let* ((*lap-i-regs* i-regs) - (*lap-v-regs* v-regs) - (*lap-t-regs* t-regs) - (code (mapcar #'lap-opcode lap))) - `(prog ,(mapcar #'(lambda (reg) - `(,(lap-reg reg) - ,(lap-reg-initial-value-form reg))) - (append i-regs v-regs t-regs)) - (declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*)) - (type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*)) - (optimize . ,*lap-optimize-declaration*)) - ,.code))) - -(defconstant *empty-vector* '#()) - -(defun lap-reg-initial-value-form (reg) - (cond ((member reg *lap-i-regs*) - 0) - ((member reg *lap-v-regs*) - '*empty-vector*) - ((member reg *lap-t-regs*) - nil) - (t (error "What kind of register is ~S?" reg)))) - -(defun lap-opcode (opcode) - (lap-case opcode (:move (from to) - `(setf ,(lap-operand to) - ,(lap-operand from))) - ((:eq :neq :fix=) - (arg1 arg2 label) - `(when ,(lap-operands (ecase (car opcode) - (:eq 'eq) - (:neq 'neq) - (:fix= 'runtime\ fix=)) - arg1 arg2) - (go ,label))) - ((:izerop) - (arg label) - `(when ,(lap-operands 'runtime\ izerop arg) - (go ,label))) - (:std-instance-p (from label) - `(when ,(lap-operands 'runtime\ std-instance-p from) - (go ,label))) - (:fsc-instance-p (from label) - `(when ,(lap-operands 'runtime\ fsc-instance-p from) - (go ,label))) - (:built-in-instance-p (from label) - (declare (ignore from)) - `(when ,t - (go ,label))) - ; *** - (:structure-instance-p (from label) - `(when ,(lap-operands 'runtime\ ??? from) - (go ,label))) - ; *** - (:jmp (fn) - (if (eq *lap-args* 'lap-in-lisp) - (error "Can't do a :JMP in LAP-IN-LISP.") - `(return ,(if *lap-rest-p* - `(runtime\ apply ,(lap-operand fn) - ,@*lap-args* .lap-rest-arg.) - `(runtime\ funcall ,(lap-operand fn) - ,@*lap-args*))))) - (:return (value) - `(return ,(lap-operand value))) - (:label (label) - label) - (:go (label) - `(go ,label)) - (:exit-lap-in-lisp nil `(go exit-lap-in-lisp)) - (:break nil `(break)) - (:beep nil) - (:print (val) - (lap-operands 'print val)))) - -(defun lap-operand (operand) - (lap-case operand (:reg (n) - (lap-reg n)) - (:cdr (reg) - (lap-operands 'cdr reg)) - ((:cvar :arg) - (name) - name) - (:constant (c) - `',c) - ((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :std-slots :fsc-slots) - (x) - (lap-operands (ecase (car operand) - (:std-wrapper 'runtime\ std-wrapper) - (:fsc-wrapper 'runtime\ fsc-wrapper) - (:built-in-wrapper 'runtime\ built-in-wrapper) - (:structure-wrapper 'runtime\ structure-wrapper) - (:std-slots 'runtime\ std-slots) - (:fsc-slots 'runtime\ fsc-slots)) - x)) - (:i1+ (index) - (lap-operands 'runtime\ i1+ index)) - (:i+ (index1 index2) - (lap-operands 'runtime\ i+ index1 index2)) - (:i- (index1 index2) - (lap-operands 'runtime\ i- index1 index2)) - (:ilogand (index1 index2) - (lap-operands 'runtime\ ilogand index1 index2)) - (:ilogxor (index1 index2) - (lap-operands 'runtime\ ilogxor index1 index2)) - (:iref (vector index) - (lap-operands 'runtime\ iref vector index)) - (:iset (vector index value) - (lap-operands 'runtime\ iset vector index value)) - (:cref (vector i) - `(runtime\ svref ,(lap-operand vector) - ,i)) - (:lisp-variable (symbol) - symbol) - (:lisp (form) - form))) - -(defun lap-operands (fn &rest regs) - (cons fn (mapcar #'lap-operand regs))) - -(defun lap-reg (n) - (intern (format nil "REG~D" n) - *the-clos-package*)) - - -;;; Runtime Implementations of the operands and opcodes. In those ports of CLOS which choose not to -;;; completely re-implement the LAP code generator, it may still be provident to consider -;;; reimplementing one or more of these to get the compiler to produce better code. That is why -;;; they are split out. - - -(proclaim '(declaration clos-fast-call)) - -(defmacro runtime\ funcall (fn &rest args) - `(funcall ,fn ,.args)) - -(defmacro runtime\ apply (fn &rest args) - `(apply ,fn ,.args)) - -(defmacro runtime\ std-wrapper (x) - `(std-instance-wrapper ,x)) - -(defmacro runtime\ fsc-wrapper (x) - `(fsc-instance-wrapper ,x)) - -(defmacro runtime\ built-in-wrapper (x) - `(built-in-wrapper-of ,x)) - -(defmacro runtime\ structure-wrapper (x) - `(??? ,x)) - -(defmacro runtime\ std-slots (x) - `(std-instance-slots (the std-instance ,x))) - -(defmacro runtime\ fsc-slots (x) - `(fsc-instance-slots ,x)) - -(defmacro runtime\ std-instance-p (x) - `(std-instance-p ,x)) - -(defmacro runtime\ fsc-instance-p (x) - `(fsc-instance-p ,x)) - -(defmacro runtime\ izerop (x) - `(zerop (the fixnum ,x))) - -(defmacro runtime\ fix= (x y) - `(= (the fixnum ,x) - (the fixnum ,y))) - - -;;; These are the implementations of the index operands. The portable assembler generates Lisp code -;;; that uses these macros. Even though the variables holding the arguments and results have type -;;; declarations on them, we put type declarations in here. Some compilers are so stupid... - - -(defmacro runtime\ iref (vector index) - `(svref (the simple-vector ,vector) - (the fixnum ,index))) - -(defmacro runtime\ iset (vector index value) - `(setf (svref (the simple-vector ,vector) - (the fixnum ,index)) - ,value)) - -(defmacro runtime\ svref (vector fixnum) - `(svref (the simple-vector ,vector) - (the fixnum ,fixnum))) - -(defmacro runtime\ i+ (index1 index2) - `(the fixnum (+ (the fixnum ,index1) - (the fixnum ,index2)))) - -(defmacro runtime\ i- (index1 index2) - `(the fixnum (- (the fixnum ,index1) - (the fixnum ,index2)))) - -(defmacro runtime\ i1+ (index) - `(the fixnum (1+ (the fixnum ,index)))) - -(defmacro runtime\ ilogand (index1 index2) - `(the fixnum (logand (the fixnum ,index1) - (the fixnum ,index2)))) - -(defmacro runtime\ ilogxor (index1 index2) - `(the fixnum (logxor (the fixnum ,index1) - (the fixnum ,index2)))) - - -;;; In the portable implementation, indexes are just fixnums. - - -(defconstant index-value-limit most-positive-fixnum) - -(defun index-value->index (index-value) - index-value) - -(defun index->index-value (index) - index) - -(defun make-index-mask (cache-size line-size) - (let ((cache-size-in-bits (floor (log cache-size 2))) - (line-size-in-bits (floor (log line-size 2))) - (mask 0)) - (dotimes (i cache-size-in-bits) - (setq mask (dpb 1 (byte 1 i) - mask))) - (dotimes (i line-size-in-bits) - (setq mask (dpb 0 (byte 1 i) - mask))) - mask)) diff --git a/obsolete/clos/2.0/precom-browser.cl b/obsolete/clos/2.0/precom-browser.cl deleted file mode 100644 index cb7bad35..00000000 --- a/obsolete/clos/2.0/precom-browser.cl +++ /dev/null @@ -1,3 +0,0 @@ -;; - -(CLOS::PRECOMPILE-RANDOM-CODE-SEGMENTS BROWSER) diff --git a/obsolete/clos/2.0/precom1.lisp b/obsolete/clos/2.0/precom1.lisp deleted file mode 100644 index 76d6e88b..00000000 --- a/obsolete/clos/2.0/precom1.lisp +++ /dev/null @@ -1,31 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; - -(in-package 'clos) - -;;; -;;; pre-allocate generic function caches. The hope is that this will put -;;; them nicely together in memory, and that that may be a win. Of course -;;; the first gc copy will probably blow that out, this really wants to be -;;; wrapped in something that declares the area static. -;;; -;;; This preallocation only creates about 25% more caches than CLOS itself -;;; uses need. Some ports may want to preallocate some more of these. -;;; -(eval-when (load) - (flet ((allocate (n size) - (mapcar #'free-cache - (mapcar #'get-cache - (make-list n :initial-element size))))) - (allocate 128 4) - (allocate 64 8) - (allocate 64 9) - (allocate 32 16) - (allocate 16 17) - (allocate 16 32) - (allocate 1 64))) \ No newline at end of file diff --git a/obsolete/clos/2.0/precom2.lisp b/obsolete/clos/2.0/precom2.lisp deleted file mode 100644 index 0c763a45..00000000 --- a/obsolete/clos/2.0/precom2.lisp +++ /dev/null @@ -1,12 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; - -(in-package 'clos) - -(precompile-dfun-constructors clos) ;this is half of a call to - ;precompile-random-code-segments diff --git a/obsolete/clos/2.0/precom4.lisp b/obsolete/clos/2.0/precom4.lisp deleted file mode 100644 index 06a17cf5..00000000 --- a/obsolete/clos/2.0/precom4.lisp +++ /dev/null @@ -1,12 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; - -(in-package 'clos) - -(precompile-function-generators clos) ;this is half of a call to - ;precompile-random-code-segments diff --git a/obsolete/clos/2.0/slots.lisp b/obsolete/clos/2.0/slots.lisp deleted file mode 100644 index c21c00d6..00000000 --- a/obsolete/clos/2.0/slots.lisp +++ /dev/null @@ -1,261 +0,0 @@ -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;;. Copyright (c) 1991 by Venue - -(in-package "CLOS") - -;;; These four functions work on std-instances and fsc-instances. These are instances for which it -;;; is possible to change the wrapper and the slots. For these kinds of instances, most specified -;;; methods from the instance structure protocol are promoted to the implementation-specific class -;;; std-class. Many of these methods call these four functions. - - -(defun get-wrapper (inst) - (cond ((std-instance-p inst) - (std-instance-wrapper inst)) - ((fsc-instance-p inst) - (fsc-instance-wrapper inst)) - (t (error "What kind of instance is this?")))) - -(defun get-slots (inst) - (cond ((std-instance-p inst) - (std-instance-slots inst)) - ((fsc-instance-p inst) - (fsc-instance-slots inst)) - (t (error "What kind of instance is this?")))) - -(defun set-wrapper (inst new) - (cond ((std-instance-p inst) - (setf (std-instance-wrapper inst) - new)) - ((fsc-instance-p inst) - (setf (fsc-instance-wrapper inst) - new)) - (t (error "What kind of instance is this?")))) - -(defun set-slots (inst new) - (cond ((std-instance-p inst) - (setf (std-instance-slots inst) - new)) - ((fsc-instance-p inst) - (setf (fsc-instance-slots inst) - new)) - (t (error "What kind of instance is this?")))) - -(defmacro get-slot-value-2 (instance wrapper slot-name slots index) - `(let ((val (%svref ,slots ,index))) - (if (eq val ',*slot-unbound*) - (slot-unbound (wrapper-class ,wrapper) - ,instance - ,slot-name) - val))) - -(defmacro set-slot-value-2 (nv instance wrapper slot-name slots index) - (declare (ignore instance wrapper slot-name)) - `(setf (%svref ,slots ,index) - ,nv)) - -(defun get-class-slot-value-1 (object wrapper slot-name) - (let ((entry (assq slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing (wrapper-class wrapper) - object slot-name 'slot-value) - (if (eq (cdr entry) - *slot-unbound*) - (slot-unbound (wrapper-class wrapper) - object slot-name) - (cdr entry))))) - -(defun set-class-slot-value-1 (new-value object wrapper slot-name) - (let ((entry (assq slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing (wrapper-class wrapper) - object slot-name 'setf new-value) - (setf (cdr entry) - new-value)))) - -(defmethod class-slot-value ((class std-class) - slot-name) - (let ((wrapper (class-wrapper class)) - (prototype (class-prototype class))) - (get-class-slot-value-1 prototype wrapper slot-name))) - -(defmethod (setf class-slot-value) - (nv (class std-class) - slot-name) - (let ((wrapper (class-wrapper class)) - (prototype (class-prototype class))) - (set-class-slot-value-1 nv prototype wrapper slot-name))) - -(defmethod find-slot-definition ((class std-class) - slot-name) - (if (and (eq class *the-class-standard-class*) - (eq slot-name 'slots)) - *the-eslotd-standard-class-slots* - (progn (unless (class-finalized-p class) - (finalize-inheritance class)) - (dolist (eslotd (class-slots class)) - (when (eq (slotd-name eslotd) - slot-name) - (return eslotd)))))) - -(defun slot-value (object slot-name) - (let ((class (class-of object))) - (if (eq class *the-class-standard-effective-slot-definition*) - (let* ((wrapper (check-wrapper-validity object)) - (slots (get-slots object)) - (index (instance-slot-index wrapper slot-name))) - (if index - (get-slot-value-2 object wrapper slot-name slots index) - (get-class-slot-value-1 object wrapper slot-name))) - (let ((slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-value) - (slot-value-using-class class object slot-definition)))))) - -(defun set-slot-value (object slot-name new-value) - (let ((class (class-of object))) - (if (eq class *the-class-standard-effective-slot-definition*) - (let* ((wrapper (check-wrapper-validity object)) - (slots (get-slots object)) - (index (instance-slot-index wrapper slot-name))) - (if index - (set-slot-value-2 new-value object wrapper slot-name slots index) - (set-class-slot-value-1 new-value object wrapper slot-name))) - (let ((slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'setf) - (setf (slot-value-using-class class object slot-definition) - new-value)))))) - -(defun slot-boundp (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-boundp) - (slot-boundp-using-class class object slot-definition)))) - -(defun slot-makunbound (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-makunbound) - (slot-makunbound-using-class class object slot-definition)))) - -(defun slot-exists-p (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (and slot-definition (slot-exists-p-using-class class object slot-definition)))) - - -;;; This isn't documented, but is used within CLOS in a number of print object methods (see -;;; named-object-print-function). - - -(defun slot-value-or-default (object slot-name &optional (default "unbound")) - (if (slot-boundp object slot-name) - (slot-value object slot-name) - default)) - - -;;; - - -(defmethod slot-value-using-class ((class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) - (let* ((wrapper (check-wrapper-validity object)) - ; trap if need be - (slots (get-slots object)) - (slot-name (slotd-name slotd)) - (index (or (slotd-instance-index slotd) - (setf (slotd-instance-index slotd) - (instance-slot-index wrapper slot-name))))) - (if index - (get-slot-value-2 object wrapper slot-name slots index) - (get-class-slot-value-1 object wrapper slot-name)))) - -(defmethod (setf slot-value-using-class) - (new-value (class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) - (let* ((wrapper (check-wrapper-validity object)) - ; trap if need be - (slots (get-slots object)) - (slot-name (slotd-name slotd)) - (index (or (slotd-instance-index slotd) - (setf (slotd-instance-index slotd) - (instance-slot-index wrapper slot-name))))) - (if index - (set-slot-value-2 new-value object wrapper slot-name slots index) - (set-class-slot-value-1 new-value object wrapper slot-name)))) - -(defmethod slot-boundp-using-class ((class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) - (let* ((wrapper (check-wrapper-validity object)) - ; trap if need be - (slots (get-slots object)) - (slot-name (slotd-name slotd)) - (index (or (slotd-instance-index slotd) - (setf (slotd-instance-index slotd) - (instance-slot-index wrapper slot-name))))) - (if index - (neq (svref slots index) - *slot-unbound*) - (let ((entry (assq slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing class object slot-name 'slot-boundp) - (neq (cdr entry) - *slot-unbound*)))))) - -(defmethod slot-makunbound-using-class ((class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) - (let* ((wrapper (check-wrapper-validity object)) - ; trap if need be - (slots (get-slots object)) - (slot-name (slotd-name slotd)) - (index (or (slotd-instance-index slotd) - (setf (slotd-instance-index slotd) - (instance-slot-index wrapper slot-name))))) - (cond (index (setf (%svref slots index) - *slot-unbound*) - object) - (t (let ((entry (assq slot-name (wrapper-class-slots wrapper)))) - (if* (null entry) - (slot-missing class object slot-name 'slot-makunbound) - (setf (cdr entry) - *slot-unbound*) - object)))))) - -(defmethod slot-exists-p-using-class ((class std-class) - (object standard-object) - (slotd standard-effective-slot-definition)) - t) - -(defmethod slot-missing ((class t) - instance slot-name operation &optional new-value) - (error "When attempting to ~A,~%the slot ~S is missing from the object ~S." - (ecase operation - (slot-value "read the slot's value (slot-value)") - (setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value)) - (slot-boundp "test to see if slot is bound (slot-boundp)") - (slot-makunbound "make the slot unbound (slot-makunbound)")) - slot-name instance)) - -(defmethod slot-unbound ((class t) - instance slot-name) - (error "The slot ~S is unbound in the object ~S." slot-name instance)) - -(defmethod allocate-instance ((class standard-class) - &rest initargs) - (declare (ignore initargs)) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (let* ((class-wrapper (class-wrapper class)) - (instance (%allocate-instance--class (class-no-of-instance-slots class)))) - (setf (std-instance-wrapper instance) - class-wrapper) - instance)) diff --git a/obsolete/clos/2.0/std-class.lisp b/obsolete/clos/2.0/std-class.lisp deleted file mode 100644 index a07b366c..00000000 --- a/obsolete/clos/2.0/std-class.lisp +++ /dev/null @@ -1,997 +0,0 @@ - -;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*- - - -;;; File converted on 10-Apr-91 22:24:19 from source std-class -;;;. Original source {dsk}local>users>welch>lisp>clos>rev4>il-format>std-class.;4 created 20-Feb-91 13:07:14 - -;;;. Copyright (c) 1991 by Venue - - -(in-package "CLOS") - - - -(define-gf-predicate classp class) - -(define-gf-predicate standard-class-p standard-class) - -(define-gf-predicate forward-referenced-class-p forward-referenced-class) - -(defmethod shared-initialize :after ((object documentation-mixin) - slot-names &key documentation) - (declare (ignore slot-names)) - (setf (plist-value object 'documentation) - documentation)) - -(defmethod documentation (object &optional doc-type) - (cl:documentation object doc-type)) - -(defmethod (setf documentation) - (new-value object &optional doc-type) - (declare (ignore new-value doc-type)) - (error "Can't change the documentation of ~S." object)) - -(defmethod documentation ((object documentation-mixin) - &optional doc-type) - (declare (ignore doc-type)) - (car (plist-value object 'documentation))) - -(defmethod (setf documentation) - (new-value (object documentation-mixin) - &optional doc-type) - (declare (ignore doc-type)) - (setf (plist-value object 'documentation) - new-value)) - -(defmethod documentation ((slotd standard-slot-definition) - &optional doc-type) - (declare (ignore doc-type)) - (slot-value slotd 'documentation)) - -(defmethod (setf documentation) - (new-value (slotd standard-slot-definition) - &optional doc-type) - (declare (ignore doc-type)) - (setf (slot-value slotd 'documentation) - new-value)) - -(defmethod documentation ((method standard-method) &optional doc-type) - (declare (ignore doc-type)) - (plist-value method 'documentation)) - -(defmethod (setf documentation) - (new-value (method standard-method) - &optional doc-type) - (declare (ignore doc-type)) - (setf (plist-value method 'documentation) new-value)) - -;;; Various class accessors that are a little more complicated than can be done with automatically -;;; generated reader methods. - - -(defmethod class-wrapper ((class clos-class)) - (with-slots (wrapper) - class - (let ((w? wrapper)) - (if (consp w?) - (let ((new (make-wrapper class))) - (setf (wrapper-instance-slots-layout new) - (car w?) - (wrapper-class-slots new) - (cdr w?)) - (setq wrapper new)) - w?)))) - -(defmethod class-precedence-list ((class clos-class)) - (unless (class-finalized-p class) - (finalize-inheritance class)) - (with-slots (class-precedence-list) - class - class-precedence-list)) - -(defmethod class-finalized-p ((class clos-class)) - (with-slots (wrapper) - class - (not (null wrapper)))) - -(defmethod class-prototype ((class std-class)) - (with-slots (prototype) - class - (or prototype (setq prototype (allocate-instance class))))) - -(defmethod class-direct-default-initargs ((class std-class)) - (plist-value class 'direct-default-initargs)) - -(defmethod class-default-initargs ((class std-class)) - (plist-value class 'default-initargs)) - -(defmethod class-constructors ((class std-class)) - (plist-value class 'constructors)) - -(defmethod class-slot-cells ((class std-class)) - (plist-value class 'class-slot-cells)) - - -;;; Class accessors that are even a little bit more complicated than those above. These have a -;;; protocol for updating them, we must implement that protocol. Maintaining the direct subclasses -;;; backpointers. The update methods are here, the values are read by an automatically generated -;;; reader method. - - -(defmethod add-direct-subclass ((class class) - (subclass class)) - (with-slots (direct-subclasses) - class - (pushnew subclass direct-subclasses) - subclass)) - -(defmethod remove-direct-subclass ((class class) - (subclass class)) - (with-slots (direct-subclasses) - class - (setq direct-subclasses (remove subclass direct-subclasses)) - subclass)) - - -;;; Maintaining the direct-methods and direct-generic-functions backpointers. There are four generic -;;; functions involved, each has one method for the class case and another method for the damned EQL -;;; specializers. All of these are specified methods and appear in their specified place in the -;;; class graph. ADD-METHOD-ON-SPECIALIZER REMOVE-METHOD-ON-SPECIALIZER SPECIALIZER-METHODS -;;; SPECIALIZER-GENERIC-FUNCTIONS In each case, we maintain one value which is a cons. The car is -;;; the list methods. The cdr is a list of the generic functions. The cdr is always computed -;;; lazily. - - -(defmethod add-method-on-specializer ((method method) - (specializer class)) - (with-slots (direct-methods) - specializer - (setf (car direct-methods) - (adjoin method (car direct-methods)) - (cdr direct-methods) - nil)) - method) - -(defmethod remove-method-on-specializer ((method method) - (specializer class)) - (with-slots (direct-methods) - specializer - (setf (car direct-methods) - (remove method (car direct-methods)) - (cdr direct-methods) - nil)) - method) - -(defmethod specializer-methods ((specializer class)) - (with-slots (direct-methods) - specializer - (car direct-methods))) - -(defmethod specializer-generic-functions ((specializer class)) - (with-slots (direct-methods) - specializer - (or (cdr direct-methods) - (setf (cdr direct-methods) - (gathering1 (collecting-once) - (dolist (m (car direct-methods)) - (gather1 (method-generic-function m)))))))) - - -;;; This hash table is used to store the direct methods and direct generic functions of EQL -;;; specializers. Each value in the table is the cons. - - -(defvar *eql-specializer-methods* (make-hash-table :test #'eql)) - -(defmethod add-method-on-specializer ((method method) - (specializer eql-specializer)) - (let* ((object (eql-specializer-object specializer)) - (entry (gethash object *eql-specializer-methods*))) - (unless entry - (setq entry (setf (gethash object *eql-specializer-methods*) - (cons nil nil)))) - (setf (car entry) - (adjoin method (car entry)) - (cdr entry) - nil) - method)) - -(defmethod remove-method-on-specializer ((method method) - (specializer eql-specializer)) - (let* ((object (eql-specializer-object specializer)) - (entry (gethash object *eql-specializer-methods*))) - (when entry - (setf (car entry) - (remove method (car entry)) - (cdr entry) - nil)) - method)) - -(defmethod specializer-methods ((specializer eql-specializer)) - (car (gethash (eql-specializer-object specializer) - *eql-specializer-methods*))) - -(defmethod specializer-generic-functions ((specializer eql-specializer)) - (let* ((object (eql-specializer-object specializer)) - (entry (gethash object *eql-specializer-methods*))) - (when entry - (or (cdr entry) - (setf (cdr entry) - (gathering1 (collecting-once) - (dolist (m (car entry)) - (gather1 (method-generic-function m))))))))) - -(defun real-load-defclass (name metaclass-name supers slots other accessors) - (do-standard-defsetfs-for-defclass accessors) - ; *** - (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots - slots :definition-source `((defclass ,name () - ()) - ,(load-truename)) - other)) - -(defun ensure-class (name &rest all) - (apply #'ensure-class-using-class name (find-class name nil) - all)) - -(defmethod ensure-class-using-class (name (class null) - &rest args &key) - (multiple-value-bind (meta initargs) - (ensure-class-values class args) - (setf class (apply #'make-instance meta :name name initargs) - (find-class name) - class) - (inform-type-system-about-class class name) - ; *** - class)) - -(defmethod ensure-class-using-class (name (class clos-class) - &rest args &key) - (multiple-value-bind (meta initargs) - (ensure-class-values class args) - (unless (eq (class-of class) - meta) - (change-class class meta)) - (apply #'reinitialize-instance class initargs) - (inform-type-system-about-class class name) - ; *** - class)) - -(defun ensure-class-values (class args) - (let* ((initargs (copy-list args)) - (unsupplied (list 1)) - (supplied-meta (getf initargs :metaclass unsupplied)) - (supplied-supers (getf initargs :direct-superclasses unsupplied)) - (supplied-slots (getf initargs :direct-slots unsupplied)) - (meta (cond ((neq supplied-meta unsupplied) - (find-class supplied-meta)) - ((or (null class) - (forward-referenced-class-p class)) - *the-class-standard-class*) - (t (class-of class)))) - (proto (class-prototype meta))) - (flet ((fix-super (s) - (cond ((classp s) - s) - ((not (legal-class-name-p s)) - (error "~S is not a class or a legal class name." s)) - (t (or (find-class s nil) - (setf (find-class s) - (make-instance 'forward-referenced-class :name s))))))) - (loop (unless (remf initargs :metaclass) - (return))) - (loop (unless (remf initargs :direct-superclasses) - (return))) - (loop (unless (remf initargs :direct-slots) - (return))) - (values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied) - (mapcar #'fix-super supplied-supers) - ) - :direct-slots - (and (neq supplied-slots unsupplied) - supplied-slots) - initargs))))) - - -;;; - - -(defmethod shared-initialize :before ((class std-class) - slot-names &key direct-superclasses) - (declare (ignore slot-names)) - - ;; *** error checking - ) - -(defmethod shared-initialize :after ((class std-class) - slot-names - &key (direct-superclasses - nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - (direct-default-initargs - nil direct-default-initargs-p)) - (declare (ignore slot-names)) - (setq direct-superclasses (if direct-superclasses-p - (setf (slot-value class 'direct-superclasses) - (or direct-superclasses - (list *the-class-standard-object*) - )) - (slot-value class 'direct-superclasses))) - (setq direct-slots (if direct-slots-p - (setf (slot-value class 'direct-slots) - (mapcar #'(lambda (pl) - (make-direct-slotd class pl)) - direct-slots)) - (slot-value class 'direct-slots))) - (if direct-default-initargs-p - (setf (plist-value class 'direct-default-initargs) - direct-default-initargs) - (setq direct-default-initargs - (plist-value class 'direct-default-initargs))) - (setf (plist-value class 'class-slot-cells) - (gathering1 (collecting) - (dolist (dslotd direct-slots) - (when (eq (slotd-allocation dslotd) - class) - (let ((initfunction (slotd-initfunction dslotd))) - (gather1 (cons (slotd-name dslotd) - (if initfunction - (funcall initfunction) - *slot-unbound*)))))))) - (add-direct-subclasses class direct-superclasses) - (add-slot-accessors class direct-slots)) - -(defmethod reinitialize-instance :before ((class std-class) - &key direct-superclasses direct-slots - direct-default-initargs) - (declare (ignore direct-default-initargs)) - (remove-direct-subclasses class (class-direct-superclasses class)) - (remove-slot-accessors class (class-direct-slots class))) - -(defmethod reinitialize-instance :after ((class std-class) - &rest initargs &key) - (update-class class nil) - (map-dependents class #'(lambda (dependent) - (apply #'update-dependent class dependent initargs)))) - -(defun add-slot-accessors (class dslotds) - (fix-slot-accessors class dslotds 'add)) - -(defun remove-slot-accessors (class dslotds) - (fix-slot-accessors class dslotds 'remove)) - -(defun fix-slot-accessors (class dslotds add/remove) - (flet ((fix (gfspec name r/w) - (let ((gf (ensure-generic-function gfspec))) - (case r/w - (r (if (eq add/remove 'add) - (add-reader-method class gf name) - (remove-reader-method class gf))) - (w (if (eq add/remove 'add) - (add-writer-method class gf name) - (remove-writer-method class gf))))))) - (dolist (dslotd dslotds) - (let ((slot-name (slotd-name dslotd))) - (dolist (r (slotd-readers dslotd)) - (fix r slot-name 'r)) - (dolist (w (slotd-writers dslotd)) - (fix w slot-name 'w)))))) - -(defun add-direct-subclasses (class new) - (dolist (n new) - (unless (memq class (class-direct-subclasses class)) - (add-direct-subclass n class)))) - -(defun remove-direct-subclasses (class new) - (let ((old (class-direct-superclasses class))) - (dolist (o (set-difference old new)) - (remove-direct-subclass o class)))) - - -;;; - - -(defmethod finalize-inheritance ((class std-class)) - (update-class class t)) - - -;;; Called by :after reinitialize instance whenever a class is reinitialized. The class may or may -;;; not be finalized. - - -(defun update-class (class finalizep) - (when (or finalizep (class-finalized-p class)) - (let* ((dsupers (class-direct-superclasses class)) - (dslotds (class-direct-slots class)) - (dinits (class-direct-default-initargs class)) - (cpl (compute-class-precedence-list class dsupers)) - (eslotds (compute-slots class cpl dslotds)) - (inits (compute-default-initargs class cpl dinits))) - (update-cpl class cpl) - (update-slots class cpl eslotds) - (update-dinits class dinits) - (update-inits class inits) - (update-constructors class))) - (unless finalizep - (dolist (sub (class-direct-subclasses class)) - (update-class sub nil)))) - -(defun update-cpl (class cpl) - (when (class-finalized-p class) - (unless (equal (class-precedence-list class) - cpl) - (force-cache-flushes class))) - (setf (slot-value class 'class-precedence-list) - cpl)) - -(defun update-slots (class cpl eslotds) - (multiple-value-bind (nlayout nwrapper-class-slots) - (compute-storage-info cpl eslotds) - - ;; If there is a change in the shape of the instances then the old class is now obsolete. - (let* ((owrapper (class-wrapper class)) - (olayout (and owrapper (wrapper-instance-slots-layout owrapper))) - (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) - (nwrapper (cond ((null owrapper) - (make-wrapper class)) - ((and (equal nlayout olayout) - (not (iterate ((o (list-elements owrapper-class-slots)) - (n (list-elements nwrapper-class-slots))) - (unless (eq (car o) - (car n)) - (return t))))) - owrapper) - (t - - ;; This will initialize the new wrapper to have the same state as - ;; the old wrapper. We will then have to change that. This may - ;; seem like wasted work (it is), but the spec requires that we - ;; call make-instances-obsolete. - (make-instances-obsolete class) - (class-wrapper class))))) - (with-slots (wrapper no-of-instance-slots slots) - class - (setf no-of-instance-slots (length nlayout) - slots eslotds (wrapper-instance-slots-layout nwrapper) - nlayout - (wrapper-class-slots nwrapper) - nwrapper-class-slots wrapper nwrapper)) - (dolist (eslotd eslotds) - (setf (slotd-class eslotd) - class) - (setf (slotd-instance-index eslotd) - (instance-slot-index nwrapper (slotd-name eslotd))))))) - -(defun compute-storage-info (cpl eslotds) - (let ((instance nil) - (class nil)) - (dolist (eslotd eslotds) - (let ((alloc (slotd-allocation eslotd))) - (cond ((eq alloc :instance) - (push eslotd instance)) - ((classp alloc) - (push eslotd class))))) - (values (compute-layout cpl instance) - (compute-class-slots class)))) - -(defun compute-layout (cpl instance-eslotds) - (let* ((names (gathering1 (collecting) - (dolist (eslotd instance-eslotds) - (when (eq (slotd-allocation eslotd) - :instance) - (gather1 (slotd-name eslotd)))))) - (order nil)) - (labels ((rwalk (tail) - (when tail - (rwalk (cdr tail)) - (dolist (ss (class-slots (car tail))) - (let ((n (slotd-name ss))) - (when (memq n names) - (setq order (cons n order) - names - (remove n names)))))))) - (rwalk cpl) - (reverse (append names order))))) - -(defun compute-class-slots (eslotds) - (gathering1 (collecting) - (dolist (eslotd eslotds) - (gather1 (assoc (slotd-name eslotd) - (class-slot-cells (slotd-allocation eslotd))))))) -(defun update-dinits (class dinits) - (setf (plist-value class 'direct-default-initargs) - (remove-invalid dinits (class-slots class)))) - -(defun update-inits (class inits) - (setf (plist-value class 'default-initargs) - (remove-invalid inits (class-slots class)))) - -;; bug: :default-initargs aren't updated with slots are removed, so -;; update-inits removes initargs that don't have corresponding slots. - -(defun remove-invalid (inits slotds &aux (return nil)) - (dolist (element inits) - (dolist (slotd slotds) - (if (member (car element) (slot-value slotd 'initargs)) - (pushnew element return)))) - return) - - - -(defmethod compute-default-initargs ((class std-class) - cpl direct) - (labels ((walk (tail) - (if (null tail) - nil - (let ((c (pop tail))) - (append (if (eq c class) - direct - (class-direct-default-initargs c)) - (walk tail)))))) - (let ((initargs (walk cpl))) - (delete-duplicates initargs - :test #'eq :key #'car :from-end t)))) - - -;;; Protocols for constructing direct and effective slot definitions. - - -(defmethod direct-slot-definition-class ((class std-class) - initargs) - (declare (ignore initargs)) - (find-class 'standard-direct-slot-definition)) - -(defun make-direct-slotd (class initargs) - (let ((initargs (list* :class class initargs))) - (apply #'make-instance (direct-slot-definition-class class initargs) - initargs))) - - -;;; - - -(defmethod compute-slots ((class std-class) - cpl class-direct-slots) - - ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once for each different slot - ;; name we find in our superclasses. Each call receives the class and a list of the dslotds - ;; with that name. The list is in most-specific-first order. - (let ((name-dslotds-alist nil)) - (labels ((collect-one-class (dslotds) - (dolist (d dslotds) - (let* ((name (slotd-name d)) - (entry (assq name name-dslotds-alist))) - (if entry - (push d (cdr entry)) - (push (list name d) - name-dslotds-alist)))))) - (collect-one-class class-direct-slots) - (dolist (c (cdr cpl)) - (collect-one-class (class-direct-slots c))) - (mapcar #'(lambda (direct) - (compute-effective-slot-definition class (nreverse (cdr direct))) - ) - name-dslotds-alist)))) - -(defmethod compute-effective-slot-definition ((class std-class) - dslotds) - (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) - (class (effective-slot-definition-class class initargs))) - (apply #'make-instance class initargs))) - -(defmethod effective-slot-definition-class ((class std-class) - initargs) - (declare (ignore initargs)) - (find-class 'standard-effective-slot-definition)) - -(defmethod compute-effective-slot-definition-initargs ((class std-class) - direct-slotds) - (let* ((name nil) - (initfunction nil) - (initform nil) - (initargs nil) - (allocation nil) - (type t) - (namep nil) - (initp nil) - (allocp nil)) - (dolist (slotd direct-slotds) - (when slotd - (unless namep - (setq name (slotd-name slotd) - namep t)) - (unless initp - (when (slotd-initfunction slotd) - (setq initform (slotd-initform slotd) - initfunction - (slotd-initfunction slotd) - initp t))) - (unless allocp - (setq allocation (slotd-allocation slotd) - allocp t)) - (setq initargs (append (slotd-initargs slotd) - initargs)) - (let ((slotd-type (slotd-type slotd))) - (setq type (cond ((null type) - slotd-type) - ((subtypep type slotd-type) - type) - (t `(and ,type ,slotd-type))))))) - (list :name name :initform initform :initfunction initfunction :initargs initargs - :allocation allocation :type type))) - - -;;; NOTE: For bootstrapping considerations, these can't use make-instance to make the method object. -;;; They have to use make-a-method which is a specially bootstrapped mechanism for making standard -;;; methods. - - -(defmethod add-reader-method ((class std-class) - generic-function slot-name) - (let* ((name (class-name class)) - (method (make-a-method 'standard-reader-method nil (list (or name 'standard-object)) - (list class) - (make-reader-method-function class slot-name) - "automatically generated reader method" slot-name))) - (add-method generic-function method))) - -(defmethod add-writer-method ((class std-class) - generic-function slot-name) - (let* ((name (class-name class)) - (method (make-a-method 'standard-writer-method nil (list 'new-value (or name - - ' - standard-object - )) - (list *the-class-t* class) - (make-writer-method-function class slot-name) - "automatically generated writer method" slot-name))) - (add-method generic-function method))) - -(defmethod remove-reader-method ((class std-class) - generic-function) - (let ((method (get-method generic-function nil (list class) - nil))) - (when method (remove-method generic-function method)))) - -(defmethod remove-writer-method ((class std-class) - generic-function) - (let ((method (get-method generic-function nil (list *the-class-t* class) - nil))) - (when method (remove-method generic-function method)))) - - -;;; make-reader-method-function and make-write-method function are NOT part of the standard -;;; protocol. They are however useful, CLOS makes uses makes use of them internally and documents -;;; them for CLOS users. *** This needs work to make type testing by the writer functions which *** -;;; do type testing faster. The idea would be to have one constructor *** for each possible type -;;; test. In order to do this it would be nice *** to have help from inform-type-system-about-class -;;; and friends. *** There is a subtle bug here which is going to have to be fixed. *** Namely, the -;;; simplistic use of the template has to be fixed. We *** have to give the optimize-slot-value -;;; method the user might have *** defined for this metclass a chance to run. - - -(defmethod make-reader-method-function ((class standard-class) - slot-name) - (make-std-reader-method-function slot-name)) - -(defmethod make-writer-method-function ((class standard-class) - slot-name) - (make-std-writer-method-function slot-name)) - -(defun make-std-reader-method-function (slot-name) - #'(lambda (instance) - (slot-value instance slot-name))) - -(defun make-std-writer-method-function (slot-name) - #'(lambda (nv instance) - (setf (slot-value instance slot-name) - nv))) - - ; inform-type-system-about-class - ; make-type-predicate - - - -;;; These are NOT part of the standard protocol. They are internal mechanism which CLOS uses to -;;; *try* and tell the type system about class definitions. In a more fully integrated -;;; implementation of CLOS, the type system would know about class objects and class names in a more -;;; fundamental way and the mechanism used to inform the type system about new classes would be -;;; different. - - -(defmethod inform-type-system-about-class ((class std-class) - name) - (let ((predicate-name (make-type-predicate-name name))) - (setf (symbol-function predicate-name) - (make-type-predicate name)) - (do-satisfies-deftype name predicate-name) - (setf (gethash name lisp::*typep-hash-table*) - predicate-name))) ;makes typep significantly faster... - -(defun make-type-predicate (name) - #'(lambda (x) - (not (null (memq (find-class name) - (cond ((std-instance-p x) - (class-precedence-list (std-instance-class x))) - ((fsc-instance-p x) - (class-precedence-list (fsc-instance-class x))))))))) - - -;;; These 4 definitions appear here for bootstrapping reasons. Logically, they should be in the -;;; construct file. For documentation purposes, a copy of these definitions appears in the -;;; construct file. If you change one of the definitions here, be sure to change the copy there. - - -(defvar *initialization-generic-functions* (list #'make-instance #'default-initargs - #'allocate-instance #'initialize-instance - #'shared-initialize)) - -(defmethod maybe-update-constructors ((generic-function generic-function) - (method method)) - (when (memq generic-function *initialization-generic-functions*) - (labels ((recurse (class) - (update-constructors class) - (dolist (subclass (class-direct-subclasses class)) - (recurse subclass)))) - (when (classp (car (method-specializers method))) - (recurse (car (method-specializers method))))))) - -(defmethod update-constructors ((class std-class)) - (dolist (cons (class-constructors class)) - (install-lazy-constructor-installer cons))) - -(defmethod update-constructors ((class class)) - nil) - -(defmethod compatible-meta-class-change-p (class proto-new-class) - (eq (class-of class) - (class-of proto-new-class))) - -(defmethod check-super-metaclass-compatibility ((class t) - (new-super t)) - (unless (eq (class-of class) - (class-of new-super)) - (error "The class ~S was specified as a~%super-class of the class ~S;~%~ - but the meta-classes ~S and~%~S are incompatible." new-super class (class-of new-super) - (class-of class)))) - - -;;; - - -(defun force-cache-flushes (class) - (let* ((owrapper (class-wrapper class)) - (state (wrapper-state owrapper))) - - ;; We only need to do something if the state is still T. If the state isn't T, it will - ;; be FLUSH or OBSOLETE, and both of those will already be doing what we want. In - ;; particular, we must be sure we never change an OBSOLETE into a FLUSH since OBSOLETE - ;; means do what FLUSH does and then some. - (when (eq state 't) - (let ((nwrapper (make-wrapper class))) - (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) - (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) - (without-interrupts (setf (slot-value class 'wrapper) - nwrapper) - (invalidate-wrapper owrapper 'flush nwrapper)) - (update-constructors class))))) - - ; ??? *** - - -(defun flush-cache-trap (owrapper nwrapper instance) - (declare (ignore owrapper)) - (set-wrapper instance nwrapper)) - - -;;; make-instances-obsolete can be called by user code. It will cause the next access to the -;;; instance (as defined in 88-002R) to trap through the update-instance-for-redefined-class -;;; mechanism. - - -(defmethod make-instances-obsolete ((class std-class)) - (let ((owrapper (class-wrapper class)) - (nwrapper (make-wrapper class))) - (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) - (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) - (without-interrupts (setf (slot-value class 'wrapper) - nwrapper) - (invalidate-wrapper owrapper 'obsolete nwrapper) - class))) - -(defmethod make-instances-obsolete ((class symbol)) - (make-instances-obsolete (find-class class))) - - -;;; obsolete-instance-trap is the internal trap that is called when we see an obsolete instance. -;;; The times when it is called are: - when the instance is involved in method lookup - when -;;; attempting to access a slot of an instance It is not called by class-of, wrapper-of, or any of -;;; the low-level instance access macros. Of course these times when it is called are an internal -;;; implementation detail of CLOS and are not part of the documented description of when the obsolete -;;; instance update happens. The documented description is as it appears in 88-002R. This has to -;;; return the new wrapper, so it counts on all the methods on obsolete-instance-trap-internal to -;;; return the new wrapper. It also does a little internal error checking to make sure that the -;;; traps are only happening when they should, and that the trap methods are computing apropriate -;;; new wrappers. - - -(defun obsolete-instance-trap (owrapper nwrapper instance) - - ;; local --> local transfer local --> shared discard local --> -- - ;; discard shared --> local transfer shared --> shared discard shared --> -- - ;; discard -- --> local add -- --> shared -- - (let* ((class (wrapper-class nwrapper)) - (guts (allocate-instance class)) - ; ??? allocate-instance ??? - (olayout (wrapper-instance-slots-layout owrapper)) - (nlayout (wrapper-instance-slots-layout nwrapper)) - (oslots (get-slots instance)) - (nslots (get-slots guts)) - (oclass-slots (wrapper-class-slots owrapper)) - (added nil) - (discarded nil) - (plist nil)) - - ;; Go through all the old local slots. - (iterate ((name (list-elements olayout)) - (opos (interval :from 0))) - (let ((npos (posq name nlayout))) - (if npos - (setf (svref nslots npos) - (svref oslots opos)) - (progn (push name discarded) - (unless (eq (svref oslots opos) - *slot-unbound*) - (setf (getf plist name) - (svref oslots opos))))))) - - ;; Go through all the old shared slots. - (iterate ((oclass-slot-and-val (list-elements oclass-slots))) - (let ((name (car oclass-slot-and-val)) - (val (cdr oclass-slot-and-val))) - (let ((npos (posq name nlayout))) - (if npos - (setf (svref nslots npos) - (cdr oclass-slot-and-val)) - (progn (push name discarded) - (unless (eq val *slot-unbound*) - (setf (getf plist name) - val))))))) - - ;; Go through all the new local slots to compute the added slots. - (dolist (nlocal nlayout) - (unless (or (memq nlocal olayout) - (assq nlocal oclass-slots)) - (push nlocal added))) - (without-interrupts (set-wrapper instance nwrapper) - (set-slots instance nslots)) - (update-instance-for-redefined-class instance added discarded plist) - nwrapper)) - - -;;; - - -(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc) - `(let* ((old-class (class-of instance)) - (copy (,alloc old-class)) - (guts (,alloc new-class)) - (new-wrapper (,wrapper-fetcher guts)) - (old-wrapper (class-wrapper old-class)) - (old-layout (wrapper-instance-slots-layout old-wrapper)) - (new-layout (wrapper-instance-slots-layout new-wrapper)) - (old-slots (,slots-fetcher instance)) - (new-slots (,slots-fetcher guts)) - (old-class-slots (wrapper-class-slots old-wrapper))) - - ;; "The values of local slots specified by both the class Cto and Cfrom are retained. - ;; If such a local slot was unbound, it remains unbound." - (iterate ((new-slot (list-elements new-layout)) - (new-position (interval :from 0))) - (let ((old-position (position new-slot old-layout :test #'eq))) - (when old-position - (setf (svref new-slots new-position) - (svref old-slots old-position))))) - - ;; "The values of slots specified as shared in the class Cfrom and as local in the - ;; class Cto are retained." - (iterate ((slot-and-val (list-elements old-class-slots))) - (let ((position (position (car slot-and-val) - new-layout :test #'eq))) - (when position - (setf (svref new-slots position) - (cdr slot-and-val))))) - - ;; Make the copy point to the old instance's storage, and make the old instance point - ;; to the new storage. - (without-interrupts (setf (,slots-fetcher copy) - old-slots) - (setf (,wrapper-fetcher instance) - new-wrapper) - (setf (,slots-fetcher instance) - new-slots)) - (update-instance-for-different-class copy instance) - instance)) - -(defmethod change-class ((instance standard-object) - (new-class standard-class)) - (unless (std-instance-p instance) - (error "Can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass~%~S." instance new-class - 'standard-class)) - (change-class-internal std-instance-wrapper std-instance-slots allocate-instance)) - -(defmethod change-class ((instance standard-object) - (new-class funcallable-standard-class)) - (unless (fsc-instance-p instance) - (error "Can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass~%~S." instance new-class - 'funcallable-standard-class)) - (change-class-internal fsc-instance-wrapper fsc-instance-slots allocate-instance)) - -(defmethod change-class ((instance t) - (new-class-name symbol)) - (change-class instance (find-class new-class-name))) - - -;;; The metaclass BUILT-IN-CLASS This metaclass is something of a weird creature. By this point, -;;; all instances of it which will exist have been created, and no instance is ever created by -;;; calling MAKE-INSTANCE. But, there are other parts of the protcol we must follow and those -;;; definitions appear here. - - -(defmethod shared-initialize :before ((class built-in-class) - slot-names &rest initargs) - (declare (ignore slot-names)) - (error "Attempt to initialize or reinitialize a built in class.")) - -(defmethod class-direct-slots ((class built-in-class)) - nil) - -(defmethod class-slots ((class built-in-class)) - nil) - -(defmethod class-direct-default-initargs ((class built-in-class)) - nil) - -(defmethod class-default-initargs ((class built-in-class)) - nil) - -(defmethod check-super-metaclass-compatibility ((c class) - (s built-in-class)) - (or (eq s *the-class-t*) - (error "~S cannot have ~S as a super.~%~ - The class ~S is the only built in class that can be a~%~ - superclass of a standard class." c s *the-class-t*))) - - -;;; - - -(defmethod check-super-metaclass-compatibility ((c std-class) - (f forward-referenced-class)) - 't) - - -;;; - - -(defmethod add-dependent ((metaobject dependent-update-mixin) - dependent) - (pushnew dependent (plist-value metaobject 'dependents))) - -(defmethod remove-dependent ((metaobject dependent-update-mixin) - dependent) - (setf (plist-value metaobject 'dependents) - (delete dependent (plist-value metaobject 'dependents)))) - -(defmethod map-dependents ((metaobject dependent-update-mixin) - function) - (dolist (dependent (plist-value metaobject 'dependents)) - (funcall function dependent))) diff --git a/obsolete/clos/2.0/test.lisp b/obsolete/clos/2.0/test.lisp deleted file mode 100644 index 74c921f2..00000000 --- a/obsolete/clos/2.0/test.lisp +++ /dev/null @@ -1,2880 +0,0 @@ -;;;-*- Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; Testing code. -;;; - -(in-package :clos) - -;;; Because CommonLoops runs in itself so much, the notion of a test file for -;;; it is kind of weird. -;;; -;;; If all of CLOS loads then many of the tests in this file (particularly -;;; those at the beginning) are sure to work. Those tests exists primarily -;;; to help debug things when low-level changes are made to CLOS, or when a -;;; particular port customizes low-level code. -;;; -;;; Some of the other tests are "real" in the sense that they test things -;;; that CLOS itself does not use, so might be broken. -;;; -;;; NOTE: -;;; The tests in this file do not appear in random order! They -;;; depend on state which has already been set up in order to run. -;;; - -(defmacro do-test (name cleanups &body body) - `(let ((do-test-failed nil)) - (catch 'do-test - (format t "~&Testing ~A..." ,name) -; (cleanup-do-test ',cleanups) - (block do-test ,@body) - (if do-test-failed - (format t "~&FAILED!") - (format t "OK"))))) - -(defmacro do-test-error (fatal string &rest args) - `(progn (terpri) - (setq do-test-failed t) - (format t ,string ,@args) - (when ,fatal (return-from do-test nil)))) - -(defun cleanup-do-test (cleanups) - (dolist (cleanup cleanups) - (ecase (car cleanup) - (:classes - (dolist (c (cdr cleanup)) - (let ((class (find-class c 'nil))) - (when class - (dolist (super (slot-value class 'direct-superclasses)) - (setf (slot-value class 'direct-subclasses) - (remove class (slot-value class 'direct-subclasses)))) - (setf (find-class c) nil))))) - (:functions - (dolist (f (cdr cleanup)) - (fmakunbound f))) - (:setf-generic-functions - (dolist (f (cdr cleanup)) - (fmakunbound (get-setf-function-name f)))) - (:variables - (dolist (v (cdr cleanup)) - (makunbound v)))))) - -#-(or KCL IBCL :Coral GCLisp) -(eval-when (eval) - (compile 'do-test) - (compile 'do-test-error) - (compile 'cleanup-do-test)) - - ;; -;;;;;; - ;; - -(do-test "types for early classes" - () - (dolist (x '(standard-object standard-class standard-slot-definition)) - (or (typep (make-instance x) x) - (do-test-error () "instance of ~S not of type ~S??" x x)))) - - -(do-test "types for late classes" - () - (dolist (x '(standard-method standard-generic-function)) - (or (typep (make-instance x) x) - (do-test-error () "~&instance of ~S not of type ~S??" x x)))) - -(defvar *built-in-class-tests* - '((ARRAY (MAKE-ARRAY '(10 10))) - (BIT-VECTOR (MAKE-ARRAY 10 :ELEMENT-TYPE 'BIT)) - (CHARACTER #\a) - (COMPLEX #C(1 2)) - (CONS (LIST 1 2 3)) - (FLOAT 1.3) - (INTEGER 1) - ;LIST abstract super of cons, null - (NULL NIL) - ;NUMBER abstract super of complex, float, rational - (RATIO 1/2) - ;RATIONAL abstract super of ratio, integer - ;SEQUENCE abstract super of list, vector - (STRING "foo") - (SYMBOL 'FOO) - (VECTOR (VECTOR 1 2 3)))) - -(do-test "built-in-class-of" - () - (let ((lostp nil)) - (dolist (tst *built-in-class-tests*) - (unless (eq (find-class (car tst) 't) - (class-of (eval (cadr tst)))) - (do-test-error () - "~&class-of ~S was ~A not ~A~%" - (cadr tst) - (class-name (class-of (eval (cadr tst)))) - (car tst)) - (setq lostp t))) - (not lostp))) - -(do-test "existence of generic-functions for accessors of early classes" - () - ;; Because accessors are done with add-method, and this has to be done - ;; specially for early classes it is worth testing to make sure that - ;; the generic-functions got created for the accessor of early classes. - ;; - ;; Of course CLOS wouldn't have loaded if most of these didn't exist, - ;; but what the hell. - (dolist (class '(standard-class - standard-slot-definition - standard-generic-function - standard-method)) - (dolist (slotd (class-slots (find-class class))) - (dolist (rea (slotd-readers slotd)) - (unless (and (gboundp rea) - (generic-function-p (gdefinition rea))) - (do-test-error () "~S isn't a generic function" rea))) - (dolist (wri (slotd-writers slotd)) - (unless (and (gboundp wri) - (generic-function-p (gdefinition wri))) - (do-test-error () "~S isn't a generic function" wri)))))) - -(do-test "early reader/writer methods are appropriate class" - () - ;; Because accessors are done with add-method, and this has to be done - ;; specially for early classes it is worth testing to make sure that - ;; the generic-functions got created for the accessor of early classes. - ;; - ;; Of course CLOS wouldn't have loaded if most of these didn't exist, - ;; but what the hell. - (dolist (class '(standard-class - standard-slot-definition - standard-generic-function - standard-method)) - (let ((class (find-class 'standard-class))) - (flet ((check-reader (gf) - (let ((reader (get-method (gdefinition gf) - () - (list class)))) - (unless (typep reader 'standard-reader-method) - (do-test-error () "~S isn't a READER method" reader)))) - (check-writer (gf) - (let ((writer (get-method (gdefinition gf) - () - (list (find-class 't) class)))) - (unless (typep writer 'standard-writer-method) - (do-test-error () "~S isn't a WRITER method" writer))))) - (dolist (slotd (class-direct-slots class)) - (dolist (rea (slotd-readers slotd)) - (check-reader rea)) - (dolist (wri (slotd-writers slotd)) - (check-writer wri))))))) - -(do-test "typep works for standard-classes" - ((:classes foo1 foo2 bar)) - - (defclass foo1 () ()) - (defclass foo2 (foo1) ()) - (defclass bar () ()) - - (let ((f1 (make-instance 'foo1)) - (f2 (make-instance 'foo2))) - (or (typep f1 'foo1) - (do-test-error - () "an instance of foo1 isn't subtypep of foo1")) - (or (not (typep f1 'foo2)) - (do-test-error - () "an instance of foo1 is suptypep of a subclass of foo1")) - (or (not (typep f1 'bar)) - (do-test-error - () "an instance of foo1 is subtypep of an unrelated class")) - (or (typep f2 'foo1) - (do-test-error - () "an instance of foo2 is not subtypep of a super-class of foo2")) - )) - -(do-test "accessors and readers should NOT be inherited" - ((:classes foo bar) - (:functions foo-x foo-y)) - - (defclass foo () - ((x :accessor foo-x) - (y :reader foo-y))) - - (fmakunbound 'foo-x) - (fmakunbound 'foo-y) - - (defclass bar (foo) - (x y)) - - (and (fboundp 'foo-x) (do-test-error () "foo-x got inherited?")) - (and (fboundp 'foo-y) (do-test-error () "foo-x got inherited?"))) - -(do-test ":accessor and :reader methods go away" - ((:classes foo) - (:functions foo-x foo-y) - (:setf-generic-functions foo-x foo-y)) - - (defclass foo () ((x :accessor foo-x) (y :reader foo-y))) - - (unless (and (fboundp 'foo-x) - (fboundp 'foo-y)) - (do-test-error t "accessors didn't even get generated?")) - - (defclass foo () (x y)) - - (flet ((methods (x) - (generic-function-methods (symbol-function 'foo-y)))) - - (and (methods 'foo-x) - (do-test-error () "~&reader method for foo-x not removed")) - (and (methods 'foo-y) - (do-test-error () "~&reader method for foo-y not removed")) - (and (methods (get-setf-function-name 'foo-y)) - (do-test-error () "~&writer method for foo-y not removed")) - t)) - - -(defclass test-class-1 () - ((x :initform nil :accessor test-class-1-x :initarg :x) - (y :initform nil :accessor test-class-1-y :initarg :y))) - -(do-test "Simple with-accessors test -- does not really exercise the walker." - ((:functions foo bar)) - - (defmethod foo ((obj test-class-1)) - (with-accessors ((x test-class-1-x) - (y test-class-1-y)) - obj - (list x y))) - - (defmethod bar ((obj test-class-1)) - (with-accessors ((x test-class-1-x) - (y test-class-1-y)) - obj - (setq x 1 - y 2))) - - (or (and (equal '(nil nil) (foo (make-instance 'test-class-1))) - (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2)))) - (do-test-error () "FOO (the one that reads) failed")) - - (or (let ((foo (make-instance 'test-class-1))) - (bar foo) - (or (and (equal (slot-value foo 'x) 1) - (equal (slot-value foo 'y) 2)) - (do-test-error () "BAR (the one that writes) failed"))))) - -(do-test "Simple with-slots test -- does not really exercise the walker." - ((:functions foo bar)) - - (defmethod foo ((obj test-class-1)) - (with-slots (x y) - obj - (list x y))) - - (defmethod bar ((obj test-class-1)) - (with-slots ((obj-x x) - (obj-y y)) - obj - (setq obj-x 1 - obj-y 2))) - - (or (and (equal '(nil nil) (foo (make-instance 'test-class-1))) - (equal '(1 2) (foo (make-instance 'test-class-1 :x 1 :y 2)))) - (do-test-error () "FOO (the one that reads) failed")) - - (or (let ((foo (make-instance 'test-class-1))) - (bar foo) - (or (and (equal (slot-value foo 'x) 1) - (equal (slot-value foo 'y) 2)) - (do-test-error () "BAR (the one that writes) failed"))))) - - ;; -;;;;;; things that bug fixes prompted. - ;; - - -(do-test "with-slots inside of lexical closures" - ((:functions frog barg)) - ;; 6/20/86 - ;; The walker was confused about what (FUNCTION (LAMBDA ..)) meant. It - ;; didn't walk inside there. Its sort of surprising this didn't get - ;; caught sooner. - - (defun frog (fn foos) - (and foos (cons (funcall fn (car foos)) (frog fn (cdr foos))))) - - (defun barg () - (let ((the-test-class (make-instance 'test-class-1 :x 0 :y 3))) - (with-slots (x y) - the-test-class - (frog #'(lambda (foo) (incf x) (decf y)) - (make-list 3))))) - - (or (equal (barg) '(2 1 0)) - (do-test-error t "lost"))) - -(do-test "redefinition of default method has proper effect" - ((:functions foo)) - ;; 5/26/86 - ;; This was caused because the hair for trying to avoid making a - ;; new discriminating function didn't know that changing the default - ;; method was a reason to make a new discriminating function. Fixed - ;; by always making a new discriminating function when a method is - ;; added or removed. The template stuff should keep this from being - ;; expensive. - - (defmethod foo ((x standard-class)) 'standard-class) - (defmethod foo (x) 'default) - (defmethod foo (x) 'new-default) - - (or (eq (foo nil) 'new-default) - (do-test-error t "lost"))) - - - -(defvar *call-next-method-test-object* (make-instance 'standard-object)) - -(do-test "call-next-method passes original arguments" - ((:functions foo)) - ;; 2/4/88 - ;; The spec says that call-next-method must pass the original arguments - ;; to call-next-method when none are supplied. This tests that. - - (defmethod foo ((x t)) - (unless (eq x *call-next-method-test-object*) - (do-test-error t "got wrong value"))) - - (defmethod foo ((x standard-object)) - (setq x nil) - (call-next-method)) - - (foo *call-next-method-test-object*) - - ) - -(do-test "call-next-method closures pass original arguments - 1" - ((:functions foo)) - ;; 2/4/88 - ;; call-next-method must pass the original arguments even when it is - ;; returned as a lexical closure with indefinite extent - - (defmethod foo ((x t)) - (unless (eq x *call-next-method-test-object*) - (do-test-error t "got wrong value"))) - - (defmethod foo ((x standard-object)) - (setq x nil) - #'call-next-method) - - (funcall (foo *call-next-method-test-object*)) - - ) - -(do-test "call-next-method closures pass original arguments - 2" - ((:functions foo)) - ;; 2/4/88 - ;; call-next-method must pass the original arguments even when it is - ;; returned as a lexical closure with indefinite extent - - (defmethod foo ((x t)) - (unless (eq x *call-next-method-test-object*) - (do-test-error t "got wrong value"))) - - (defmethod foo ((x standard-object)) - #'(lambda () - (setq x nil) - (call-next-method))) - - (funcall (foo *call-next-method-test-object*)) - - ) - -(do-test "call-next-method passes supplied arguments" - ((:functions foo)) - ;; 2/4/88 - ;; The spec says that call-next-method must pass the original arguments - ;; to call-next-method when none are supplied. This tests that. - - (defmethod foo ((x t)) - (unless (eq x *call-next-method-test-object*) - (do-test-error t "got wrong value"))) - - (defmethod foo ((x standard-object)) - (call-next-method *call-next-method-test-object*)) - - (foo (make-instance 'standard-object)) - - ) - -(do-test "call-next-method closures pass supplied arguments - 1" - ((:functions foo)) - ;; 2/4/88 - ;; call-next-method must pass the original arguments even when it is - ;; returned as a lexical closure with indefinite extent - - (defmethod foo ((x t)) - (unless (eq x *call-next-method-test-object*) - (do-test-error t "got wrong value"))) - - (defmethod foo ((x standard-object)) - #'call-next-method) - - (funcall (foo (make-instance 'standard-object)) *call-next-method-test-object*) - - ) - -(do-test "call-next-method closures pass supplied arguments - 2" - ((:functions foo)) - ;; 2/4/88 - ;; call-next-method must pass the original arguments even when it is - ;; returned as a lexical closure with indefinite extent - - (defmethod foo ((x t)) - (unless (eq x *call-next-method-test-object*) - (do-test-error t "got wrong value"))) - - (defmethod foo ((x standard-object)) - #'(lambda (x) - (call-next-method x))) - - (funcall (foo (make-instance 'standard-object)) - *call-next-method-test-object*)) - - -(do-test "call-next-method inside of default value form of &optional" - ((:functions foo)) - ;; 5/3/88 - ;; call-next-method must work inside the default value forms of the - ;; method's &mumble arguments. - - (defmethod foo1 ((x t) &optional y) - (declare (ignore y)) - *call-next-method-test-object*) - - (defmethod foo1 ((x standard-object) &optional (y (call-next-method))) - (list x y)) - - (let ((object (make-instance 'standard-object))) - (unless (equal (foo1 object) (list object *call-next-method-test-object*)) - (do-test-error t "Got wrong value")))) - -(do-test "specifying :type when superclass doesn't" - ((:classes foo bar)) - ;; 3/23/88 - ;; if a suclass specifies the :type slot option for a slot for which no - ;; superclass specifies a type then the inheritance rule is just to take - ;; the type specified by the subclass - - (defclass foo () - ((x))) - - (defclass bar (foo) - ((x :type number)))) - - -(do-test "Leaky next methods" - ((:functions foo bar)) - ;; 6/23/88 - ;; Since I use special variables to communicate the next methods info, - ;; there can be bugs which cause them to leak to the wrong method. - - (defmethod foo ((x standard-class)) - (bar x)) - - (defmethod foo ((x class)) - (call-next-method)) - - (defmethod foo ((x t)) - t) - - (defmethod bar ((x standard-class)) - (next-method-p)) - - (unless (foo (find-class 't)) - (do-test-error nil "Method leaked."))) - - -;;; -;;; some simple tests for initialization protocols -;;; 8/5/88 -;;; -(proclaim '(special x-initform-fired y-initform-fired z-initform-fired)) - -(defclass initialization-test-1 () - ((x :initform (setq x-initform-fired 'x-initform)) - (y :initform (setq y-initform-fired 'y-initform)) - (z :initform (setq z-initform-fired 'z-initform)))) - -(defclass initialization-test-2 () - ((x :initform (setq x-initform-fired 'x-initform) :initarg :x) - (y :initform (setq y-initform-fired 'y-initform) :initarg :y) - (z :initform (setq z-initform-fired 'z-initform) :initarg :z))) - -(defclass initialization-test-3 () - ((x :initform (setq x-initform-fired 'x-initform) :initarg :x) - (y :initform (setq y-initform-fired 'y-initform) :initarg :y) - (z :initform (setq z-initform-fired 'z-initform) :initarg :z)) - (:default-initargs :x 'x-default)) - -(defclass initalization-test-4 (initialization-test-3) - () - (:default-initargs :z 'z-default)) - -(defclass initialization-test-5 (initialization-test-4) - () - (:default-initargs :x 'x-default-from-5)) - -(do-test "shared-initialize with T argument and no initargs" - () - - (let (x-initform-fired y-initform-fired z-initform-fired) - (let* ((class (find-class 'initialization-test-1)) - (instance (allocate-instance class))) - - (shared-initialize instance 't) - - (unless x-initform-fired (do-test-error nil "x initform not evaluated")) - (unless y-initform-fired (do-test-error nil "y initform not evaluated")) - (unless z-initform-fired (do-test-error nil "z initform not evaluated")) - - (unless (eq (slot-value instance 'x) 'x-initform) - (do-test-error nil "Value of X doesn't match initform")) - (unless (eq (slot-value instance 'y) 'y-initform) - (do-test-error nil "Value of X doesn't match initform")) - (unless (eq (slot-value instance 'z) 'z-initform) - (do-test-error nil "Value of X doesn't match initform")) - - ))) - -(do-test "shared-initialize with T argument and initargs" - () - - (let (x-initform-fired y-initform-fired z-initform-fired) - (let* ((class (find-class 'initialization-test-2)) - (instance (allocate-instance class))) - - (shared-initialize instance 't :y 'y-initarg) - - (unless x-initform-fired - (do-test-error nil "x initform not evaluated")) - (unless (not y-initform-fired) - (do-test-error nil "y initform was evaluated")) - (unless z-initform-fired - (do-test-error nil "z initform not evaluated")) - - (unless (eq (slot-value instance 'x) 'x-initform) - (do-test-error nil "Value of X doesn't match initform")) - (unless (eq (slot-value instance 'y) 'y-initarg) - (do-test-error nil "Value of X doesn't match initform")) - (unless (eq (slot-value instance 'z) 'z-initform) - (do-test-error nil "Value of X doesn't match initform")) - - ))) - -(do-test "initialization arguments rules test" - ((:classes foo bar)) - - (defclass foo () - ((x :initarg a))) - - (defclass bar (foo) - ((x :initarg b)) - (:default-initargs a 1 b 2)) - - (unless (and (equal (default-initargs (find-class 'bar) '()) - '(b 2 a 1)) - (equal (default-initargs (find-class 'bar) '(a 3)) - '(a 3 b 2)) - (equal (default-initargs (find-class 'bar) '(b 4)) - '(b 4 a 1)) - (equal (default-initargs (find-class 'bar) '(a 1 a 2)) - '(a 1 a 2 b 2))) - (do-test-error nil "default-initargs got wrong value")) - - (unless (and (eq (slot-value (make-instance 'bar) 'x) 1) - (eq (slot-value (make-instance 'bar 'a 3) 'x) 3) - (eq (slot-value (make-instance 'bar 'b 4) 'x) 4) - (eq (slot-value (make-instance 'bar 'a 1 'a 2) 'x) 1)) - (do-test-error nil "initialization in make-instance failed")) - - ) - - -#| testing a pair of lists for equality bogus, '(a b c) <> '(b c a) - -(do-test "more tests for initialization arguments rules" - ((:classes foo fie bar baz)) - - (defclass foo () - ((a :initform 'initform-foo-a) - (b :initarg :foo-b) - (c :initform 'initform-foo-c) - (d :initarg :foo-d)) - (:default-initargs :foo-b 'initarg-foo-b - :foo-d 'initarg-foo-d)) - (defclass fie (foo) - ((a :initform 'initform-fie-a) - (b :initarg :fie-b) - (c :initform 'initform-fie-c :allocation :class) - (d :initarg :fie-d :allocation :class)) - (:default-initargs :fie-b 'initarg-fie-b - :fie-d 'initarg-fie-d)) - (defclass bar (foo) - ((a :initform 'initform-bar-a) - (b :initarg :bar-b) - (c :initform 'initform-bar-c) - (d :initarg :bar-d)) - (:default-initargs :bar-b 'initarg-bar-b - :bar-d 'initarg-bar-d)) - (defclass baz (fie bar) - ((a :initform 'initform-baz-a) - (b :initarg :baz-b) - (c :initform 'initform-baz-c) - (d :initarg :baz-d)) - (:default-initargs :baz-b 'initarg-baz-b - :baz-d 'initarg-baz-d)) - - (unless (and (equal (default-initargs (find-class 'foo) ()) - '(:foo-d initarg-foo-d - :foo-b initarg-foo-b)) - (equal (default-initargs (find-class 'fie) ()) - '(:fie-b initarg-fie-b - :fie-d initarg-fie-d - :foo-b initarg-foo-b - :foo-d initarg-foo-d)) - (equal (default-initargs (find-class 'bar) ()) - '(:bar-b initarg-bar-b - :bar-d initarg-bar-d - :foo-b initarg-foo-b - :foo-d initarg-foo-d)) - (equal (default-initargs (find-class 'baz) ()) - '(:baz-b initarg-baz-b - :baz-d initarg-baz-d - :fie-b initarg-fie-b - :fie-d initarg-fie-d - :bar-b initarg-bar-b - :bar-d initarg-bar-d - :foo-b initarg-foo-b - :foo-d initarg-foo-d))) - (do-test-error nil "default-initargs got wrong value")) - ) -|# -(do-test "initialization protocols" - ((:classes foo)) - - (let ((initform-for-x 'initform-x) - (initform-for-y 'initform-y) - (initform-for-z 'initform-z) - (default-initarg-for-x 'default-initarg-x) - (initarg-supplied-for-z 'initarg-z) - instance-of-foo) - - (defclass foo () - ((x :initform initform-for-x :initarg :x) - (y :initform initform-for-y :initarg :y) - (z :initform initform-for-z :initarg :z)) - (:default-initargs :x default-initarg-for-x)) - - (setq instance-of-foo (make-instance 'foo :z initarg-supplied-for-z)) - - (unless (and (eq (slot-value instance-of-foo 'x) - default-initarg-for-x) - (eq (slot-value instance-of-foo 'y) - initform-for-y) - (eq (slot-value instance-of-foo 'z) - initarg-supplied-for-z)) - (do-test-error nil "initialization failed")) - - (setq instance-of-foo - (reinitialize-instance (allocate-instance (find-class 'foo)) - :z initarg-supplied-for-z)) - - (unless (and (not (slot-boundp instance-of-foo 'x)) - (not (slot-boundp instance-of-foo 'y)) - (eq (slot-value instance-of-foo 'z) - initarg-supplied-for-z)) - (do-test-error nil "initialization failed"))) - - ) - -(do-test "update-instance-for-different-class" - ((:classes foo bar)) - - (let ((initform-for-x 'initform-x) - (initform-for-y 'initform-y) - (default-initarg-for-x 'default-initarg-x) - (initform-for-z 'initform-z) - (initform-for-u 'initform-u) - (initform-for-v 'initform-v) - (default-initarg-for-z 'default-intiarg-z) - (initarg-supplied-for-v 'initarg-v) - instance-of-foo - instance-of-bar) - - (defclass foo () - ((x :initform initform-for-x :initarg :x) - (y :initform initform-for-y :initarg :y)) - (:default-initargs :x default-initarg-for-x)) - - (defclass bar () - ((x :initform initform-for-x :initarg :x) - (y :initform initform-for-y :initarg :y) - (z :initform initform-for-z :initarg :z) - (u :initform initform-for-u :initarg :u) - (v :initform initform-for-v :initarg :v)) - (:default-initargs :z default-initarg-for-z)) - - (setq instance-of-foo (make-instance 'foo)) - (setq instance-of-bar (allocate-instance (find-class 'bar))) - (update-instance-for-different-class instance-of-foo instance-of-bar - :v initarg-supplied-for-v) - (unless (and (not (slot-boundp instance-of-bar 'x)) - (not (slot-boundp instance-of-bar 'y)) - (eq (slot-value instance-of-bar 'z) initform-for-z) - (eq (slot-value instance-of-bar 'u) initform-for-u) - (eq (slot-value instance-of-bar 'v) initarg-supplied-for-v)) - (do-test-error nil "initialization failed")))) - -(do-test "only needed forms should be evaluated in initializing instances" - ((:classes foo)) - - (defclass foo () - ((x :initform (do-test-error nil "x initform was evaluated") - :initarg :x) - (y :initform (do-test-error nil "y initform was evaluated") - :initarg :y) - (z :initform (do-test-error nil "z initform was evaluated") - :initarg :z)) - (:default-initargs :y 1 - :z (do-test-error nil "z default initarg was evaluated"))) - - (make-instance 'foo :x 1 :z 1)) - - -;;; -;;; We need to put these class defenitions in top level. -;;; - -(defclass class-for-testing-change-class-1 () - ((x :initform 'x :accessor class-1-x) - (y :initform 'y :accessor class-1-y))) - -(defclass class-for-testing-change-class-2 () - ((a :initform 'a :accessor class-2-a) - (b :initform 'b :accessor class-2-b))) - -(do-test "update-instance-for-different-class/change-class" - () - - (defmethod update-instance-for-different-class - ((previous class-for-testing-change-class-1) - (current class-for-testing-change-class-2) - &rest initargs) - (declare (ignore initargs)) - (setf (class-2-a current) (class-1-x previous)) - (setf (class-2-b current) (class-1-y previous))) - - (let ((f1 (make-instance 'class-for-testing-change-class-1)) - (f2 (make-instance 'class-for-testing-change-class-1))) - (change-class f1 (find-class 'class-for-testing-change-class-2)) - (unless (and (eq (class-2-a f1) (class-1-x f2)) - (eq (class-2-b f1) (class-1-y f2))) - (do-test-error nil "change class failed"))) - ) - -(cleanup-do-test '((:classes class-for-testing-redefined-class) - (:functions test-x test-y test-a) - (:setf-generic-functions class-x class-y))) - -(let (foo) - (defclass class-for-testing-redefined-class () - ((x :initform 'x :accessor test-x) - (y :initform 'y :accessor test-y))) - - (setq foo (make-instance 'class-for-testing-redefined-class)) - - (defclass class-for-testing-redefined-class () - ((a :initform 0 :accessor test-a) - (y :initform 1 :accessor test-y))) - - (do-test "update-instance-for-redefined-class/make-instances-obsolete(1)" - () - (unless (and (eq (test-a foo) 0) - (eq (test-y foo) 'y)) - (do-test-error nil "default behavior failed")))) - -(cleanup-do-test '((:classes x-y-pos) - (:functions pos-x pos-y pos-rho pos-theta) - (:setf-generic-functions pos-x pos-y pos-rho pos-theta))) - -(let (old-pos new-pos) - - (defclass x-y-pos () - ((x :initform 3 :accessor pos-x) - (y :initform 4 :accessor pos-y))) - - (setq old-pos (make-instance 'x-y-pos)) - - (defclass x-y-pos () - ((rho :initform 0 :accessor pos-rho) - (theta :initform 0 :accessor pos-theta))) - - (do-test "update-instance-for-redefined-class/make-instances-obsolete(2)" - () - - (defmethod update-instance-for-redefined-class :before - ((pos x-y-pos) added deleted plist &key) - ;; Transform the x-y coordinates to polar coordinates - ;; and store into the new slots - (let ((x (getf plist 'x)) - (y (getf plist 'y))) - (setf (pos-rho pos) (sqrt (+ (* x x) (* y y))) - (pos-theta pos) (atan y x)))) - - (defmethod pos-x ((pos x-y-pos)) - (with-slots (rho theta) pos (* rho (cos theta)))) - - (defmethod (setf pos-x) (new-x (pos x-y-pos)) - (with-slots (rho theta) pos - (let ((y (pos-y pos))) - (setq rho (sqrt (+ (* new-x new-x) (* y y))) - theta (atan y new-x)) - new-x))) - - (defmethod pos-y ((pos x-y-pos)) - (with-slots (rho theta) pos (* rho (sin theta)))) - - (defmethod (setf pos-y) (new-y (pos x-y-pos)) - (with-slots (rho theta) - (let ((x (pos-x pos))) - (setq rho (sqrt (+ (* x x) (* new-y new-y))) - theta (atan new-y x)) - new-y))) - - (unless (and (equalp 5 (pos-rho old-pos)) - (equalp (* 5 (cos (atan 4 3))) (pos-x old-pos)) - (equalp (* 5 (sin (atan 4 3))) (pos-y old-pos))) - (do-test-error nil "specialized behaivior failed")) - )) - -(cleanup-do-test '((:classes class-for-testing-redefined-class - test-obsolete-class) - (:functions test-x test-y test-a) - (:setf-generic-functions class-x class-y))) - -(defclass test-obsolete-class (standard-class) ()) - -(defmethod check-super-metaclass-compatibility ((x test-obsolete-class) - (y standard-class)) - 't) - -(let ((foo 'nil) - bar) - (defmethod make-instances-obsolete ((x test-obsolete-class)) - (setq foo 'called) - (call-next-method)) - - (defclass class-for-testing-redefined-class () - ((x :initform 'x :accessor test-x) - (y :initform 'y :accessor test-y)) - (:metaclass test-obsolete-class)) - - (setq bar (make-instance 'class-for-testing-redefined-class)) - - (defclass class-for-testing-redefined-class () - ((a :initform 0 :accessor test-a) - (y :initform 1 :accessor test-y))) - - (do-test "update-instance-for-redefined-class/make-instances-obsolete(3)" - () - (unless (and (eq (test-a bar) 0) - (eq (test-y bar) '1) - (eq foo 'called)) - (do-test-error nil "imcompatible class change failed")))) - -(cleanup-do-test '((:classes class-for-testing-redefined-class) - (:functions test-x test-y test-a) - (:setf-generic-functions class-x class-y))) - -(let (foo) - (defclass class-for-testing-redefined-class () - ((x :initform 'x :accessor test-x) - (y :initform 'y :accessor test-y))) - - (setq foo (make-instance 'class-for-testing-redefined-class)) - - (make-instances-obsolete 'class-for-testing-redefined-class) - - (do-test "update-instance-for-redefined-class/make-instances-obsolete(4)" - () - (unless (and (eq (test-x foo) 'x) - (eq (test-y foo) 'y)) - (do-test-error nil "call make-instances-obsolete by hand failed")))) - -(do-test "slot-mumble functions" - ((:variables foo1 bar1) - (:classes foo bar)) - - (defclass foo-sm () - ((x :initform 'x :allocation :class) - (y :initform 'y) - (z :allocation :class) - (u))) - - (defclass bar-sm () - ((x :initform 'x :allocation :class) - (y :initform 'y) - (z :allocation :class) - (u)) - (:metaclass funcallable-standard-class)) - - (defmethod slot-missing ((class standard-class) - (instance foo-sm) - slot-name operation &optional new-value) - (list* class instance slot-name operation new-value)) - - (defmethod slot-missing ((class standard-class) - (instance bar-sm) - slot-name operation &optional new-value) - (list* class instance slot-name operation new-value)) - - (defmethod slot-unbound ((class standard-class) - (instance foo-sm) - slot-name) - (list class instance slot-name)) - - (defmethod slot-unbound ((class funcallable-standard-class) - (instance bar-sm) - slot-name) - (list class instance slot-name)) - - (setq foo1 (make-instance 'foo-sm)) - (setq bar1 (make-instance 'bar-sm)) - - (flet ((test1 (instance) - (and (eq (slot-value instance 'x) 'x) - (eq (slot-value instance 'y) 'y) - (equal (slot-value instance 'z) - (list (class-of instance) instance 'z)) - (equal (slot-value instance 'u) - (list (class-of instance) instance 'u)) - (slot-boundp instance 'x) - (slot-boundp instance 'y) - (not (slot-boundp instance 'z)) - (not (slot-boundp instance 'u)))) - (test2 (instance) - (and (not (slot-boundp instance 'x)) - (not (slot-boundp instance 'y)) - (slot-boundp instance 'z) - (slot-boundp instance 'u) - (equal (slot-value instance 'x) - (list (class-of instance) instance 'x)) - (equal (slot-value instance 'y) - (list (class-of instance) instance 'y)) - (eq (slot-value instance 'z) 'z) - (eq (slot-value instance 'u) 'u))) - (test3 (instance) - (and (slot-exists-p instance 'x) - (slot-exists-p instance 'y))) - (test4 (instance) - (and (equal (slot-value instance 'a) - (list (class-of instance) - instance - 'a - 'slot-value)) - (equal (setf (slot-value instance 'a) 'b) - (list* (class-of instance) - instance - 'a - 'setf - 'b)) - (equal (slot-boundp instance 'a) - (list (class-of instance) - instance - 'a - 'slot-boundp)) - - (equal (slot-makunbound instance 'a) - (list (class-of instance) - instance - 'a - 'slot-makunbound))))) - - (unless (and (test1 foo1) - (test1 bar1)) - (do-test-error nil "slot functions test1 failed")) - - (slot-makunbound foo1 'x) - (slot-makunbound foo1 'y) - (setf (slot-value foo1 'z) 'z) - (setf (slot-value foo1 'u) 'u) - (slot-makunbound bar1 'x) - (slot-makunbound bar1 'y) - (setf (slot-value bar1 'z) 'z) - (setf (slot-value bar1 'u) 'u) - - (unless (and (test2 foo1) - (test2 bar1)) - (do-test-error nil "slot functions test2 failed")) - - (unless (and (test3 foo1) - (test3 bar1)) - (do-test-error nil "slot functions test3 failed")) - - (unless (and (test4 foo1) - (test4 bar1)) - (do-test-error nil "slot function test4 failed")) - )) - - -(cleanup-do-test '((:classes foo-sm bar-sm) - (:functions foo-x foo-y bar-x bar-y))) - -(defclass foo () - ((x :initform 'x :allocation :class :reader foo-x) - (y :initform 'y :reader foo-y))) - -(defclass bar () - ((x :allocation :class :reader bar-x) - (y :reader bar-y))) - -(do-test "slot-value/slot-unbound for pv optimization case and :reader method" - ((:functions get-foo-x get-foo-y get-x-1 get-y-1 - get-bar-x get-bar-y get-x-2 get-y-2) - (:variables foo1 bar1)) - - (defmethod get-foo-x ((foo1 foo)) - (slot-value foo1 'x)) - (defmethod get-foo-y ((foo1 foo)) - (slot-value foo1 'y)) - - (defun get-x-1 (foo1) - (slot-value foo1 'x)) - (defun get-y-1 (foo1) - (slot-value foo1 'y)) - - (defmethod slot-unbound ((class standard-class) (instance foo) slot-name) - (list class instance slot-name)) - - (setq foo1 (make-instance 'foo)) - - (unless (and (eq (get-foo-x foo1) 'x) - (eq (get-foo-y foo1) 'y) - (eq (get-x-1 foo1) 'x) - (eq (get-y-1 foo1) 'y) - (eq (foo-x foo1) 'x) - (eq (foo-y foo1) 'y)) - (do-test-error nil "slot-value failed")) - - (unless (and (eq (slot-makunbound foo1 'x) foo1) - (eq (slot-makunbound foo1 'y) foo1)) - (do-test-error nil "slot-makunbound returns wrong value")) - - (unless (and (equal (get-foo-x foo1) - (list (find-class 'foo) foo1 'x)) - (equal (get-foo-y foo1) - (list (find-class 'foo) foo1 'y)) - (equal (get-x-1 foo1) - (list (find-class 'foo) foo1 'x)) - (equal (get-y-1 foo1) - (list (find-class 'foo) foo1 'y)) - (equal (foo-x foo1) - (list (find-class 'foo) foo1 'x)) - (equal (foo-y foo1) - (list (find-class 'foo) foo1 'y))) - (do-test-error nil "slot-value/slot-unbound failed")) - - (defmethod get-bar-x ((bar1 bar)) - (slot-value bar1 'x)) - (defmethod get-bar-y ((bar1 bar)) - (slot-value bar1 'y)) - - (defun get-x-2 (bar1) - (slot-value bar1 'x)) - (defun get-y-2 (bar1) - (slot-value bar1 'y)) - - (defmethod slot-unbound ((class standard-class) (instance bar) slot-name) - (list class instance slot-name)) - - (setq bar1 (make-instance 'bar)) - - (unless (and (equal (get-bar-x bar1) - (list (find-class 'bar) bar1 'x)) - (equal (get-bar-y bar1) - (list (find-class 'bar) bar1 'y)) - (equal (get-x-2 bar1) - (list (find-class 'bar) bar1 'x)) - (equal (get-y-2 bar1) - (list (find-class 'bar) bar1 'y)) - (equal (bar-x bar1) - (list (find-class 'bar) bar1 'x)) - (equal (bar-y bar1) - (list (find-class 'bar) bar1 'y))) - (do-test-error nil "slot-value/slot-unbound failed"))) - - -(do-test "defmethod/call-next-method/&aux variable" - ((:variables foo1 bar1) - (:classes foo bar) - (:functions test1 test2 test3)) - - (defclass foo () - ((x :initform 0) - (y :initform 1))) - - (defclass bar (foo) ()) - - (defmethod test1 ((foo1 foo) &aux aux-arg) - (setq aux-arg (list foo1))) - - (defmethod test1 ((bar1 bar) &aux aux-arg) - (setq aux-arg (list (list bar1))) - (call-next-method) - aux-arg) - - (setq foo1 (make-instance 'foo)) - (setq bar1 (make-instance 'bar)) - (unless (and (equal (test1 foo1) (list foo1)) - (equal (test1 bar1) (list (list bar1)))) - (do-test-error nil "defmethod with call-next-method and &aux failed"))) - -;;; -;;; defconstructor tests -;;; -(format t - "~%Testing defconstructor [methods, default/initform, slot-filling]") - -(defun check-slots (object &rest names-and-values) - (doplist (name value) names-and-values - (unless (if (eq value :unbound) - (not (slot-boundp object name)) - (and (slot-boundp object name) - (eq (slot-value object name) value))) - (return-from check-slots nil))) - 't) - -;;; -;;; [methods, default/initform, slot-filling] -;;; methods: [nil, :after, t] -;;; default/initform: [nil, :constant, t] -;;; slot-filling: [:instance, :class] -;;; -;;; supplied: [nil, :constant, t] - - -(cleanup-do-test '((:classes foo1 foo2 foo3 foo4 - foo5 foo6 foo7 foo8 - foo9 foo10 foo11 foo12) - (:variables *a-initform* *b-initform* *c-initform* - *a-default* *b-default* *c-default* - *a-supplied* *b-supplied* *c-supplied*) - (:functions foo1-test1 foo1-test2 foo1-test3 - foo2-test1 foo2-test2 foo2-test3 - foo3-test1 foo3-test2 foo3-test3 - foo4-test1 foo4-test2 foo4-test3 - foo5-test1 foo5-test2 foo5-test3 - foo6-test1 foo6-test2 foo6-test3 - foo7-test1 foo7-test2 foo7-test3 - foo8-test1 foo8-test2 foo8-test3 - foo9-test1 foo9-test2 foo9-test3 - foo10-test1 foo10-test2 foo10-test3 - foo11-test1 foo11-test2 foo11-test3 - foo12-test1 foo12-test2 foo12-test3))) - -(defvar *a-initform* 'a-initform) -(defvar *b-initform* 'b-initform) -(defvar *c-initform* 'c-initform) -(defvar *a-default* 'a-default) -(defvar *b-default* 'b-default) -(defvar *c-default* 'c-default) -(defvar *a-supplied* 'a-supplied) -(defvar *b-supplied* 'b-supplied) -(defvar *c-supplied* 'c-supplied) - -;;; -;;; foo1 -;;; [methods, default/initform, slot-filing] -;;; (t, t, :class) - -(defclass foo1 () - ((a :initarg :a :initform *a-initform*) - (b :initarg :b :initform *b-initform*) - (c :initarg :c :allocation :class :initform *c-initform*)) - (:default-initargs :b *b-default* :c *c-default*)) - -(defmethod *initialize-instance :before ((instance foo1) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, t, :class) (1)" - ((:functions foo1-test1 foo1-test2 foo1-test3)) - - (defconstructor foo1-test1 foo1 ()) - (defconstructor foo1-test2 foo1 () :a 1 :b 2 :c 3) - (defconstructor foo1-test3 foo1 (a b c) :a a :b b :c c) - - (dotimes (i 2) ;Do it twice to be sure that - ;the constructor works more - ;than just the first time. - (unless (check-slots (foo1-test1) - 'a *a-initform* - 'b *b-default* - 'c *c-default*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo1-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo1-test3 *a-supplied* *b-supplied* *c-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-supplied*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) -;;; -;;; foo2 -;;; [methods, default/initform, slot-filling] -;;; (t, t, :class) - -(defclass foo2 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class :initform *c-initform* :initarg :c)) - (:default-initargs :b *b-default*)) - -(defmethod *initialize-instance :before ((instance foo2) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, t, :class) (2)" - ((:functions foo2-test1 foo2-test2 foo2-test3)) - - (defconstructor foo2-test1 foo2 ()) - (defconstructor foo2-test2 foo2 () :a 1 :b 2 :c 3) - (defconstructor foo2-test3 foo2 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (foo2-test1) 'a *a-initform* - 'b *b-default* - 'c *c-initform*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo2-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo2-test3 *a-supplied* *b-supplied* *c-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-supplied*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo3 -;;; [methods, default/initform, slot-filling] -;;; (t, t, :instance) - -(defclass foo3 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class :initform *c-initform*)) - (:default-initargs :b *b-default*)) - -(defmethod *initialize-instance :before ((instance foo3) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, t, :instance) (1)" - ((:functions foo3-test1 foo3-test2 foo3-test3)) - - (defconstructor foo3-test1 foo3 ()) - (defconstructor foo3-test2 foo3 () :a 1 :b 2) - (defconstructor foo3-test3 foo3 (a b) :a a :b b) - - - (dotimes (i 2) - (unless (check-slots (foo3-test1) 'a *a-initform* - 'b *b-default* - 'c *c-initform*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo3-test2) 'a '1 'b '2 'c *c-initform*) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo3-test3 *a-supplied* *b-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-initform*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo4 -;;; [methods, default/initform, slot-filling] -;;; (t, t, :instance) - -(defclass foo4 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class)) - (:default-initargs :b *b-default*)) - -(defmethod *initialize-instance :before ((instance foo4) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, t, :instance) (2)" - ((:functions foo4-test1 foo4-test2 foo4-test3)) - - (defconstructor foo4-test1 foo4 ()) - (defconstructor foo4-test2 foo4 () :a 1 :b 2) - (defconstructor foo4-test3 foo4 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (foo4-test1) 'a *a-initform* - 'b *b-default* - 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo4-test2) 'a '1 'b '2 'c :unbound) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo4-test3 *a-supplied* *b-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c :unbound) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo5 -;;; [methods, default/initform, slot-filling] -;;; (:after, t, :class) - -(defclass foo5 () - ((a :initarg :a :initform *a-initform*) - (b :initarg :b :initform *b-initform*) - (c :initarg :c :allocation :class :initform *c-initform*)) - (:default-initargs :b *b-default* :c *c-default*)) - -(defmethod *initialize-instance :after ((instance foo5) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, t, :class) (1)" - ((:functions foo5-test1 foo5-test2 foo5-test3)) - - (defconstructor foo5-test1 foo5 ()) - (defconstructor foo5-test2 foo5 () :a 1 :b 2 :c 3) - (defconstructor foo5-test3 foo5 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (foo5-test1) 'a *a-initform* - 'b *b-default* - 'c *c-default*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo5-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo5-test3 *a-supplied* *b-supplied* *c-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-supplied*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo6 -;;; [methods, default/initform, slot-filling] -;;; (:after, t, :class) - -(defclass foo6 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class :initform *c-initform* :initarg :c)) - (:default-initargs :b *b-default*)) - -(defmethod *initialize-instance :after ((instance foo6) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, t, :class) (2)" - ((:functions foo6-test1 foo6-test2 foo6-test3)) - - (defconstructor foo6-test1 foo6 ()) - (defconstructor foo6-test2 foo6 () :a 1 :b 2 :c 3) - (defconstructor foo6-test3 foo6 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (foo6-test1) 'a *a-initform* - 'b *b-default* - 'c *c-initform*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo6-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo6-test3 *a-supplied* *b-supplied* *c-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-supplied*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo7 -;;; [methods, default/initform, slot-filling] -;;; (:after, t, :instance) - -(defclass foo7 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class :initform *c-initform*)) - (:default-initargs :b *b-default*)) - -(defmethod *initialize-instance :after ((instance foo7) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, t, :instance) (1)" - ((:functions foo7-test1 foo7-test2 foo7-test3)) - - (defconstructor foo7-test1 foo7 ()) - (defconstructor foo7-test2 foo7 () :a 1 :b 2) - (defconstructor foo7-test3 foo7 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (foo7-test1) 'a *a-initform* - 'b *b-default* - 'c *c-initform*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo7-test2) 'a '1 'b '2 'c *c-initform*) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo7-test3 *a-supplied* *b-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-initform*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo8 -;;; [methods, default/initform, slot-filling] -;;; (:after, t, :instance) - -(defclass foo8 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class)) - (:default-initargs :b *b-default*)) - -(defmethod *initialize-instance :after ((instance foo8) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, t, :instance) (2)" - ((:functions foo8-test1 foo8-test2 foo8-test3)) - - (defconstructor foo8-test1 foo8 ()) - (defconstructor foo8-test2 foo8 () :a 1 :b 2) - (defconstructor foo8-test3 foo8 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (foo8-test1) 'a *a-initform* - 'b *b-default* - 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo8-test2) 'a '1 'b '2 'c :unbound) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo8-test3 *a-supplied* *b-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c :unbound) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo9 -;;; [methods, default/initform, slot-filling] -;;; (nil, t, :class) - -(defclass foo9 () - ((a :initarg :a :initform *a-initform*) - (b :initarg :b :initform *b-initform*) - (c :initarg :c :allocation :class :initform *c-initform*)) - (:default-initargs :b *b-default* :c *c-default*)) - -(do-test "defconstructor (nil, t, :class) (1)" - ((:functions foo9-test1 foo9-test2 foo9-test3)) - - (defconstructor foo9-test1 foo9 ()) - (defconstructor foo9-test2 foo9 () :a 1 :b 2 :c 3) - (defconstructor foo9-test3 foo9 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (foo9-test1) 'a *a-initform* - 'b *b-default* - 'c *c-default*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo9-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo9-test3 *a-supplied* *b-supplied* *c-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-supplied*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo10 -;;; [methods, default/initform, slot-filling] -;;; (nil, t, :class) - -(defclass foo10 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class :initform *c-initform* :initarg :c)) - (:default-initargs :b *b-default*)) - -(do-test "defconstructor (nil, t, :class) (2)" - ((:functions foo10-test1 foo10-test2 foo10-test3)) - - (defconstructor foo10-test1 foo10 ()) - (defconstructor foo10-test2 foo10 () :a 1 :b 2 :c 3) - (defconstructor foo10-test3 foo10 (a b c) :a a - :b b - :c c) - (dotimes (i 2) - (unless (check-slots (foo10-test1) 'a *a-initform* - 'b *b-default* - 'c *c-initform*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo10-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo10-test3 *a-supplied* *b-supplied* *c-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-supplied*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo11 -;;; [methods, default/initform, slot-filling] -;;; (nil, t, :instance) - -(defclass foo11 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class :initform *c-initform*)) - (:default-initargs :b *b-default*)) - -(do-test "defconstructor (nil, t, :instance) (1)" - ((:functions foo11-test1 foo11-test2 foo11-test3)) - - (defconstructor foo11-test1 foo11 ()) - (defconstructor foo11-test2 foo11 () :a 1 :b 2) - (defconstructor foo11-test3 foo11 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (foo11-test1) 'a *a-initform* - 'b *b-default* - 'c *c-initform*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo11-test2) 'a '1 'b '2 'c *c-initform*) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo11-test3 *a-supplied* *b-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c *c-initform*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; foo12 -;;; [methods, default/initform, slot-filling] -;;; (nil, t, :instance) - -(defclass foo12 () - ((a :initform *a-initform* :initarg :a) - (b :initform *b-initform* :initarg :b) - (c :allocation :class)) - (:default-initargs :b *b-default*)) - -(defmethod *initialize-instance :after ((instance foo12) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (nil, t, :instance) (2)" - ((:functions foo12-test1 foo12-test2 foo12-test3)) - - (defconstructor foo12-test1 foo12 ()) - (defconstructor foo12-test2 foo12 () :a 1 :b 2) - (defconstructor foo12-test3 foo12 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (foo12-test1) 'a *a-initform* - 'b *b-default* - 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo12-test2) 'a '1 'b '2 'c :unbound) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (foo12-test3 *a-supplied* *b-supplied*) - 'a *a-supplied* - 'b *b-supplied* - 'c :unbound) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - - -(cleanup-do-test '((:classes bar1 bar2 bar3 bar4 - bar5 bar6 bar7 bar8 - bar9 bar10 bar11 bar12) - (:functions bar1-test1 bar1-test2 bar1-test3 - bar2-test1 bar2-test2 bar2-test3 - bar3-test1 bar3-test2 bar3-test3 - bar4-test1 bar4-test2 bar4-test3 - bar5-test1 bar5-test2 bar5-test3 - bar6-test1 bar6-test2 bar6-test3 - bar7-test1 bar7-test2 bar7-test3 - bar8-test1 bar8-test2 bar8-test3 - bar9-test1 bar9-test2 bar9-test3 - bar10-test1 bar10-test2 bar10-test3 - bar11-test1 bar11-test2 bar11-test3 - bar12-test1 bar12-test2 bar12-test3))) - -;;; -;;; bar1 -;;; [methods, default/initform, slot-filling] -;;; (t, :constant, :class) - -(defclass bar1 () - ((a :initarg :a :initform 1) - (b :initarg :b :initform 2) - (c :initarg :c :allocation :class :initform 3)) - (:default-initargs :b 5 :c 6)) - -(defmethod *initialize-instance :before ((instance bar1) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, :constant, :class) (1)" - ((:functions bar1-test1 bar1-test2 bar1-test3)) - - (defconstructor bar1-test1 bar1 ()) - (defconstructor bar1-test2 bar1 () :a 1 :b 2 :c 3) - (defconstructor bar1-test3 bar1 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (bar1-test1) 'a '1 'b '5 'c '6) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar1-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar1-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar2 -;;; [methods, default/initform, slot-filling] -;;; (t, :constant, :class) - -(defclass bar2 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class :initform 3 :initarg :c)) - (:default-initargs :b 5)) - -(defmethod *initialize-instance :before ((instance bar2) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, :constant, :class) (2)" - ((:functions bar2-test1 bar2-test2 bar2-test3)) - - (defconstructor bar2-test1 bar2 ()) - (defconstructor bar2-test2 bar2 () :a 1 :b 2 :c 3) - (defconstructor bar2-test3 bar2 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (bar2-test1) 'a '1 'b '5 'c '3) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar2-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar2-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar3 -;;; [methods, default/initform, slot-filling] -;;; (t, :constant, :instance) - -(defclass bar3 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class :initform 3)) - (:default-initargs :b 5)) - -(defmethod *initialize-instance :before ((instance bar3) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, :constant, :instance) (1)" - ((:functions bar3-test1 bar3-test2 bar3-test3)) - - (defconstructor bar3-test1 bar3 ()) - (defconstructor bar3-test2 bar3 () :a 1 :b 2) - (defconstructor bar3-test3 bar3 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (bar3-test1) 'a '1 'b '5 'c '3) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar3-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar3-test3 7 8) 'a '7 'b '8 'c '3) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar4 -;;; [methods, default/initform, slot-filling] -;;; (t, :constant, :instance) - -(defclass bar4 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class)) - (:default-initargs :b 5)) - -(defmethod *initialize-instance :before ((instance bar4) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, :constant, :instance) (2)" - ((:functions bar4-test1 bar4-test2 bar4-test3)) - - (defconstructor bar4-test1 bar4 ()) - (defconstructor bar4-test2 bar4 () :a 1 :b 2) - (defconstructor bar4-test3 bar4 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (bar4-test1) 'a '1 'b '5 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar4-test2) 'a '1 'b '2 'c :unbound) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar4-test3 7 8) 'a '7 'b '8 'c :unbound) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar5 -;;; [methods, default/initform, slot-filling] -;;; (:after, :constant, :class) - -(defclass bar5 () - ((a :initarg :a :initform 1) - (b :initarg :b :initform 2) - (c :initarg :c :allocation :class :initform 3)) - (:default-initargs :b 5 :c 6)) - -(defmethod *initialize-instance :after ((instance bar5) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, :constant, :class) (1)" - ((:functions bar5-test1 bar5-test2 bar5-test3)) - - (defconstructor bar5-test1 bar5 ()) - (defconstructor bar5-test2 bar5 () :a 1 :b 2 :c 3) - (defconstructor bar5-test3 bar5 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (bar5-test1) 'a '1 'b '5 'c '6) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar5-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar5-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar6 -;;; [methods, default/initform, slot-filling] -;;; (:after, :constant, :class) - -(defclass bar6 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class :initform 3 :initarg :c)) - (:default-initargs :b 5)) - -(defmethod *initialize-instance :after ((instance bar6) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, :constant, :class) (2)" - ((:functions bar6-test1 bar6-test2 bar6-test3)) - - (defconstructor bar6-test1 bar6 ()) - (defconstructor bar6-test2 bar6 () :a 1 :b 2 :c 3) - (defconstructor bar6-test3 bar6 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (bar6-test1) 'a '1 'b '5 'c '3) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar6-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar6-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar7 -;;; [methods, default/initform, slot-filling] -;;; (:after, :constant, :instance) - -(defclass bar7 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class :initform 3)) - (:default-initargs :b 5)) - -(defmethod *initialize-instance :after ((instance bar7) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, :constant, :instance) (1)" - ((:functions bar7-test1 bar7-test2 bar7-test3)) - - (defconstructor bar7-test1 bar7 ()) - (defconstructor bar7-test2 bar7 () :a 1 :b 2) - (defconstructor bar7-test3 bar7 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (bar7-test1) 'a '1 'b '5 'c '3) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar7-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar7-test3 7 8) 'a '7 'b '8 'c '3) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar8 -;;; [methods, default/initform, slot-filling] -;;; (:after, :constant, :instance) - -(defclass bar8 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class)) - (:default-initargs :b 5)) - -(defmethod *initialize-instance :after ((instance bar8) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, :constant, :instance) (2)" - ((:functions bar8-test1 bar8-test2 bar8-test3)) - - (defconstructor bar8-test1 bar8 ()) - (defconstructor bar8-test2 bar8 () :a 1 :b 2) - (defconstructor bar8-test3 bar8 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (bar8-test1) 'a '1 'b '5 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar8-test2) 'a '1 'b '2 'c :unbound) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar8-test3 7 8) 'a '7 'b '8 'c :unbound) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar9 -;;; [methods, default/initform, slot-filling] -;;; (nil, :constant, :class) - -(defclass bar9 () - ((a :initarg :a :initform 1) - (b :initarg :b :initform 2) - (c :initarg :c :allocation :class :initform 3)) - (:default-initargs :b 5 :c 6)) - -(do-test "defconstructor (nil, :constant, :class) (1)" - ((:functions bar9-test1 bar9-test2 bar9-test3)) - - (defconstructor bar9-test1 bar9 ()) - (defconstructor bar9-test2 bar9 () :a 1 :b 2 :c 3) - (defconstructor bar9-test3 bar9 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (bar9-test1) 'a '1 'b '5 'c '6) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar9-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar9-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar10 -;;; [methods, default/initform, slot-filling] -;;; (nil, :constant, :class) - -(defclass bar10 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class :initform 3 :initarg :c)) - (:default-initargs :b 5)) - -(do-test "defconstructor (nil, :constant, :class) (2)" - ((:functions bar10-test1 bar10-test2 bar10-test3)) - - (defconstructor bar10-test1 bar10 ()) - (defconstructor bar10-test2 bar10 () :a 1 :b 2 :c 3) - (defconstructor bar10-test3 bar10 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (bar10-test1) 'a '1 'b '5 'c '3) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar10-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar10-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar11 -;;; [methods, default/initform, slot-filling] -;;; (nil, :constant, :instance) - -(defclass bar11 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class :initform 3)) - (:default-initargs :b 5)) - -(do-test "defconstructor (nil, :constant, :instance) (1)" - ((:functions bar11-test1 bar11-test2 bar11-test3)) - - (defconstructor bar11-test1 bar11 ()) - (defconstructor bar11-test2 bar11 () :a 1 :b 2) - (defconstructor bar11-test3 bar11 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (bar11-test1) 'a '1 'b '5 'c '3) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar11-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar11-test3 7 8) 'a '7 'b '8 'c '3) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; bar12 -;;; [methods, default/initform, slot-filling] -;;; (nil, :constant, :instance) - -(defclass bar12 () - ((a :initform 1 :initarg :a) - (b :initform 2 :initarg :b) - (c :allocation :class)) - (:default-initargs :b 5)) - -(defmethod *initialize-instance :after ((instance bar12) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (nil, :constant, :instance) (2)" - ((:functions bar12-test1 bar12-test2 bar12-test3)) - - (defconstructor bar12-test1 bar12 ()) - (defconstructor bar12-test2 bar12 () :a 1 :b 2) - (defconstructor bar12-test3 bar12 (a b) :a a :b b) - - (dotimes (i 2) - (unless (check-slots (bar12-test1) 'a '1 'b '5 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar12-test2) 'a '1 'b '2 'c :unbound) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (bar12-test3 7 8) 'a '7 'b '8 'c :unbound) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - - -(cleanup-do-test '((:classes baz1 baz2 baz3) - (:functions baz1-test1 baz1-test2 baz1-test3 - baz2-test1 baz2-test2 baz2-test3 - baz3-test1 baz3-test2 baz3-test3))) - -;;; -;;; baz1 -;;; [methods, default/initform, slot-filling] -;;; (t, nil, :class) - -(defclass baz1 () - ((a :initarg :a) - (b :initarg :b) - (c :initarg :c :allocation :class))) - -(defmethod *initialize-instance :before ((instance baz1) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (t, nil, :class) (1)" - ((:functions baz1-test1 baz1-test2 baz1-test3)) - - (defconstructor baz1-test1 baz1 ()) - (defconstructor baz1-test2 baz1 () :a 1 :b 2 :c 3) - (defconstructor baz1-test3 baz1 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (baz1-test1) 'a :unbound 'b :unbound 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (baz1-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (baz1-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; baz2 -;;; [methods, default/initform, slot-filling] -;;; (:after, nil, :class) - -(defclass baz2 () - ((a :initarg :a) - (b :initarg :b) - (c :initarg :c :allocation :class))) - -(defmethod *initialize-instance :after ((instance baz2) &rest ignore) - (declare (ignore ignore)) - ()) - -(do-test "defconstructor (:after, nil, :class) (1)" - ((:functions baz2-test1 baz2-test2 baz2-test3)) - - (defconstructor baz2-test1 baz2 ()) - (defconstructor baz2-test2 baz2 () :a 1 :b 2 :c 3) - (defconstructor baz2-test3 baz2 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (baz2-test1) 'a :unbound 'b :unbound 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (baz2-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (baz2-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - -;;; -;;; baz3 -;;; [methods, default/initform, slot-filling] -;;; (nil, nil, :class) - -(defclass baz3 () - ((a :initarg :a) - (b :initarg :b) - (c :initarg :c :allocation :class))) - -(do-test "defconstructor (nil, nil, :class) (1)" - ((:functions baz3-test1 baz3-test2 baz3-test3)) - - (defconstructor baz3-test1 baz3 ()) - (defconstructor baz3-test2 baz3 () :a 1 :b 2 :c 3) - (defconstructor baz3-test3 baz3 (a b c) :a a - :b b - :c c) - - (dotimes (i 2) - (unless (check-slots (baz3-test1) 'a :unbound 'b :unbound 'c :unbound) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (baz3-test2) 'a '1 'b '2 'c '3) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (baz3-test3 7 8 9) 'a '7 'b '8 'c '9) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - - -(cleanup-do-test '((:classes foo bar) - (:functions make-bar-1 make-bar-2 make-bar-3))) - -(setq *foo-a* 'foo-a - *foo-b* 'foo-b - *foo-c* 'foo-c - *bar-a* 'bar-a - *bar-b* 'bar-b - *bar-c* 'bar-c - *supplied-a* 'a - *supplied-b* 'b - *supplied-c* 'c) - -(defclass foo () - ((a :initarg :a) - (b :initarg :b) - (c :initarg :c)) - (:default-initargs :a *foo-a* :b *foo-b* :c *foo-c*)) - -(defclass bar (foo) - ((c :initarg :a)) - (:default-initargs :a *bar-a* :c *bar-c*)) - -(defconstructor make-bar-1 bar ()) -(defconstructor make-bar-2 bar () :a 1 :b 2 :c 3) -(defconstructor make-bar-3 bar (a b c) :a a :b b :c c) - -(do-test "defconstructor/shadowing" - () - - (dotimes (i 2) - (unless (check-slots (make-bar-1) 'a *bar-a* 'b *foo-b* 'c *bar-a*) - (do-test-error nil "no initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (make-bar-2) 'a '1 'b '2 'c '1) - (do-test-error nil "constant initargs failed (~D time)" i))) - - (dotimes (i 2) - (unless (check-slots (make-bar-3 *supplied-a* *supplied-b* *supplied-c*) - 'a *supplied-a* 'b *supplied-b* 'c *supplied-a*) - (do-test-error nil "non constant initargs failed (~D time)" i)))) - - -(do-test "defconstructor/only needed forms should be evaluated" - ((:classes foo) - (:functions make-foo-1 make-foo-2)) - - (defclass foo () - ((x :initform (do-test-error nil "foo x initform was evaluated") - :initarg :x) - (y :initform (do-test-error nil "foo y initform was evaluated") - :initarg :y) - (z :initform (do-test-error nil "foo z initform was evaluated") - :initarg :z)) - (:default-initargs :y 2 - :z (do-test-error - nil - "z default was evaluated"))) - - (defconstructor make-foo-1 foo () :x 1 :z 3) - (defconstructor make-foo-2 foo (x z) :x x :z z) - - (make-foo-1) - (make-foo-1) - (make-foo-2 'x 'z) - (make-foo-2 'x 'z)) - -(do-test "defconstructor/shadowing/only needed forms should be evaluated" - ((:classes foo bar) - (:functions make-bar-4 make-bar-5)) - - (defclass foo () - ((x :initform (do-test-error nil "foo x initform was evaluated") - :initarg :x) - (y :initform (do-test-error nil "foo y initform was evaluated") - :initarg :y) - (z :initform (do-test-error nil "foo z initform was evaluated") - :initarg :z)) - (:default-initargs :x (do-test-error - nil - "foo z default was evaluated") - :y (do-test-error - nil - "foo y default was evaluated") - :z (do-test-error - nil - "foo z default was evaluated"))) - (defclass bar (foo) - ((x :initform (do-test-error nil "bar x initform was evaluated")) - (y :initform (do-test-error nil "bar y initform was evaluated")) - (z :initform (do-test-error nil "bar z initform was evaluated"))) - (:default-initargs :y 2 - :z (do-test-error - nil - "bar z default was evaluated"))) - - (defconstructor make-bar-4 bar () :x 1 :z 3) - (defconstructor make-bar-5 bar (x z) :x x :z z) - - (make-bar-4) - (make-bar-4) - (make-bar-5 'x 'z) - (make-bar-5 'x 'z)) - -;;; -;;; 11/1 test to make sure reader/writer call slot-value-using-class -;;; -;;; ********************************************************************** -;;; This test codes will have to change in each of the next releases -;;; ********************************************************************** -;;; -(cleanup-do-test '((:classes test-deoptimized-slot-access-class - test-deoptimized-slot-access) - (:functions test-a test-b test-c) - (:setf-generic-functions test-a test-b))) - -(defclass test-deoptimized-slot-access-class (standard-class) ()) - -(defmethod check-super-metaclass-compatibility - ((x test-deoptimized-slot-access-class) (y standard-class)) - 't) - -(defmethod all-std-class-reader-miss-1 - ((class test-deoptimized-slot-access-class) wrapper slot-name) - (declare (ignore wrapper slot-name)) - ()) - -(defmethod lookup-pv-miss-1 - ((class test-deoptimized-slot-access-class) slots pv) - (let ((pv (call-next-method))) - (make-list (length pv) :initial-element nil))) - - -(defclass test-deoptimized-slot-access () - ((a :initform 'a :accessor test-a) - (b :initform 'b :accessor test-b)) - (:metaclass test-deoptimized-slot-access-class)) - -(defmethod test-c ((o test-deoptimized-slot-access)) - (list (slot-value o 'a) (slot-value o 'b))) - -(let ((called-p 'nil) - instance) - (defmethod slot-value-using-class ((class test-deoptimized-slot-access-class) - object - slot-name) - (setq called-p 'read) - (call-next-method)) - - (defmethod (setf slot-value-using-class) - (nv (class test-deoptimized-slot-access-class) object slot-name) - (setq called-p 'written) - (call-next-method)) - - (setq instance (make-instance 'test-deoptimized-slot-access)) - - (do-test "deoptimized slot access should call slot-value-using-class" - () - (unless (and (eq (test-a instance) 'a) - (eq called-p 'read)) - (do-test-error nil "reader doesn't call slot-value-using-class")) - - (setq called-p 'nil) - (setf (test-b instance) 'c) - (unless (eq called-p 'written) - (do-test-error nil "writer doesn't call slot-value-using-class")) - - (setq called-p 'nil) - (unless (and (equal (test-c instance) '(a c)) - (eq called-p 'read)) - (do-test-error nil "slot-value doesn't call slot-value-using-class")))) - -;;; -;;; 5/3/89 eql specializers tests -;;; - -(cleanup-do-test '((:classes foo bar))) -(defclass foo () ()) -(defclass bar (foo) ()) - -(do-test "eql specializers(eql and other methods/symbol only)" - ((:functions test) - (:variables i)) - - (defmethod test ((self foo) x) 'foo) - (defmethod test ((self bar) (x (eql 'a))) 'a) - (defmethod test ((self bar) (x (eql 'b))) 'b) - (setq i (make-instance 'bar)) - - (unless (eq (test i 'a) 'a) - (do-test-error () "for (bar (eql a)) wrong method was called")) - (unless (eq (test i 'b) 'b) - (do-test-error () "for (bar (eql b)) wrong method was called")) - (unless (eq (test i 'c) 'foo) - (do-test-error () "for (bar (eql c)) wrong method was called")) - ) - -(do-test "eql specializers(only eql methods/symbol only)" - ((:functions test2) - (:variables i)) - - (defmethod test2 ((self bar) (x (eql 'a))) 'a) - (defmethod test2 ((self bar) (x (eql 'b))) 'b) - (setq i (make-instance 'bar)) - - (unless (eq (test2 i 'a) 'a) - (do-test-error () "for (bar (eql a)) wrong method was called")) - (unless (eq (test2 i 'b) 'b) - (do-test-error () "for (bar (eql b)) wrong method was called")) - ) - -(do-test "eql specializers(only eql methods/symbol and integer)" - ((:functions test3)) - - (defmethod test3 ((x (eql 'a)) (y (eql '1))) 'a-1) - (defmethod test3 ((x (eql 'b)) (y (eql '1))) 'b-1) - (defmethod test3 ((x (eql 'c)) (y (eql '1))) 'c-1) - (defmethod test3 ((x (eql 'a)) (y (eql '2))) 'a-2) - (defmethod test3 ((x (eql 'b)) (y (eql '2))) 'b-2) - (defmethod test3 ((x (eql 'c)) (y (eql '2))) 'c-2) - (defmethod test3 ((x (eql 'a)) (y (eql '3))) 'a-3) - (defmethod test3 ((x (eql 'b)) (y (eql '3))) 'b-3) - (defmethod test3 ((x (eql 'c)) (y (eql '3))) 'c-3) - - (unless (eq (test3 'a '1) 'a-1) - (do-test-error () "for (a 1) wrong method was called")) - (unless (eq (test3 'a '2) 'a-2) - (do-test-error () "for (a 2) wrong method was called")) - (unless (eq (test3 'a '3) 'a-3) - (do-test-error () "for (a 3) wrong method was called")) - (unless (eq (test3 'b '1) 'b-1) - (do-test-error () "for (b 1) wrong method was called")) - (unless (eq (test3 'b '2) 'b-2) - (do-test-error () "for (b 2) wrong method was called")) - (unless (eq (test3 'b '3) 'b-3) - (do-test-error () "for (b 3) wrong method was called")) - (unless (eq (test3 'c '1) 'c-1) - (do-test-error () "for (c 1) wrong method was called")) - (unless (eq (test3 'c '2) 'c-2) - (do-test-error () "for (c 2) wrong method was called")) - (unless (eq (test3 'c '3) 'c-3) - (do-test-error () "for (c 3) wrong method was called")) - - ) - -(do-test "eql specializers(eql and other methods/symbol and integer)" - ((:functions test4)) - - (defmethod test4 ((x (eql 'a)) (y (eql '1))) 'a-1) - (defmethod test4 ((x (eql 'b)) (y (eql '1))) 'b-1) - (defmethod test4 ((x (eql 'c)) (y (eql '2))) 'c-2) - (defmethod test4 ((x (eql 'b)) (y (eql '3))) 'b-3) - (defmethod test4 (x y) 'other) - - (unless (eq (test4 'a '1) 'a-1) - (do-test-error () "for (a 1) wrong method was called")) - (unless (eq (test4 'a '2) 'other) - (do-test-error () "for (a 2) wrong method was called")) - (unless (eq (test4 'a '3) 'other) - (do-test-error () "for (a 3) wrong method was called")) - (unless (eq (test4 'b '1) 'b-1) - (do-test-error () "for (b 1) wrong method was called")) - (unless (eq (test4 'b '2) 'other) - (do-test-error () "for (b 2) wrong method was called")) - (unless (eq (test4 'b '3) 'b-3) - (do-test-error () "for (b 3) wrong method was called")) - (unless (eq (test4 'c '1) 'other) - (do-test-error () "for (c 1) wrong method was called")) - (unless (eq (test4 'c '2) 'c-2) - (do-test-error () "for (c 2) wrong method was called")) - (unless (eq (test4 'c '3) 'other) - (do-test-error () "for (c 3) wrong method was called")) - - ) - -(do-test "eql specializers(call-next-method)" - ((:functions test5)) - - (defmethod test5 (x) ()) - (defmethod test5 ((x (eql 'a))) (cons 'a (call-next-method))) - (defmethod test5 ((x (eql 'b))) (cons 'b (call-next-method))) - - (unless (equal (test5 'a) '(a)) - (do-test-error () "for (a) wrong method was called")) - (unless (equal (test5 'b) '(b)) - (do-test-error () "for (b) wrong method was called")) - (unless (eq (test5 'c) '()) - (do-test-error () "for (c) wrong method was called")) - ) - -(do-test "eql specializers(for random types)" - ((:functions test6)) - - (defmethod test6 (x) ()) - (defmethod test6 ((x symbol)) (cons 'the-class-symbol (call-next-method))) - (defmethod test6 ((x null)) (cons 'the-class-null (call-next-method))) - (defmethod test6 ((x number)) (cons 'the-class-number (call-next-method))) - (defmethod test6 ((x integer)) (cons 'the-class-integer (call-next-method))) - (defmethod test6 ((x (eql 'foo))) (cons 'foo (call-next-method))) - (defmethod test6 ((x (eql 'bar))) (cons 'bar (call-next-method))) - (defmethod test6 ((x (eql 'nil))) (cons 'nil (call-next-method))) - (defmethod test6 ((x (eql '1.7))) (cons '1.7 (call-next-method))) - (defmethod test6 ((x (eql '321))) (cons '321 (call-next-method))) - - (unless (eq (test6 '(other)) ()) - (do-test-error () "for ((other)) wrong method was called")) - (unless (equal (test6 'symbol) '(the-class-symbol)) - (do-test-error () "for (symbol) wrong method was called")) - (unless (equal (test6 '5.5) '(the-class-number)) - (do-test-error () "for (number) wrong method was called")) - (unless (equal (test6 '123) '(the-class-integer the-class-number)) - (do-test-error () "for (integer) wrong method was called")) - (unless (equal (test6 'foo) '(foo the-class-symbol)) - (do-test-error () "for ((eql foo)) wrong method was called")) - (unless (equal (test6 'bar) '(bar the-class-symbol)) - (do-test-error () "for ((eql bar)) wrong method was called")) - (unless (equal (test6 'nil) '(nil the-class-null the-class-symbol)) - (do-test-error () "for ((eql nil)) wrong method was called")) - (unless (equal (test6 '1.7) '(1.7 the-class-number)) - (do-test-error () "for ((eql 1.7)) wrong method was called")) - (unless (equal (test6 '321) '(321 the-class-integer the-class-number)) - (do-test-error () "for ((eql 321)) wrong method was called")) - ) - -;;; -;;; (5/3/89)Testing :allocation :class for funcallable-instance -;;; - -(format t "~%Testing :allocation :class test(for standard-instance)~%") - -(cleanup-do-test '((:classes foo bar) - (:variables foo1 bar1))) - -(defclass foo () - ((a :initform (list 'foo-a) :allocation :class) - (b :initform (list 'foo-b) :allocation :class) - (c :initform (list 'foo-c) :allocation :class) - (d :allocation :class) - (e :allocation :class) - (f :allocation :class))) - -(defclass bar (foo) - ((b :initform (list 'bar-b) :allocation :class) - (c :allocation :class) - (e :initform (list 'bar-e) :allocation :class) - (f :allocation :class))) - -(defmethod slot-missing ((class standard-class) - (instance foo) - slot-name operation &optional new-value) - (list* class instance slot-name operation new-value)) - -(defmethod slot-missing ((class standard-class) - (instance bar) - slot-name operation &optional new-value) - (list* class instance slot-name operation new-value)) - -(defmethod slot-unbound ((class standard-class) - (instance foo) - slot-name) - (list class instance slot-name)) - -(defmethod slot-unbound ((class standard-class) - (instance bar) - slot-name) - (list class instance slot-name)) - -(setq foo1 (make-instance 'foo) - bar1 (make-instance 'bar)) - -(do-test ":allocation :class(:initform/slot-value)" - () - (unless (and (equal (slot-value foo1 'a) '(foo-a)) - (equal (slot-value foo1 'b) '(foo-b)) - (equal (slot-value foo1 'c) '(foo-c)) - (equal (slot-value bar1 'a) '(foo-a)) - (equal (slot-value bar1 'b) '(bar-b)) - (equal (slot-value bar1 'c) '(foo-c)) - (equal (slot-value bar1 'e) '(bar-e))) - (do-test-error () ":initform/slot-value failed"))) - -(do-test ":allocation :class(shared by instances of super and sub case)" - () - (unless (eq (slot-value foo1 'a) - (slot-value bar1 'a)) - (do-test-error () ":class slot should be shared by instances"))) - -(do-test ":allocation :class(not shared by instances of super and sub case)" - () - (unless (not (eq (slot-value foo1 'c) - (slot-value bar1 'c))) - (do-test-error () ":class slot should not be shared by instances"))) - -(do-test ":allocation :class(slot-boundp)" - () - (unless (and (slot-boundp foo1 'a) - (slot-boundp foo1 'b) - (slot-boundp foo1 'c) - (not (slot-boundp foo1 'd)) - (not (slot-boundp foo1 'e)) - (not (slot-boundp foo1 'f)) - (slot-boundp bar1 'a) - (slot-boundp bar1 'b) - (slot-boundp bar1 'c) - (not (slot-boundp bar1 'd)) - (slot-boundp bar1 'e) - (not (slot-boundp bar1 'f))) - (do-test-error () "slot-boundp failed"))) - -(slot-makunbound foo1 'a) -(slot-makunbound foo1 'b) - -(do-test ":allocation :class(slot-makunbound)" - () - (unless (and (not (slot-boundp foo1 'a)) - (not (slot-boundp foo1 'b)) - (not (slot-boundp bar1 'a)) - (slot-boundp bar1 'b)) - (do-test-error () "slot-makunbound failed"))) - -(setf (slot-value foo1 'a) '(new-foo-a) - (slot-value foo1 'b) '(new-foo-b) - (slot-value foo1 'c) '(new-foo-c) - (slot-value bar1 'b) '(new-bar-b) - (slot-value bar1 'e) '(new-bar-e)) - -(do-test ":allocation :class(slot-value/(setf slot-value))" - () - (unless (and (equal (slot-value foo1 'a) '(new-foo-a)) - (equal (slot-value foo1 'b) '(new-foo-b)) - (equal (slot-value foo1 'c) '(new-foo-c)) - (equal (slot-value bar1 'a) '(new-foo-a)) - (equal (slot-value bar1 'b) '(new-bar-b)) - (equal (slot-value bar1 'e) '(new-bar-e))) - (do-test-error () "slot-value/(setf slot-value failed"))) - -(do-test ":allocation :class(slot-exists-p)" - () - (unless (and (slot-exists-p foo1 'a) - (slot-exists-p foo1 'b) - (slot-exists-p foo1 'c) - (slot-exists-p foo1 'd) - (slot-exists-p foo1 'e) - (slot-exists-p foo1 'f) - (slot-exists-p bar1 'a) - (slot-exists-p bar1 'b) - (slot-exists-p bar1 'c) - (slot-exists-p bar1 'd) - (slot-exists-p bar1 'e) - (slot-exists-p bar1 'f)) - (do-test-error () "slot-exist-p failed"))) - -(do-test ":allocation :class(slot-missing)" - () - (unless (and (equal (slot-value foo1 'x) - (list (class-of foo1) - foo1 - 'x - 'slot-value)) - (equal (setf (slot-value foo1 'x) 'dummy) - (list* (class-of foo1) - foo1 - 'x - 'setf - 'dummy)) - (equal (slot-boundp foo1 'x) - (list (class-of foo1) - foo1 - 'x - 'slot-boundp)) - - (equal (slot-makunbound foo1 'x) - (list (class-of foo1) - foo1 - 'x - 'slot-makunbound)) - (equal (slot-value bar1 'x) - (list (class-of bar1) - bar1 - 'x - 'slot-value)) - (equal (setf (slot-value bar1 'x) 'dummy) - (list* (class-of bar1) - bar1 - 'x - 'setf - 'dummy)) - (equal (slot-boundp bar1 'x) - (list (class-of bar1) - bar1 - 'x - 'slot-boundp)) - - (equal (slot-makunbound bar1 'x) - (list (class-of bar1) - bar1 - 'x - 'slot-makunbound))) - (do-test-error () "slot-missing failed"))) - -;;; -;;; (5/4/89)Testing :allocation :class for funcallable-instance -;;; - -(format t "~%Testing :allocation :class test~ - (for funcallable-standard-instance)~%") - -(cleanup-do-test '((:classes foo bar) - (:variables foo2 bar2))) - -(defclass foo () - ((a :initform (list 'foo-a) :allocation :class) - (b :initform (list 'foo-b) :allocation :class) - (c :initform (list 'foo-c) :allocation :class) - (d :allocation :class) - (e :allocation :class) - (f :allocation :class)) - (:metaclass funcallable-standard-class)) - -(defclass bar (foo) - ((b :initform (list 'bar-b) :allocation :class) - (c :allocation :class) - (e :initform (list 'bar-e) :allocation :class) - (f :allocation :class)) - (:metaclass funcallable-standard-class)) - -(defmethod slot-missing ((class standard-class) - (instance foo) - slot-name operation &optional new-value) - (list* class instance slot-name operation new-value)) - -(defmethod slot-missing ((class standard-class) - (instance bar) - slot-name operation &optional new-value) - (list* class instance slot-name operation new-value)) - -(defmethod slot-unbound ((class standard-class) - (instance foo) - slot-name) - (list class instance slot-name)) - -(defmethod slot-unbound ((class standard-class) - (instance bar) - slot-name) - (list class instance slot-name)) - -(setq foo2 (make-instance 'foo) - bar2 (make-instance 'bar)) - -(do-test ":allocation :class(:initform/slot-value)" - () - (unless (and (equal (slot-value foo2 'a) '(foo-a)) - (equal (slot-value foo2 'b) '(foo-b)) - (equal (slot-value foo2 'c) '(foo-c)) - (equal (slot-value bar2 'a) '(foo-a)) - (equal (slot-value bar2 'b) '(bar-b)) - (equal (slot-value bar2 'c) '(foo-c)) - (equal (slot-value bar2 'e) '(bar-e))) - (do-test-error () ":initform/slot-value failed"))) - -(do-test ":allocation :class(shared by instances of super and sub case)" - () - (unless (eq (slot-value foo2 'a) - (slot-value bar2 'a)) - (do-test-error () ":class slot should be shared by instances"))) - -(do-test ":allocation :class(not shared by instances of super and sub case)" - () - (unless (not (eq (slot-value foo2 'c) - (slot-value bar2 'c))) - (do-test-error () ":class slot should not be shared by instances"))) - -(do-test ":allocation :class(slot-boundp)" - () - (unless (and (slot-boundp foo2 'a) - (slot-boundp foo2 'b) - (slot-boundp foo2 'c) - (not (slot-boundp foo2 'd)) - (not (slot-boundp foo2 'e)) - (not (slot-boundp foo2 'f)) - (slot-boundp bar2 'a) - (slot-boundp bar2 'b) - (slot-boundp bar2 'c) - (not (slot-boundp bar2 'd)) - (slot-boundp bar2 'e) - (not (slot-boundp bar2 'f))) - (do-test-error () "slot-boundp failed"))) - -(slot-makunbound foo2 'a) -(slot-makunbound foo2 'b) - -(do-test ":allocation :class(slot-makunbound)" - () - (unless (and (not (slot-boundp foo2 'a)) - (not (slot-boundp foo2 'b)) - (not (slot-boundp bar2 'a)) - (slot-boundp bar2 'b)) - (do-test-error () "slot-makunbound failed"))) - -(setf (slot-value foo2 'a) '(new-foo-a) - (slot-value foo2 'b) '(new-foo-b) - (slot-value foo2 'c) '(new-foo-c) - (slot-value bar2 'b) '(new-bar-b) - (slot-value bar2 'e) '(new-bar-e)) - -(do-test ":allocation :class(slot-value/(setf slot-value))" - () - (unless (and (equal (slot-value foo2 'a) '(new-foo-a)) - (equal (slot-value foo2 'b) '(new-foo-b)) - (equal (slot-value foo2 'c) '(new-foo-c)) - (equal (slot-value bar2 'a) '(new-foo-a)) - (equal (slot-value bar2 'b) '(new-bar-b)) - (equal (slot-value bar2 'e) '(new-bar-e))) - (do-test-error () "slot-value/(setf slot-value failed"))) - -(do-test ":allocation :class(slot-exists-p)" - () - (unless (and (slot-exists-p foo2 'a) - (slot-exists-p foo2 'b) - (slot-exists-p foo2 'c) - (slot-exists-p foo2 'd) - (slot-exists-p foo2 'e) - (slot-exists-p foo2 'f) - (slot-exists-p bar2 'a) - (slot-exists-p bar2 'b) - (slot-exists-p bar2 'c) - (slot-exists-p bar2 'd) - (slot-exists-p bar2 'e) - (slot-exists-p bar2 'f)) - (do-test-error () "slot-exist-p failed"))) - -;(do-test ":allocation :class(slot-missing)" -; () -; (unless (and (equal (slot-value foo2 'x) -; (list (class-of foo2) -; foo2 -; 'x -; 'slot-value)) -; (equal (setf (slot-value foo2 'x) 'dummy) -; (list* (class-of foo2) -; foo2 -; 'x - ; 'setf -; 'dummy)) -; (equal (slot-boundp foo2 'x) -; (list (class-of foo2) -; foo2 -; 'x -; 'slot-boundp)) -; -; (equal (slot-makunbound foo2 'x) -; (list (class-of foo2) -; foo2 -; 'x -; 'slot-makunbound)) -; (equal (slot-value bar2 'x) -; (list (class-of bar2) -; bar2 -; 'x -; 'slot-value)) -; (equal (setf (slot-value bar2 'x) 'dummy) -; (list* (class-of bar2) -; bar2 -; 'x -; 'setf -; 'dummy)) -; (equal (slot-boundp bar2 'x) -; (list (class-of bar2) -; bar2 -; 'x -; 'slot-boundp)) -; -; (equal (slot-makunbound bar2 'x) -; (list (class-of bar2) -; bar2 -; 'x -; 'slot-makunbound))) -; (do-test-error () "slot-missing failed"))) - - - diff --git a/obsolete/clos/2.0/unchaged.lisp b/obsolete/clos/2.0/unchaged.lisp deleted file mode 100644 index 4116cfd3..00000000 --- a/obsolete/clos/2.0/unchaged.lisp +++ /dev/null @@ -1,22 +0,0 @@ -boot -braid -cache -combin -compat -construct -cpl -defcombin -defs -dlap -env -fixup -fngen -fsc -lap -methods -plap -precom2 -precom4 -test -vector -walk \ No newline at end of file diff --git a/obsolete/clos/2.0/vector.lisp b/obsolete/clos/2.0/vector.lisp deleted file mode 100644 index 5f613f84..00000000 --- a/obsolete/clos/2.0/vector.lisp +++ /dev/null @@ -1,368 +0,0 @@ -;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; Permutation vectors. -;;; - -(in-package 'clos) - -(defmacro instance-slot-index (wrapper slot-name) - `(let ((pos 0)) - (block loop - (dolist (sn (wrapper-instance-slots-layout ,wrapper)) - (when (eq ,slot-name sn) (return-from loop pos)) - (incf pos))))) - - -;;; -;;; -;;; -(defmacro %isl-cache (isl) `(%svref ,isl 1)) -(defmacro %isl-field (isl) `(%svref ,isl 2)) -(defmacro %isl-mask (isl) `(%svref ,isl 3)) -(defmacro %isl-size (isl) `(%svref ,isl 4)) -(defmacro %isl-slot-name-lists (isl) `(%svref ,isl 5)) - -(defun make-isl (slot-name-lists) - (multiple-value-bind (mask size) - (compute-primary-pv-cache-size slot-name-lists) - (make-isl-internal (wrapper-field 'number) - (get-cache size) - mask - size - slot-name-lists))) - -(defun make-isl-internal (field cache mask size slot-name-lists) - (let ((isl (make-array 6))) - (setf (svref isl 0) 'isl - (%isl-cache isl) cache - (%isl-field isl) field - (%isl-mask isl) mask - (%isl-size isl) size - (%isl-slot-name-lists isl) slot-name-lists) - isl)) - -(defun make-isl-type-declaration (var) - `(type simple-vector ,var)) - -(defun islp (x) - (and (simple-vector-p x) - (= (array-dimension x 0) 5) - (eq (svref x 0) 'isl))) - -(defvar *slot-name-lists-inner* (make-hash-table :test #'equal)) -(defvar *slot-name-lists-outer* (make-hash-table :test #'equal)) - -(defun intern-slot-name-lists (slot-name-lists) - (flet ((inner (x) - (or (gethash x *slot-name-lists-inner*) - (setf (gethash x *slot-name-lists-inner*) (copy-list x)))) - (outer (x) - (or (gethash x *slot-name-lists-outer*) - (setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x)))))) - (outer (mapcar #'inner slot-name-lists)))) - - - -(defvar *pvs* (make-hash-table :test #'equal)) - -(defvar default-svuc-method nil) -(defvar default-setf-svuc-method nil) - -(defun optimize-slot-value-by-class-p (class slot-name setf-p) - (or (not (eq *boot-state* 'complete)) - (let* ((slot-definition (find-slot-definition class slot-name)) - (gfun-name (if setf-p - '(setf slot-value-using-class) 'slot-value-using-class)) - (gfun (gdefinition gfun-name)) - (csym (if setf-p 'default-setf-svuc-method 'default-svuc-method)) - (app-methods nil)) - (dolist (method (generic-function-methods gfun)) - (let* ((mspecs (method-specializers method)) - (specs (if setf-p (cdr mspecs) mspecs))) - (when (and (specializer-applicable-p (first specs) class) - (specializer-applicable-using-class-p (second specs) class) - (specializer-applicable-p (third specs) slot-definition)) - (push method app-methods)))) - (and app-methods (null (cdr app-methods)) - (eq (car app-methods) - (or (symbol-value csym) - (let* ((specs (if setf-p - '(t - std-class - standard-object - standard-effective-slot-definition) - '(std-class - standard-object - standard-effective-slot-definition))) - (slist (mapcar #'find-class specs))) - (set csym (get-method gfun nil slist))))))))) - -(defun lookup-pv (isl args) - (let* ((class-slot-p nil) - (elements - (gathering1 (collecting) - (iterate ((slot-names (list-elements (%isl-slot-name-lists isl))) - (arg (list-elements args))) - (when slot-names - (let* ((wrapper (check-wrapper-validity arg)) - (class (wrapper-class wrapper)) - (class-slots (wrapper-class-slots wrapper))) - (dolist (slot-name slot-names) - (if (and (optimize-slot-value-by-class-p - class slot-name nil) - (optimize-slot-value-by-class-p - class slot-name t)) - (let ((index (instance-slot-index wrapper slot-name))) - (if index - (gather1 index) - (let ((cell (assq slot-name class-slots))) - (if cell - (progn (setq class-slot-p t) (gather1 cell)) - (gather1 nil))))) - (gather1 nil))))))))) - (if class-slot-p ;Sure is a shame Common Lisp doesn't - (make-permutation-vector elements) ;give me the right kind of hash table. - (or (gethash elements *pvs*) - (setf (gethash elements *pvs*) (make-permutation-vector elements)))))) - -(defun make-permutation-vector (indexes) - (make-array (length indexes) :initial-contents indexes)) - -(defun make-pv-type-declaration (var) - `(type simple-vector ,var)) - -(defmacro pvref (pv index) - `(svref ,pv ,index)) - - - -(defun can-optimize-access (var required-parameters env) - (let ((rebound? (caddr (variable-declaration 'variable-rebinding var env)))) - (if rebound? - (car (memq rebound? required-parameters)) - (car (memq var required-parameters))))) - -(defun optimize-slot-value (slots parameter form) - (destructuring-bind (ignore ignore slot-name) - form - (optimize-instance-access slots :read parameter (eval slot-name) nil))) - -(defun optimize-set-slot-value (slots parameter form) - (destructuring-bind (ignore ignore slot-name new-value) - form - (optimize-instance-access slots :write parameter (eval slot-name) new-value))) - -;;; -;;; The argument is an alist, the CAR of each entry is the name of -;;; a required parameter to the function. The alist is in order, so the -;;; position of an entry in the alist corresponds to the argument's position -;;; in the lambda list. -;;; -(defun optimize-instance-access (slots read/write parameter slot-name new-value) - (let* ((parameter-entry (assq parameter slots)) - (slot-entry (assq slot-name (cdr parameter-entry))) - (position (position parameter-entry slots))) - (unless parameter-entry - (error "Internal error in slot optimization.")) - (unless slot-entry - (setq slot-entry (list slot-name)) - (push slot-entry (cdr parameter-entry))) - (ecase read/write - (:read - (let ((form (list 'instance-read ''.PV-OFFSET. parameter position - `',slot-name))) - (push form (cdr slot-entry)) - form)) - (:write - (let ((form (list 'instance-write ''.PV-OFFSET. parameter position - `',slot-name '.new-value.))) - (push form (cdr slot-entry)) - `(let ((.new-value. ,new-value)) ,form)))))) - -(define-walker-template instance-read) -(define-walker-template instance-write) - - -(defmacro instance-read (pv-offset parameter position slot-name) - `(locally - (declare (optimize (speed 3) (safety 0) (compilation-speed 0))) - (let ((.INDEX. (pvref .PV. ,pv-offset))) - (if (and (typep .INDEX. 'fixnum) - (neq (setq .INDEX. (%svref ,(slot-vector-symbol position) .INDEX.)) - ',*slot-unbound*)) - .INDEX. - (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name))))) - -(defmacro instance-write (pv-offset parameter position slot-name new-value) - `(locally - (declare (optimize (speed 3) (safety 0) (compilation-speed 0))) - (let ((.INDEX. (pvref .PV. ,pv-offset))) - (if (typep .INDEX. 'fixnum) - (setf (%svref ,(slot-vector-symbol position) .INDEX.) ,new-value) - (pv-access-trap ,parameter .PV. ,pv-offset ,slot-name ,new-value))))) - -(defun pv-access-trap (instance pv offset slot-name &optional (new-value nil nvp)) - ;; - ;; First thing we do is a quick check to see if this is a class variable. - ;; This could be done inline by moving it to INSTANCE-READ/WRITE. I did - ;; not do that because I don't know whether its worth it. - ;; - (let ((cell (pvref pv offset))) - (if (consp cell) - (if nvp (setf (cdr cell) new-value) (cdr cell)) - ;; - ;; Well, now do a slow trap. - ;; - (if nvp - (setf (slot-value instance slot-name) new-value) - (slot-value instance slot-name))))) - -;;; -;;; This magic function has quite a job to do indeed. -;;; -;;; The careful reader will recall that contains all of the optimized -;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is -;;; a call to either INSTANCE-READ or INSTANCE-WRITE. -;;; -;;; At the time these calls were produced, the first argument was specified as -;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset -;;; arguments into the actual number that is the correct offset into the pv. -;;; -;;; But first, oh but first, we sort a bit so that for each argument -;;; we have the slots in alphabetical order. This canonicalizes the ISL's a -;;; bit and will hopefully lead to having fewer PV's floating around. Even -;;; if the gain is only modest, it costs nothing. -;;; -(defun slot-name-lists-from-slots (slots) - (mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry))) - (mutate-slots slots))) - -(defun mutate-slots (slots) - (let ((sorted (sort-slots slots)) - (pv-offset -1)) - (dolist (parameter-entry sorted) - (dolist (slot-entry (cdr parameter-entry)) - (incf pv-offset) - (dolist (form (cdr slot-entry)) - (setf (cadr form) pv-offset)))) - sorted)) - -(defun sort-slots (slots) - (mapcar #'(lambda (parameter-entry) - (cons (car parameter-entry) - (sort (cdr parameter-entry) ;slot entries - #'(lambda (a b) - (string-lessp (symbol-name (car a)) - (symbol-name (car b))))))) - slots)) - - -;;; -;;; This needs to work in terms of metatypes and also needs to work for -;;; automatically generated reader and writer functions. -;;; -(defun add-pv-binding (method-body plist required-parameters) - (let* ((isl (getf plist :isl)) - (isl-cache-symbol (make-symbol "isl-cache"))) - (nconc plist (list :isl-cache-symbol isl-cache-symbol)) - (with-gathering ((slot-variables (collecting)) - (metatypes (collecting))) - (iterate ((slots (list-elements isl)) - (i (interval :from 0))) - (cond (slots - (gather (slot-vector-symbol i) slot-variables) - (gather 'standard-instance metatypes)) - (t - (gather nil slot-variables) - (gather t metatypes)))) - `((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol)) - (.PV. *empty-vector*) - ,@(remove nil slot-variables)) - (declare ,(make-isl-type-declaration '.ISL.) - ,(make-pv-type-declaration '.PV.)) - - (let* ((cache (%isl-cache .ISL.)) - (size (%isl-size .ISL.)) - (mask (%isl-mask .ISL.)) - (field (%isl-field .ISL.))) - ,(generating-lap-in-lisp '(cache size mask field) - required-parameters - (flatten-lap - (emit-pv-dlap required-parameters metatypes slot-variables)))) - - ,@method-body))))) - -(defun emit-pv-dlap (required-parameters metatypes slot-variables) - (let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv))) - slot-variables)) - (wrappers (dlap-wrappers metatypes)) - (nwrappers (remove nil wrappers))) - (flet ((wrapper-moves (miss-label) - (dlap-wrapper-moves wrappers required-parameters metatypes miss-label slot-regs))) - (prog1 (emit-dlap-internal - nwrappers ;wrapper-regs - (wrapper-moves 'pv-miss) ;wrapper-moves - (opcode :exit-lap-in-lisp) ;hit - (flatten-lap ;miss - (opcode :label 'pv-miss) - (opcode :move - (operand :lisp `(primary-pv-cache-miss - .ISL. ,@required-parameters)) - (operand :lisp-variable '.PV.)) - (apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the wrappers have changed. - (opcode :label 'pv-wrapper-miss) - (opcode :exit-lap-in-lisp)) - 'pv-miss ;miss-label - (operand :lisp-variable '.PV.)) ;value-reg - (mapc #'deallocate-register nwrappers))))) - -(defun compute-primary-pv-cache-size (slot-name-lists) - (compute-cache-parameters (- (length slot-name-lists) (count nil slot-name-lists)) - t - 2)) - -(defun pv-cache-limit-fn (nlines) - (default-limit-fn nlines)) - -(defun primary-pv-cache-miss (isl &rest args) - (let* ((wrappers - (gathering1 (collecting) - (iterate ((slot-names (list-elements (%isl-slot-name-lists isl))) - (arg (list-elements args))) - (when slot-names (gather1 (check-wrapper-validity arg)))))) - (pv (lookup-pv isl args)) - (field (%isl-field isl)) - (cache (%isl-cache isl)) - (nkeys (length wrappers))) - (multiple-value-bind (new-field new-cache new-mask new-size) - (fill-cache field cache nkeys t #'pv-cache-limit-fn - (if (= nkeys 1) (car wrappers) wrappers) - pv) - (when (or (not (= new-field field)) - (not (eq new-cache cache))) - (without-interrupts ;NOTE: - (setf (%isl-field isl) new-field ; There is no mechanism to - (%isl-cache isl) new-cache ; synchronize the reading of - (%isl-size isl) new-size ; these values. But, this is - (%isl-mask isl) new-mask)) ; a safe order to write them - ; in. Stricly speaking, the - ; use of without-interrupts - ; is superfluous. - (when (neq new-cache cache) (free-cache cache)))) - pv)) - - - -(defmethod wrapper-fetcher ((class standard-class)) - 'std-instance-wrapper) - -(defmethod slots-fetcher ((class standard-class)) - 'std-instance-slots) - -(defmethod raw-instance-allocator ((class standard-class)) - '%%allocate-instance--class) diff --git a/obsolete/clos/2.0/walk.lisp b/obsolete/clos/2.0/walk.lisp deleted file mode 100644 index 2172c050..00000000 --- a/obsolete/clos/2.0/walk.lisp +++ /dev/null @@ -1,2005 +0,0 @@ -;;;-*- Mode:LISP; Package:(WALKER LISP 1000); Base:10; Syntax:Common-lisp -*- -;;; -;;; ************************************************************************* -;;; Copyright (c) 1991 Venue -;;; All rights reserved. -;;; ************************************************************************* -;;; -;;; A simple code walker, based IN PART on: (roll the credits) -;;; Larry Masinter's Masterscope -;;; Moon's Common Lisp code walker -;;; Gary Drescher's code walker -;;; Larry Masinter's simple code walker -;;; . -;;; . -;;; boy, thats fair (I hope). -;;; -;;; For now at least, this code walker really only does what CLOS needs it to -;;; do. Maybe it will grow up someday. -;;; - -;;; -;;; This code walker used to be completely portable. Now it is just "Real -;;; easy to port". This change had to happen because the hack that made it -;;; completely portable kept breaking in different releases of different -;;; Common Lisps, and in addition it never worked entirely anyways. So, -;;; its now easy to port. To port this walker, all you have to write is one -;;; simple macro and two simple functions. These macros and functions are -;;; used by the walker to manipluate the macroexpansion environments of -;;; the Common Lisp it is running in. -;;; -;;; The code which implements the macroexpansion environment manipulation -;;; mechanisms is in the first part of the file, the real walker follows it. -;;; - -(in-package 'walker) - -;;; -;;; The user entry points are walk-form and nested-walked-form. In addition, -;;; it is legal for user code to call the variable information functions: -;;; variable-lexical-p, variable-special-p and variable-class. Some users -;;; will need to call define-walker-template, they will have to figure that -;;; out for themselves. -;;; -(export '(define-walker-template - walk-form - nested-walk-form - variable-lexical-p - variable-special-p - variable-globally-special-p - *variable-declarations* - variable-declaration - )) - - - -;;; -;;; On the following pages are implementations of the implementation specific -;;; environment hacking functions for each of the implementations this walker -;;; has been ported to. If you add a new one, so this walker can run in a new -;;; implementation of Common Lisp, please send the changes back to us so that -;;; others can also use this walker in that implementation of Common Lisp. -;;; -;;; This code just hacks 'macroexpansion environments'. That is, it is only -;;; concerned with the function binding of symbols in the environment. The -;;; walker needs to be able to tell if the symbol names a lexical macro or -;;; function, and it needs to be able to build environments which contain -;;; lexical macro or function bindings. It must be able, when walking a -;;; macrolet, flet or labels form to construct an environment which reflects -;;; the bindings created by that form. Note that the environment created -;;; does NOT have to be sufficient to evaluate the body, merely to walk its -;;; body. This means that definitions do not have to be supplied for lexical -;;; functions, only the fact that that function is bound is important. For -;;; macros, the macroexpansion function must be supplied. -;;; -;;; This code is organized in a way that lets it work in implementations that -;;; stack cons their environments. That is reflected in the fact that the -;;; only operation that lets a user build a new environment is a with-body -;;; macro which executes its body with the specified symbol bound to the new -;;; environment. No code in this walker or in CLOS will hold a pointer to -;;; these environments after the body returns. Other user code is free to do -;;; so in implementations where it works, but that code is not considered -;;; portable. -;;; -;;; There are 3 environment hacking tools. One macro which is used for -;;; creating new environments, and two functions which are used to access the -;;; bindings of existing environments. -;;; -;;; WITH-AUGMENTED-ENVIRONMENT -;;; -;;; ENVIRONMENT-FUNCTION -;;; -;;; ENVIRONMENT-MACRO -;;; - -(defun unbound-lexical-function (&rest args) - (declare (ignore args)) - (error "The evaluator was called to evaluate a form in a macroexpansion~%~ - environment constructed by the CLOS portable code walker. These~%~ - environments are only useful for macroexpansion, they cannot be~%~ - used for evaluation.~%~ - This error should never occur when using CLOS.~%~ - This most likely source of this error is a program which tries to~%~ - to use the CLOS portable code walker to build its own evaluator.")) - - -;;; -;;; In Coral Common Lisp, the macroexpansion environment is just a list -;;; of environment entries. The cadr of each element specifies the type -;;; of the element. The only types that interest us are CCL::MACRO and -;;; FUNCTION. In these cases the element is interpreted as follows. -;;; -;;; ( CCL::MACRO . macroexpansion-function) -;;; -;;; ( FUNCTION . ) -;;; -;;; When in the compiler, is a gensym which will be -;;; a variable which bound at run-time to the function. -;;; When in the interpreter, is the actual function. -;;; -;;; -#+:Coral -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - (dolist (f functions) - (push (list* f 'function (gensym)) env)) - (dolist (m macros) - (push (list* (car m) 'ccl::macro (cadr m)) env)) - env) - -(defun environment-function (env fn) - (let ((entry (assoc fn env :test #'equal))) - (and entry - (eq (cadr entry) 'function) - (cddr entry)))) - -(defun environment-macro (env macro) - (let ((entry (assoc macro env :test #'equal))) - (and entry - (eq (cadr entry) 'ccl::macro) - (cddr entry)))) - -);#+:Coral - - -;;; -;;; Franz Common Lisp is a lot like Coral Lisp. The macroexpansion -;;; environment is just a list of entries. The cadr of each element -;;; specifies the type of the element. The types that interest us -;;; are FUNCTION, EXCL::MACRO, and COMPILER::FUNCTION-VALUE. These -;;; are interpreted as follows: -;;; -;;; ( FUNCTION . ) -;;; -;;; This happens in the interpreter with lexically -;;; bound functions. -;;; -;;; ( COMPILER::FUNCTION-VALUE . ) -;;; -;;; This happens in the compiler. The gensym represents -;;; a variable which will be bound at run time to the -;;; function object. -;;; -;;; ( EXCL::MACRO . ) -;;; -;;; In both interpreter and compiler, this is the -;;; representation used for macro definitions. -;;; -;;; -#+:ExCL -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - (dolist (f functions) - (push (list* f 'function #'unbound-lexical-function) env)) - (dolist (m macros) - (push (list* (car m) 'excl::macro (cadr m)) env)) - env) - -(defun environment-function (env fn) - (let ((entry (assoc fn env :test #'equal))) - (and entry - (or (eq (cadr entry) 'function) - (eq (cadr entry) 'compiler::function-value)) - (cddr entry)))) - -(defun environment-macro (env macro) - (let ((entry (assoc macro env :test #'equal))) - (and entry - (eq (cadr entry) 'excl::macro) - (cddr entry)))) - -);#+:ExCL - - -#+Lucid -(progn - -(proclaim '(inline - %alphalex-p - add-contour-to-env-shape - make-function-variable - make-sfc-contour - sfc-contour-type - sfc-contour-elements - add-sfc-contour - add-function-contour - add-macrolet-contour - find-variable-in-contour - find-alist-element-in-contour - find-macrolet-in-contour)) - -(defun %alphalex-p (object) - #-Prime - (eq (cadddr (cddddr object)) 'lucid::%alphalex) - #+Prime - (eq (caddr (cddddr object)) 'lucid::%alphalex)) - -#+Prime -(defun lucid::augment-lexenv-fvars-dummy (lexical vars) - (lucid::augment-lexenv-fvars-aux lexical vars '() '() 'flet '())) - -(defconstant function-contour 1) -(defconstant macrolet-contour 5) - -(defstruct lucid::contour - type - elements) - -(defun add-contour-to-env-shape (contour-type elements env-shape) - (cons (make-contour :type contour-type - :elements elements) - env-shape)) - -(defstruct (variable (:constructor make-variable (name source-type))) - name - (identifier nil) - source-type) - -(defconstant function-sfc-contour 1) -(defconstant macrolet-sfc-contour 8) -(defconstant function-variable-type 1) - -(defun make-function-variable (name) - (make-variable name function-variable-type)) - -(defun make-sfc-contour (type elements) - (cons type elements)) - -(defun sfc-contour-type (sfc-contour) - (car sfc-contour)) - -(defun sfc-contour-elements (sfc-contour) - (cdr sfc-contour)) - -(defun add-sfc-contour (element-list environment type) - (cons (make-sfc-contour type element-list) environment)) - -(defun add-function-contour (variable-list environment) - (add-sfc-contour variable-list environment function-sfc-contour)) - -(defun add-macrolet-contour (alist environment) - (add-sfc-contour alist environment macrolet-sfc-contour)) - -(defun find-variable-in-contour (name contour) - (dolist (element (sfc-contour-elements contour) nil) - (when (eq (variable-name element) name) - (return element)))) - -(defun find-alist-element-in-contour (name contour) - (cdr (assoc name (sfc-contour-elements contour)))) - -(defun find-macrolet-in-contour (name contour) - (find-alist-element-in-contour name contour)) - -(defmacro do-sfc-contours ((contour-var environment &optional result) - &body body) - `(dolist (,contour-var ,environment ,result) ,@body)) - - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let* ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -;;; -;;; with-augmented-environment-internal is where the real work of augmenting -;;; the environment happens. -;;; -(defun with-augmented-environment-internal (env functions macros) - (let ((function-names (mapcar #'first functions)) - (macro-names (mapcar #'first macros)) - (macro-functions (mapcar #'second macros))) - (cond ((or (null env) - (contour-p (first env))) - (when function-names - (setq env (add-contour-to-env-shape function-contour - function-names - env))) - (when macro-names - (setq env (add-contour-to-env-shape macrolet-contour - (pairlis macro-names - macro-functions) - env)))) - ((%alphalex-p env) - (when function-names - (setq env (lucid::augment-lexenv-fvars-dummy env function-names))) - (when macro-names - (setq env (lucid::augment-lexenv-mvars env - macro-names - macro-functions)))) - (t - (when function-names - (setq env (add-function-contour - (mapcar #'make-function-variable function-names) - env))) - (when macro-names - (setq env (add-macrolet-contour - (pairlis macro-names macro-functions) - env))))) - env)) - - -(defun environment-function (env fn) - (cond ((null env) nil) - ((contour-p (first env)) - (if (lucid::find-lexical-function fn env) - t - nil)) - ((%alphalex-p env) - (if (lucid::lexenv-fvar fn env) - t - nil)) - (t (do-sfc-contours (contour env nil) - (let ((type (sfc-contour-type contour))) - (cond ((eql type function-sfc-contour) - (when (find-variable-in-contour fn contour) - (return t))) - ((eql type macrolet-sfc-contour) - (when (find-macrolet-in-contour fn contour) - (return nil))))))))) - -(defun environment-macro (env macro) - (cond ((null env) nil) - ((contour-p (first env)) - (lucid::find-lexical-macro macro env)) - ((%alphalex-p env) - (lucid::lexenv-mvar macro env)) - (t (do-sfc-contours (contour env nil) - (let ((type (sfc-contour-type contour))) - (cond ((eql type function-sfc-contour) - (when (find-variable-in-contour macro contour) - (return nil))) - ((eql type macrolet-sfc-contour) - (let ((fn (find-macrolet-in-contour macro contour))) - (when fn - (return fn)))))))))) - - -);#+Lucid - - - -;;; -;;; On the 3600, the documentation for how the environments are represented -;;; is in sys:sys;eval.lisp. That total information is not repeated here. -;;; The important points are that: -;;; si:env-variables returns a list of which each element is: -;;; -;;; (symbol value) -;;; or (symbol . locative) -;;; -;;; The first form is for lexical variables, the second for -;;; special and instance variables. In either case CADR of -;;; the entry is the value and SETF of CADR is used to change -;;; the value. Variables are looked up with ASSQ. -;;; -;;; si:env-functions returns a list of which each element is: -;;; -;;; (symbol definition) -;;; -;;; where definition is anything that could go in a function cell. -;;; This is used for both local functions and local macros. -;;; -;;; The 3600 stack conses its environments (at least in the interpreter). -;;; This means that code written using this walker and running on the 3600 -;;; must not hold on to the environment after the walk-function returns. -;;; No code in this walker or in CLOS does that. -;;; -#+Genera -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - (let ((funs (make-symbol "FNS")) - (macs (make-symbol "MACROS")) - (new (make-symbol "NEW"))) - `(let ((,funs ,functions) - (,macs ,macros) - (,new ())) - (dolist (f ,funs) - (push `(,(car f) ,#'unbound-lexical-function) ,new)) - (dolist (m ,macs) - (push `(,(car m) (special ,(cadr m))) ,new)) - (let* ((.old-env. ,old-env) - (.old-vars. (pop .old-env.)) - (.old-funs. (pop .old-env.)) - (.old-blks. (pop .old-env.)) - (.old-tags. (pop .old-env.)) - (.old-dcls. (pop .old-env.))) - (si:with-interpreter-environment (,new-env - .old-env. - .old-vars. - (append ,new .old-funs.) - .old-blks. - .old-tags. - .old-dcls.) - ,@body))))) - - -(defun environment-function (env fn) - (if (null env) - (values nil nil) - (let ((entry (assoc fn (si:env-functions env) :test #'equal))) - (if (and entry - (or (not (listp (cadr entry))) - (not (eq (caadr entry) 'special)))) - (values (cadr entry) t) - (environment-function (si:env-parent env) fn))))) - -(defun environment-macro (env macro) - (if (null env) - (values nil nil) - (let ((entry (assoc macro (si:env-functions env) :test #'equal))) - (if (and entry - (listp (cadr entry)) - (eq (caadr entry) 'special)) - (values (cadadr entry) t) - (environment-macro (si:env-parent env) macro))))) - -);#+Genera - -#+Cloe-Runtime -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env ,functions ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - functions - (dolist (m macros) - (setf env `(,(first m) (compiler::macro . ,(second m)) ,@env))) - env) - -(defun environment-function (env fn) - nil) - -(defun environment-macro (env macro) - (let ((entry (getf env macro))) - (if (and (consp entry) - (eq (car entry) 'compiler::macro)) - (values (cdr entry) t) - (values nil nil)))) - -);#+Cloe-Runtime - - -;;; -;;; In Xerox Lisp, the compiler and interpreter use different structures for -;;; the environment. This doesn't cause a serious problem, the parts of the -;;; environments we are concerned with are fairly similar. -;;; -#+:Xerox -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let* ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -;;; -;;; with-augmented-environment-internal is where the real work of augmenting -;;; the environment happens. Before it gets there, env had better not be NIL -;;; anymore because we have to know what kind of environment we are supposed -;;; to be building up. This is probably never a real concern in practice. -;;; It better not be because we don't do anything about it. -;;; -(defun with-augmented-environment-internal (env functions macros) - (cond - ((compiler::env-p env) - (dolist (f functions) - (setq env (compiler::copy-env-with-function - env f :function))) - (dolist (m macros) - (setq env (compiler::copy-env-with-function - env (car m) :macro (cadr m))))) - (t (setq env (if (il:environment-p env) - (il:\\copy-environment env) - (il:\\make-environment))) - ;; The functions field of the environment is a plist of function names - ;; and conses like (:function . fn) or (:macro . expansion-fn). - ;; Note that we can't smash existing entries in this plist since these - ;; are likely shared with older environments. - (dolist (f functions) - (setf (il:environment-functions env) - (list* f (cons :function #'unbound-lexical-function) - (il:environment-functions env)))) - (dolist (m macros) - (setf (il:environment-functions env) - (list* (car m) (cons :macro (cadr m)) - (il:environment-functions env)))))) - env) - -(defun environment-function (env fn) - (cond ((compiler::env-p env) (eq (compiler:env-fboundp env fn) :function)) - ((il:environment-p env) (eq (getf (il:environment-functions env) fn) - :function)) - (t nil))) - -(defun environment-macro (env macro) - (cond ((compiler::env-p env) - (multiple-value-bind (type def) - (compiler:env-fboundp env macro) - (when (eq type :macro) def))) - ((il:environment-p env) - (xcl:destructuring-bind (type . def) - (getf (il:environment-functions env) macro) - (when (eq type :macro) def))) - (t nil))) - -);#+:Xerox - - -;;; -;;; In IBUKI Common Lisp, the macroexpansion environment is a three element -;;; list. The second element describes lexical functions and macros. The -;;; function entries in this list have the form -;;; ( . (FUNCTION . ( . nil)) -;;; The macro entries have the form -;;; ( . (MACRO . ( . nil)). -;;; -;;; -#+(or KCL IBCL) -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - (let ((first (first env)) - (lexicals (second env)) - (third (third env))) - (dolist (f functions) - (push `(,(car f) . (function . (,#'unbound-lexical-function . nil))) - lexicals)) - (dolist (m macros) - (push `(,(car m) . (macro . ( ,(cadr m) . nil))) - lexicals)) - (list first lexicals third))) - -(defun environment-function (env fn) - (when env - (let ((entry (assoc fn (second env)))) - (and entry - (eq (cadr entry) 'function) - (caddr entry))))) - -(defun environment-macro (env macro) - (when env - (let ((entry (assoc macro (second env)))) - (and entry - (eq (cadr entry) 'macro) - (caddr entry))))) -);#+(or KCL IBCL) - - -;;; --- TI Explorer -- - -;;; An environment is a two element list, whose car we can ignore and -;;; whose cadr is list of the local-definitions-frames. Each -;;; local-definitions-frame holds either macros or functions, but not -;;; both. Each frame is a plist of ... where -;;; is a locative to the function cell of the symbol that names -;;; the function or macro, and is the new def or NIL if this is function -;;; redefinition or (cons 'ticl:macro ) if this is a macro -;;; redefinition. -;;; -;;; Here's an example. For the form: -;;; (defun foo () -;;; (macrolet ((bar (a b) (list a b)) -;;; (bar2 (a b) (list a b))) -;;; (flet ((some-local-fn (c d) (print (list c d))) -;;; (another (c d) (print (list c d)))) -;;; (bar (some-local-fn 1 2) 3)))) - -;;; the environment arg to macroexpand-1 when called on -;;; (bar (some-local-fn 1 2) 3) -;;;is -;;;(NIL ((# NIL -;;; # NIL) -;;; (# -;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR (:DESCRIPTIVE-ARGLIST (A B))) -;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) -;;; (BLOCK BAR ....)) -;;; # -;;; (TICL:MACRO TICL:NAMED-LAMBDA (BAR2 (:DESCRIPTIVE-ARGLIST (A B))) -;;; (SYS::*MACROARG* &OPTIONAL SYS::*MACROENVIRONMENT*) -;;; (BLOCK BAR2 ....)))) -#+TI -(progn - -;;; from sys:site;macros.lisp -(eval-when (compile load eval) - -(DEFMACRO MACRO-DEF? (thing) - `(AND (CONSP ,thing) (EQ (CAR ,thing) 'TICL::MACRO))) - -;; the following macro generates code to check the 'local' environment -;; for a macro definition for THE SYMBOL . Such a definition would -;; be set up only by a MACROLET. If a macro definition for is -;; found, its expander function is returned. - -(DEFMACRO FIND-LOCAL-DEFINITION (name local-function-environment) - `(IF ,local-function-environment - (LET ((vcell (ticl::LOCF (SYMBOL-FUNCTION ,name)))) - (DOLIST (frame ,local-function-environment) - ;; is nil or a locative - (LET ((value (sys::GET-LOCATION-OR-NIL (ticl::LOCF frame) - vcell))) - (When value (RETURN (CAR value)))))) - nil))) - - -;;;Edited by Reed Hastings 13 Jan 88 16:29 -(defun environment-macro (env macro) - "returns what macro-function would, ie. the expansion function" - ;;some code picked off macroexpand-1 - (let* ((local-definitions (cadr env)) - (local-def (find-local-definition macro local-definitions))) - (if (macro-def? local-def) - (cdr local-def)))) - -;;;Edited by Reed Hastings 13 Jan 88 16:29 -;;;Edited by Reed Hastings 7 Mar 88 19:07 -(defun environment-function (env fn) - (let* ((local-definitions (cadr env))) - (dolist (frame local-definitions) - (let ((val (getf frame - (ticl::locf (symbol-function fn)) - :not-found-marker))) - (cond ((eq val :not-found-marker)) - ((functionp val) (return t)) - ((and (listp val) - (eq (car val) 'ticl::macro)) - (return nil)) - (t - (error "we are confused"))))))) - - -;;;Edited by Reed Hastings 13 Jan 88 16:29 -;;;Edited by Reed Hastings 7 Mar 88 19:07 -(defun with-augmented-environment-internal (env functions macros) - (let ((local-definitions (cadr env)) - (new-local-fns-frame - (mapcan #'(lambda (fn) - (list (ticl:locf (symbol-function (car fn))) - #'unbound-lexical-function)) - functions)) - (new-local-macros-frame - (mapcan #'(lambda (m) - (list (ticl:locf (symbol-function (car m))) (cons 'ticl::macro (cadr m)))) - macros))) - (when new-local-fns-frame - (push new-local-fns-frame local-definitions)) - (when new-local-macros-frame - (push new-local-macros-frame local-definitions)) - `(,(car env) ,local-definitions))) - - -;;;Edited by Reed Hastings 7 Mar 88 19:07 -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -);#+TI - - -#+(and dec vax common) -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - #'(lambda (op &optional (arg nil arg-p)) - (cond ((eq op :macro-function) - (unless arg-p (error "Invalid environment use.")) - (lookup-macro-function arg env functions macros)) - (arg-p - (error "Invalid environment operation: ~S ~S" op arg)) - (t - (lookup-macro-function op env functions macros))))) - -(defun lookup-macro-function (name env fns macros) - (let ((m (assoc name macros))) - (cond (m (cadr m)) - ((assoc name fns) :function) - (env (funcall env name)) - (t nil)))) - -(defun environment-macro (env macro) - (let ((m (and env (funcall env macro)))) - (and (not (eq m :function)) - m))) - -;;; Nobody calls environment-function. What would it return, anyway? -);#+(and dec vax common) - - -;;; -;;; In Golden Common Lisp, the macroexpansion environment is just a list -;;; of environment entries. Unless the car of the list is :compiler-menv -;;; it is an interpreted environment. The cadr of each element specifies -;;; the type of the element. The only types that interest us are GCL:MACRO -;;; and FUNCTION. In these cases the element is interpreted as follows. -;;; -;;; Compiled: -;;; ( macroexpansion-function) -;;; ( ) -;;; -;;; Interpreted: -;;; ( GCL:MACRO macroexpansion-function) -;;; ( ) -;;; -;;; When in the compiler, is a gensym which will be -;;; a variable which bound at run-time to the function. -;;; When in the interpreter, is the actual function. -;;; -;;; -#+gclisp -(progn - -(defmacro with-augmented-environment - ((new-env old-env &key functions macros) &body body) - `(let ((,new-env (with-augmented-environment-internal ,old-env - ,functions - ,macros))) - ,@body)) - -(defun with-augmented-environment-internal (env functions macros) - (let ((new-entries nil)) - (dolist (f functions) - (push (cons (car f) nil) new-entries)) - (dolist (m macros) - (push (cons (car m) - (if (eq :compiler-menv (car env)) - (if (eq (caadr m) 'lisp::lambda) - `(,(gensym) ,(cadr m)) - `(,(gensym) ,@(cadr m))) - `(gclisp:MACRO ,@(cadr m)))) - new-entries)) - (if (eq :compiler-menv (car env)) - `(:compiler-menv ,@new-entries ,@(cdr env)) - (append new-entries env)))) - -(defun environment-function (env fn) - (let ((entry (lisp::lexical-function fn env))) - (and entry - (eq entry 'lisp::lexical-function) - fn))) - -(defun environment-macro (env macro) - (let ((entry (assoc macro (if (eq :compiler-menv (first env)) - (rest env) - env)))) - (and entry - (consp entry) - (symbolp (car entry)) ;name - (symbolp (cadr entry)) ;gcl:macro or gensym - (nthcdr 2 entry)))) - -);#+gclisp - - - -(defmacro with-new-definition-in-environment - ((new-env old-env macrolet/flet/labels-form) &body body) - (let ((functions (make-symbol "Functions")) - (macros (make-symbol "Macros"))) - `(let ((,functions ()) - (,macros ())) - (ecase (car ,macrolet/flet/labels-form) - ((flet labels) - (dolist (fn (cadr ,macrolet/flet/labels-form)) - (push fn ,functions))) - ((macrolet) - (dolist (mac (cadr ,macrolet/flet/labels-form)) - (push (list (car mac) - (convert-macro-to-lambda (cadr mac) - (cddr mac) - (string (car mac)))) - ,macros)))) - (with-augmented-environment - (,new-env ,old-env :functions ,functions :macros ,macros) - ,@body)))) - -#-Genera -(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) - (let ((gensym (make-symbol name))) - (eval `(defmacro ,gensym ,llist ,@body)) - (macro-function gensym))) - -#+Genera -(defun convert-macro-to-lambda (llist body &optional (name "Dummy Macro")) - (si:defmacro-1 - 'sys:named-lambda 'sys:special (make-symbol name) llist body)) - - - - - -;;; -;;; Now comes the real walker. -;;; -;;; As the walker walks over the code, it communicates information to itself -;;; about the walk. This information includes the walk function, variable -;;; bindings, declarations in effect etc. This information is inherently -;;; lexical, so the walker passes it around in the actual environment the -;;; walker passes to macroexpansion functions. This is what makes the -;;; nested-walk-form facility work properly. -;;; -(defmacro walker-environment-bind ((var env &rest key-args) - &body body) - `(with-augmented-environment - (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args)) - .,body)) - -(defvar *key-to-walker-environment* (gensym)) - -(defun env-lock (env) - (environment-macro env *key-to-walker-environment*)) - -(defun walker-environment-bind-1 (env &key (walk-function nil wfnp) - (walk-form nil wfop) - (declarations nil decp) - (lexical-variables nil lexp)) - (let ((lock (environment-macro env *key-to-walker-environment*))) - (list - (list *key-to-walker-environment* - (list (if wfnp walk-function (car lock)) - (if wfop walk-form (cadr lock)) - (if decp declarations (caddr lock)) - (if lexp lexical-variables (cadddr lock))))))) - -(defun env-walk-function (env) - (car (env-lock env))) - -(defun env-walk-form (env) - (cadr (env-lock env))) - -(defun env-declarations (env) - (caddr (env-lock env))) - -(defun env-lexical-variables (env) - (cadddr (env-lock env))) - - -(defun note-declaration (declaration env) - (let ((lock (env-lock env))) - (setf (caddr lock) - (cons declaration (caddr lock))))) - -(defun note-lexical-binding (thing env) - (let ((lock (env-lock env))) - (setf (cadddr lock) - (cons thing (cadddr lock))))) - - -(defun VARIABLE-LEXICAL-P (var env) - (member var (env-lexical-variables env))) - -(defvar *VARIABLE-DECLARATIONS* '(special)) - -(defun VARIABLE-DECLARATION (declaration var env) - (if (not (member declaration *variable-declarations*)) - (error "~S is not a reckognized variable declaration." declaration) - (let ((id (or (member var (env-lexical-variables env)) var))) - (dolist (decl (env-declarations env)) - (when (and (eq (car decl) declaration) - (eq (cadr decl) id)) - (return decl)))))) - -(defun VARIABLE-SPECIAL-P (var env) - (or (not (null (variable-declaration 'special var env))) - (variable-globally-special-p var))) - -;;; -;;; VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been -;;; declared globally special. Any particular CommonLisp implementation -;;; should customize this function accordingly and send their customization -;;; back. -;;; -;;; The default version of variable-globally-special-p is probably pretty -;;; slow, so it uses *globally-special-variables* as a cache to remember -;;; variables that it has already figured out are globally special. -;;; -;;; This would need to be reworked if an unspecial declaration got added to -;;; Common Lisp. -;;; -;;; Common Lisp nit: -;;; variable-globally-special-p should be defined in Common Lisp. -;;; -#-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs - GCLisp TI pyramid) -(defvar *globally-special-variables* ()) - -(defun variable-globally-special-p (symbol) - #+Genera (si:special-variable-p symbol) - #+Cloe-Runtime (compiler::specialp symbol) - #+Lucid (lucid::proclaimed-special-p symbol) - #+TI (get symbol 'special) - #+Xerox (il:variable-globally-special-p symbol) - #+(and dec vax common) (get symbol 'system::globally-special) - #+(or KCL IBCL) (si:specialp symbol) - #+excl (get symbol 'excl::.globally-special.) - #+:CMU (or (get symbol 'lisp::globally-special) - (get symbol - 'clc::globally-special-in-compiler)) - #+HP-HPLabs (member (get symbol 'impl:vartype) - '(impl:fluid impl:global) - :test #'eq) - #+:GCLISP (gclisp::special-p symbol) - #+pyramid (or (get symbol 'lisp::globally-special) - (get symbol - 'clc::globally-special-in-compiler)) - #+:CORAL (ccl::proclaimed-special-p symbol) - #-(or Genera Cloe-Runtime Lucid Xerox Excl KCL IBCL (and dec vax common) :CMU HP-HPLabs - GCLisp TI pyramid :CORAL) - (or (not (null (member symbol *globally-special-variables* :test #'eq))) - (when (eval `(flet ((ref () ,symbol)) - (let ((,symbol '#,(list nil))) - (and (boundp ',symbol) (eq ,symbol (ref)))))) - (push symbol *globally-special-variables*) - t))) - - - ;; -;;;;;; Handling of special forms (the infamous 24). - ;; -;;; -;;; and I quote... -;;; -;;; The set of special forms is purposely kept very small because -;;; any program analyzing program (read code walker) must have -;;; special knowledge about every type of special form. Such a -;;; program needs no special knowledge about macros... -;;; -;;; So all we have to do here is a define a way to store and retrieve -;;; templates which describe how to walk the 24 special forms and we are all -;;; set... -;;; -;;; Well, its a nice concept, and I have to admit to being naive enough that -;;; I believed it for a while, but not everyone takes having only 24 special -;;; forms as seriously as might be nice. There are (at least) 3 ways to -;;; lose: -;; -;;; 1 - Implementation x implements a Common Lisp special form as a macro -;;; which expands into a special form which: -;;; - Is a common lisp special form (not likely) -;;; - Is not a common lisp special form (on the 3600 IF --> COND). -;;; -;;; * We can safe ourselves from this case (second subcase really) by -;;; checking to see if there is a template defined for something -;;; before we check to see if we we can macroexpand it. -;;; -;;; 2 - Implementation x implements a Common Lisp macro as a special form. -;;; -;;; * This is a screw, but not so bad, we save ourselves from it by -;;; defining extra templates for the macros which are *likely* to -;;; be implemented as special forms. (DO, DO* ...) -;;; -;;; 3 - Implementation x has a special form which is not on the list of -;;; Common Lisp special forms. -;;; -;;; * This is a bad sort of a screw and happens more than I would like -;;; to think, especially in the implementations which provide more -;;; than just Common Lisp (3600, Xerox etc.). -;;; The fix is not terribly staisfactory, but will have to do for -;;; now. There is a hook in get walker-template which can get a -;;; template from the implementation's own walker. That template -;;; has to be converted, and so it may be that the right way to do -;;; this would actually be for that implementation to provide an -;;; interface to its walker which looks like the interface to this -;;; walker. -;;; - -(eval-when (compile load eval) - -(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because - `(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack - ;compile time definition of macros - ;right for setf. - -(defmacro define-walker-template - (name &optional (template '(nil repeat (eval)))) - `(eval-when (load eval) - (setf (get-walker-template-internal ',name) ',template))) -) - -(defun get-walker-template (x) - (cond ((symbolp x) - (or (get-walker-template-internal x) - (get-implementation-dependent-walker-template x))) - ((and (listp x) (eq (car x) 'lambda)) - '(lambda repeat (eval))) - (t - (error "Can't get template for ~S" x)))) - -(defun get-implementation-dependent-walker-template (x) - (declare (ignore x)) - ()) - - - ;; -;;;;;; The actual templates - ;; - -(define-walker-template BLOCK (NIL NIL REPEAT (EVAL))) -(define-walker-template CATCH (NIL EVAL REPEAT (EVAL))) -(define-walker-template COMPILER-LET walk-compiler-let) -(define-walker-template DECLARE walk-unexpected-declare) -(define-walker-template EVAL-WHEN (NIL QUOTE REPEAT (EVAL))) -(define-walker-template FLET walk-flet) -(define-walker-template FUNCTION (NIL CALL)) -(define-walker-template GO (NIL QUOTE)) -(define-walker-template IF walk-if) -(define-walker-template LABELS walk-labels) -(define-walker-template LAMBDA walk-lambda) -(define-walker-template LET walk-let) -(define-walker-template LET* walk-let*) -(define-walker-template MACROLET walk-macrolet) -(define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL))) -(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL))) -(define-walker-template MULTIPLE-VALUE-SETQ (NIL (REPEAT (SET)) EVAL)) -(define-walker-template MULTIPLE-VALUE-BIND walk-multiple-value-bind) -(define-walker-template PROGN (NIL REPEAT (EVAL))) -(define-walker-template PROGV (NIL EVAL EVAL REPEAT (EVAL))) -(define-walker-template QUOTE (NIL QUOTE)) -(define-walker-template RETURN-FROM (NIL QUOTE REPEAT (RETURN))) -(define-walker-template SETQ (NIL REPEAT (SET EVAL))) -(define-walker-template TAGBODY walk-tagbody) -(define-walker-template THE (NIL QUOTE EVAL)) -(define-walker-template THROW (NIL EVAL EVAL)) -(define-walker-template UNWIND-PROTECT (NIL RETURN REPEAT (EVAL))) - -;;; The new special form. -;(define-walker-template clos::LOAD-TIME-EVAL (NIL EVAL)) - -;;; -;;; And the extra templates... -;;; -(define-walker-template DO walk-do) -(define-walker-template DO* walk-do*) -(define-walker-template PROG walk-prog) -(define-walker-template PROG* walk-prog*) -(define-walker-template COND (NIL REPEAT ((TEST REPEAT (EVAL))))) - -#+Genera -(progn - (define-walker-template zl::named-lambda walk-named-lambda) - (define-walker-template SCL:LETF walk-let) - (define-walker-template SCL:LETF* walk-let*) - ) - -#+Lucid -(progn - (define-walker-template #+LCL3.0 lucid-common-lisp:named-lambda - #-LCL3.0 sys:named-lambda walk-named-lambda) - ) - -#+(or KCL IBCL) -(progn - (define-walker-template lambda-block walk-named-lambda);Not really right, - ;we don't hack block - ;names anyways. - ) - -#+TI -(progn - (define-walker-template TICL::LET-IF walk-let-if) - ) - -#+:Coral -(progn - (define-walker-template ccl:%stack-block walk-let) - ) - - - -(defun WALK-FORM (form - &optional environment - (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) - (walker-environment-bind (new-env environment :walk-function walk-function) - (walk-form-internal form :eval new-env))) - -;;; -;;; nested-walk-form provides an interface that allows nested macros, each -;;; of which must walk their body to just do one walk of the body of the -;;; inner macro. That inner walk is done with a walk function which is the -;;; composition of the two walk functions. -;;; -;;; This facility works by having the walker annotate the environment that -;;; it passes to macroexpand-1 to know which form is being macroexpanded. -;;; If then the &whole argument to the macroexpansion function is eq to -;;; the env-walk-form of the environment, nested-walk-form can be certain -;;; that there are no intervening layers and that a nested walk is alright. -;;; -;;; There are some semantic problems with this facility. In particular, if -;;; the outer walk function returns T as its walk-no-more-p value, this will -;;; prevent the inner walk function from getting a chance to walk the subforms -;;; of the form. This is almost never what you want, since it destroys the -;;; equivalence between this nested-walk-form function and two seperate -;;; walk-forms. -;;; -(defun NESTED-WALK-FORM (whole - form - &optional environment - (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) - (if (eq whole (env-walk-form environment)) - (let ((outer-walk-function (env-walk-function environment))) - (throw whole - (walk-form - form - environment - #'(lambda (f c e) - ;; First loop to make sure the inner walk function - ;; has done all it wants to do with this form. - ;; Basically, what we are doing here is providing - ;; the same contract walk-form-internal normally - ;; provides to the inner walk function. - (let ((inner-result nil) - (inner-no-more-p nil) - (outer-result nil) - (outer-no-more-p nil)) - (loop - (multiple-value-setq (inner-result inner-no-more-p) - (funcall walk-function f c e)) - (cond (inner-no-more-p (return)) - ((not (eq inner-result f))) - ((not (consp inner-result)) (return)) - ((get-walker-template (car inner-result)) (return)) - (t - (multiple-value-bind (expansion macrop) - (walker-environment-bind - (new-env e :walk-form inner-result) - (macroexpand-1 inner-result new-env)) - (if macrop - (setq inner-result expansion) - (return))))) - (setq f inner-result)) - (multiple-value-setq (outer-result outer-no-more-p) - (funcall outer-walk-function - inner-result - c - e)) - (values outer-result - (and inner-no-more-p outer-no-more-p))))))) - (walk-form form environment walk-function))) - -;;; -;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It -;;; takes a form and the current context and walks the form calling itself or -;;; the appropriate template recursively. -;;; -;;; "It is recommended that a program-analyzing-program process a form -;;; that is a list whose car is a symbol as follows: -;;; -;;; 1. If the program has particular knowledge about the symbol, -;;; process the form using special-purpose code. All of the -;;; standard special forms should fall into this category. -;;; 2. Otherwise, if macro-function is true of the symbol apply -;;; either macroexpand or macroexpand-1 and start over. -;;; 3. Otherwise, assume it is a function call. " -;;; - -(defun walk-form-internal (form context env - &aux newform newnewform - walk-no-more-p macrop - fn template) - ;; First apply the walk-function to perform whatever translation - ;; the user wants to this form. If the second value returned - ;; by walk-function is T then we don't recurse... - (catch form - (multiple-value-setq (newform walk-no-more-p) - (funcall (env-walk-function env) form context env)) - (catch newform - (cond (walk-no-more-p newform) - ((not (eq form newform)) - (walk-form-internal newform context env)) - ((not (consp newform)) newform) - ((setq template (get-walker-template (setq fn (car newform)))) - (if (symbolp template) - (funcall template newform context env) - (walk-template newform template context env))) - (t - (multiple-value-setq (newnewform macrop) - (walker-environment-bind (new-env env :walk-form newform) - (macroexpand-1 newform new-env))) - (cond (macrop (walk-form-internal newnewform context env)) - ((and (symbolp fn) - (not (fboundp fn)) - (special-form-p fn)) - (error - "~S is a special form, not defined in the CommonLisp.~%~ - manual This code walker doesn't know how to walk it.~%~ - Define a template for this special form and try again." - fn)) - (t - ;; Otherwise, walk the form as if its just a standard - ;; functioncall using a template for standard function - ;; call. - (walk-template - newnewform '(call repeat (eval)) context env)))))))) - -(defun walk-template (form template context env) - (if (atom template) - (ecase template - ((EVAL FUNCTION TEST EFFECT RETURN) - (walk-form-internal form :EVAL env)) - ((QUOTE NIL) form) - (SET - (walk-form-internal form :SET env)) - ((LAMBDA CALL) - (cond ((symbolp form) form) - #+Lispm - ((sys:validate-function-spec form) form) - (t (walk-form-internal form context env))))) - (case (car template) - (REPEAT - (walk-template-handle-repeat form - (cdr template) - ;; For the case where nothing happens - ;; after the repeat optimize out the - ;; call to length. - (if (null (cddr template)) - () - (nthcdr (- (length form) - (length - (cddr template))) - form)) - context - env)) - (IF - (walk-template form - (if (if (listp (cadr template)) - (eval (cadr template)) - (funcall (cadr template) form)) - (caddr template) - (cadddr template)) - context - env)) - (REMOTE - (walk-template form (cadr template) context env)) - (otherwise - (cond ((atom form) form) - (t (recons form - (walk-template - (car form) (car template) context env) - (walk-template - (cdr form) (cdr template) context env)))))))) - -(defun walk-template-handle-repeat (form template stop-form context env) - (if (eq form stop-form) - (walk-template form (cdr template) context env) - (walk-template-handle-repeat-1 form - template - (car template) - stop-form - context - env))) - -(defun walk-template-handle-repeat-1 (form template repeat-template - stop-form context env) - (cond ((null form) ()) - ((eq form stop-form) - (if (null repeat-template) - (walk-template stop-form (cdr template) context env) - (error "While handling repeat: - ~%~Ran into stop while still in repeat template."))) - ((null repeat-template) - (walk-template-handle-repeat-1 - form template (car template) stop-form context env)) - (t - (recons form - (walk-template (car form) (car repeat-template) context env) - (walk-template-handle-repeat-1 (cdr form) - template - (cdr repeat-template) - stop-form - context - env))))) - -(defun walk-repeat-eval (form env) - (and form - (recons form - (walk-form-internal (car form) :eval env) - (walk-repeat-eval (cdr form) env)))) - -(defun recons (x car cdr) - (if (or (not (eq (car x) car)) - (not (eq (cdr x) cdr))) - (cons car cdr) - x)) - -(defun relist (x &rest args) - (relist-internal x args nil)) - -(defun relist* (x &rest args) - (relist-internal x args 't)) - -(defun relist-internal (x args *p) - (if (null (cdr args)) - (if *p (car args) (list (car args))) - (recons x - (car args) - (relist-internal (cdr x) (cdr args) *p)))) - - - ;; -;;;;;; Special walkers - ;; - -(defun walk-declarations (body fn env - &optional doc-string-p declarations old-body - &aux (form (car body)) macrop new-form) - (cond ((and (stringp form) ;might be a doc string - (cdr body) ;isn't the returned value - (null doc-string-p) ;no doc string yet - (null declarations)) ;no declarations yet - (recons body - form - (walk-declarations (cdr body) fn env t))) - ((and (listp form) (eq (car form) 'declare)) - ;; Got ourselves a real live declaration. Record it, look for more. - (dolist (declaration (cdr form)) - (let ((type (car declaration)) - (name (cadr declaration)) - (args (cddr declaration))) - (if (member type *variable-declarations*) - (note-declaration `(,type - ,(or (variable-lexical-p name env) name) - ,.args) - env) - (note-declaration declaration env)) - (push declaration declarations))) - (recons body - form - (walk-declarations - (cdr body) fn env doc-string-p declarations))) - ((and form - (listp form) - (null (get-walker-template (car form))) - (progn - (multiple-value-setq (new-form macrop) - (macroexpand-1 form env)) - macrop)) - ;; This form was a call to a macro. Maybe it expanded - ;; into a declare? Recurse to find out. - (walk-declarations (recons body new-form (cdr body)) - fn env doc-string-p declarations - (or old-body body))) - (t - ;; Now that we have walked and recorded the declarations, - ;; call the function our caller provided to expand the body. - ;; We call that function rather than passing the real-body - ;; back, because we are RECONSING up the new body. - (funcall fn (or old-body body) env)))) - - -(defun walk-unexpected-declare (form context env) - (declare (ignore context env)) - (warn "Encountered declare ~S in a place where a declare was not expected." - form) - form) - -(defun walk-arglist (arglist context env &optional (destructuringp nil) - &aux arg) - (cond ((null arglist) ()) - ((symbolp (setq arg (car arglist))) - (or (member arg lambda-list-keywords) - (note-lexical-binding arg env)) - (recons arglist - arg - (walk-arglist (cdr arglist) - context - env - (and destructuringp - (not (member arg - lambda-list-keywords)))))) - ((consp arg) - (prog1 (if destructuringp - (walk-arglist arg context env destructuringp) - (recons arglist - (relist* arg - (car arg) - (walk-form-internal (cadr arg) :eval env) - (cddr arg)) - (walk-arglist (cdr arglist) context env nil))) - (if (symbolp (car arg)) - (note-lexical-binding (car arg) env) - (note-lexical-binding (cadar arg) env)) - (or (null (cddr arg)) - (not (symbolp (caddr arg))) - (note-lexical-binding (caddr arg) env)))) - (t - (error "Can't understand something in the arglist ~S" arglist)))) - -(defun walk-let (form context env) - (walk-let/let* form context env nil)) - -(defun walk-let* (form context env) - (walk-let/let* form context env t)) - -(defun walk-prog (form context env) - (walk-prog/prog* form context env nil)) - -(defun walk-prog* (form context env) - (walk-prog/prog* form context env t)) - -(defun walk-do (form context env) - (walk-do/do* form context env nil)) - -(defun walk-do* (form context env) - (walk-do/do* form context env t)) - -(defun walk-let/let* (form context old-env sequentialp) - (walker-environment-bind (new-env old-env) - (let* ((let/let* (car form)) - (bindings (cadr form)) - (body (cddr form)) - (walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) - (relist* - form let/let* walked-bindings walked-body)))) - -(defun walk-prog/prog* (form context old-env sequentialp) - (walker-environment-bind (new-env old-env) - (let* ((possible-block-name (second form)) - (blocked-prog (and (symbolp possible-block-name) - (not (eq possible-block-name 'nil))))) - (multiple-value-bind (let/let* block-name bindings body) - (if blocked-prog - (values (car form) (cadr form) (caddr form) (cdddr form)) - (values (car form) nil (cadr form) (cddr form))) - (let* ((walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations - body - #'(lambda (real-body real-env) - (walk-tagbody-1 real-body context real-env)) - new-env))) - (if block-name - (relist* - form let/let* block-name walked-bindings walked-body) - (relist* - form let/let* walked-bindings walked-body))))))) - -(defun walk-do/do* (form context old-env sequentialp) - (walker-environment-bind (new-env old-env) - (let* ((do/do* (car form)) - (bindings (cadr form)) - (end-test (caddr form)) - (body (cdddr form)) - (walked-bindings (walk-bindings-1 bindings - old-env - new-env - context - sequentialp)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) - (relist* form - do/do* - (walk-bindings-2 bindings walked-bindings context new-env) - (walk-template end-test '(test repeat (eval)) context new-env) - walked-body)))) - -(defun walk-let-if (form context env) - (let ((test (cadr form)) - (bindings (caddr form)) - (body (cdddr form))) - (walk-form-internal - `(let () - (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x)) - bindings))) - (flet ((.let-if-dummy. () ,@body)) - (if ,test - (let ,bindings (.let-if-dummy.)) - (.let-if-dummy.)))) - context - env))) - -(defun walk-multiple-value-bind (form context old-env) - (walker-environment-bind (new-env old-env) - (let* ((mvb (car form)) - (bindings (cadr form)) - (mv-form (walk-template (caddr form) 'eval context old-env)) - (body (cdddr form)) - walked-bindings - (walked-body - (walk-declarations - body - #'(lambda (real-body real-env) - (setq walked-bindings - (walk-bindings-1 bindings - old-env - new-env - context - nil)) - (walk-repeat-eval real-body real-env)) - new-env))) - (relist* form mvb walked-bindings mv-form walked-body)))) - -(defun walk-bindings-1 (bindings old-env new-env context sequentialp) - (and bindings - (let ((binding (car bindings))) - (recons bindings - (if (symbolp binding) - (prog1 binding - (note-lexical-binding binding new-env)) - (prog1 (relist* binding - (car binding) - (walk-form-internal (cadr binding) - context - (if sequentialp - new-env - old-env)) - (cddr binding)) ;save cddr for DO/DO* - ;it is the next value - ;form. Don't walk it - ;now though. - (note-lexical-binding (car binding) new-env))) - (walk-bindings-1 (cdr bindings) - old-env - new-env - context - sequentialp))))) - -(defun walk-bindings-2 (bindings walked-bindings context env) - (and bindings - (let ((binding (car bindings)) - (walked-binding (car walked-bindings))) - (recons bindings - (if (symbolp binding) - binding - (relist* binding - (car walked-binding) - (cadr walked-binding) - (walk-template (cddr binding) - '(eval) - context - env))) - (walk-bindings-2 (cdr bindings) - (cdr walked-bindings) - context - env))))) - -(defun walk-lambda (form context old-env) - (walker-environment-bind (new-env old-env) - (let* ((arglist (cadr form)) - (body (cddr form)) - (walked-arglist (walk-arglist arglist context new-env)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) - (relist* form - (car form) - walked-arglist - walked-body)))) - -(defun walk-named-lambda (form context old-env) - (walker-environment-bind (new-env old-env) - (let* ((name (cadr form)) - (arglist (caddr form)) - (body (cdddr form)) - (walked-arglist (walk-arglist arglist context new-env)) - (walked-body - (walk-declarations body #'walk-repeat-eval new-env))) - (relist* form - (car form) - name - walked-arglist - walked-body)))) - -(defun walk-tagbody (form context env) - (recons form (car form) (walk-tagbody-1 (cdr form) context env))) - -(defun walk-tagbody-1 (form context env) - (and form - (recons form - (walk-form-internal (car form) - (if (symbolp (car form)) 'quote context) - env) - (walk-tagbody-1 (cdr form) context env)))) - -(defun walk-compiler-let (form context old-env) - (declare (ignore context)) - (let ((vars ()) - (vals ())) - (dolist (binding (cadr form)) - (cond ((symbolp binding) (push binding vars) (push nil vals)) - (t - (push (car binding) vars) - (push (eval (cadr binding)) vals)))) - (relist* form - (car form) - (cadr form) - (progv vars vals (walk-repeat-eval (cddr form) old-env))))) - -(defun walk-macrolet (form context old-env) - (walker-environment-bind (macro-env - nil - :walk-function (env-walk-function old-env)) - (labels ((walk-definitions (definitions) - (and definitions - (let ((definition (car definitions))) - (recons definitions - (relist* definition - (car definition) - (walk-arglist (cadr definition) - context - macro-env - t) - (walk-declarations (cddr definition) - #'walk-repeat-eval - macro-env)) - (walk-definitions (cdr definitions))))))) - (with-new-definition-in-environment (new-env old-env form) - (relist* form - (car form) - (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) - -(defun walk-flet (form context old-env) - (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context old-env) - (walk-definitions (cdr definitions)))))) - (recons form - (car form) - (recons (cdr form) - (walk-definitions (cadr form)) - (with-new-definition-in-environment (new-env old-env form) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) - -(defun walk-labels (form context old-env) - (with-new-definition-in-environment (new-env old-env form) - (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context new-env) - (walk-definitions (cdr definitions)))))) - (recons form - (car form) - (recons (cdr form) - (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) - -(defun walk-if (form context env) - (let ((predicate (cadr form)) - (arm1 (caddr form)) - (arm2 - (if (cddddr form) - (progn - (warn "In the form:~%~S~%~ - IF only accepts three arguments, you are using ~D.~%~ - It is true that some Common Lisps support this, but ~ - it is not~%~ - truly legal Common Lisp. For now, this code ~ - walker is interpreting ~%~ - the extra arguments as extra else clauses. ~ - Even if this is what~%~ - you intended, you should fix your source code." - form - (length (cdr form))) - (cons 'progn (cdddr form))) - (cadddr form)))) - (relist form - 'if - (walk-form-internal predicate context env) - (walk-form-internal arm1 context env) - (walk-form-internal arm2 context env)))) - - -;;; -;;; Tests tests tests -;;; - -#| -;;; -;;; Here are some examples of the kinds of things you should be able to do -;;; with your implementation of the macroexpansion environment hacking -;;; mechanism. -;;; -;;; with-lexical-macros is kind of like macrolet, but it only takes names -;;; of the macros and actual macroexpansion functions to use to macroexpand -;;; them. The win about that is that for macros which want to wrap several -;;; macrolets around their body, they can do this but have the macroexpansion -;;; functions be compiled. See the WITH-RPUSH example. -;;; -;;; If the implementation had a special way of communicating the augmented -;;; environment back to the evaluator that would be totally great. It would -;;; mean that we could just augment the environment then pass control back -;;; to the implementations own compiler or interpreter. We wouldn't have -;;; to call the actual walker. That would make this much faster. Since the -;;; principal client of this is defmethod it would make compiling defmethods -;;; faster and that would certainly be a win. -;;; -(defmacro with-lexical-macros (macros &body body &environment old-env) - (with-augmented-environment (new-env old-env :macros macros) - (walk-form (cons 'progn body) :environment new-env))) - -(defun expand-rpush (form env) - `(push ,(caddr form) ,(cadr form))) - -(defmacro with-rpush (&body body) - `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body)) - - -;;; -;;; Unfortunately, I don't have an automatic tester for the walker. -;;; Instead there is this set of test cases with a description of -;;; how each one should go. -;;; -(defmacro take-it-out-for-a-test-walk (form) - `(take-it-out-for-a-test-walk-1 ',form)) - -(defun take-it-out-for-a-test-walk-1 (form) - (terpri) - (terpri) - (let ((copy-of-form (copy-tree form)) - (result (walk-form form nil - #'(lambda (x y env) - (format t "~&Form: ~S ~3T Context: ~A" x y) - (when (symbolp x) - (let ((lexical (variable-lexical-p x env)) - (special (variable-special-p x env))) - (when lexical - (format t ";~3T") - (format t "lexically bound")) - (when special - (format t ";~3T") - (format t "declared special")) - (when (boundp x) - (format t ";~3T") - (format t "bound: ~S " (eval x))))) - x)))) - (cond ((not (equal result copy-of-form)) - (format t "~%Warning: Result not EQUAL to copy of start.")) - ((not (eq result form)) - (format t "~%Warning: Result not EQ to copy of start."))) - (pprint result) - result)) - -(defmacro foo (&rest ignore) ''global-foo) - -(defmacro bar (&rest ignore) ''global-bar) - -(take-it-out-for-a-test-walk (list arg1 arg2 arg3)) -(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5))) - -(take-it-out-for-a-test-walk (progn (foo) (bar 1))) - -(take-it-out-for-a-test-walk (block block-name a b c)) -(take-it-out-for-a-test-walk (block block-name (list a) b c)) - -(take-it-out-for-a-test-walk (catch catch-tag (list a) b c)) -;;; -;;; This is a fairly simple macrolet case. While walking the body of the -;;; macro, x should be lexically bound. In the body of the macrolet form -;;; itself, x should not be bound. -;;; -(take-it-out-for-a-test-walk - (macrolet ((foo (x) (list x) ''inner)) - x - (foo 1))) - -;;; -;;; A slightly more complex macrolet case. In the body of the macro x -;;; should not be lexically bound. In the body of the macrolet form itself -;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it -;;; tries to macroexpand the call to foo. -;;; -(take-it-out-for-a-test-walk - (let ((x 1)) - (macrolet ((foo () (list x) ''inner)) - x - (foo)))) - -;;; -;;; A truly hairy use of compiler-let and macrolet. In the body of the -;;; macro x should not be lexically bound. In the body of the macrolet -;;; itself x should not be lexically bound. But the macro should expand -;;; into 1. -;;; -(take-it-out-for-a-test-walk - (compiler-let ((x 1)) - (let ((x 2)) - (macrolet ((foo () x)) - x - (foo))))) - - -(take-it-out-for-a-test-walk - (flet ((foo (x) (list x y)) - (bar (x) (list x y))) - (foo 1))) - -(take-it-out-for-a-test-walk - (let ((y 2)) - (flet ((foo (x) (list x y)) - (bar (x) (list x y))) - (foo 1)))) - -(take-it-out-for-a-test-walk - (labels ((foo (x) (bar x)) - (bar (x) (foo x))) - (foo 1))) - -(take-it-out-for-a-test-walk - (flet ((foo (x) (foo x))) - (foo 1))) - -(take-it-out-for-a-test-walk - (flet ((foo (x) (foo x))) - (flet ((bar (x) (foo x))) - (bar 1)))) - -(take-it-out-for-a-test-walk (compiler-let ((a 1) (b 2)) (foo a) b)) -(take-it-out-for-a-test-walk (prog () (declare (special a b)))) -(take-it-out-for-a-test-walk (let (a b c) - (declare (special a b)) - (foo a) b c)) -(take-it-out-for-a-test-walk (let (a b c) - (declare (special a) (special b)) - (foo a) b c)) -(take-it-out-for-a-test-walk (let (a b c) - (declare (special a)) - (declare (special b)) - (foo a) b c)) -(take-it-out-for-a-test-walk (let (a b c) - (declare (special a)) - (declare (special b)) - (let ((a 1)) - (foo a) b c))) -(take-it-out-for-a-test-walk (eval-when () - a - (foo a))) -(take-it-out-for-a-test-walk (eval-when (eval when load) - a - (foo a))) - -(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b))) -(take-it-out-for-a-test-walk (multiple-value-bind (a b) - (foo a b) - (declare (special a)) - (list a b))) -(take-it-out-for-a-test-walk (progn (function foo))) -(take-it-out-for-a-test-walk (progn a b (go a))) -(take-it-out-for-a-test-walk (if a b c)) -(take-it-out-for-a-test-walk (if a b)) -(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2)) -(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b)) - 1 2)) -(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c))) -(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c))) -(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) - (declare (special a b)) - (list a b c))) -(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) - (declare (special a b)) - (list a b c))) -(take-it-out-for-a-test-walk (let ((a 1) (b 2)) - (foo bar) - (declare (special a)) - (foo a b))) -(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c)) -(take-it-out-for-a-test-walk (multiple-value-prog1 a b c)) -(take-it-out-for-a-test-walk (progn a b c)) -(take-it-out-for-a-test-walk (progv vars vals a b c)) -(take-it-out-for-a-test-walk (quote a)) -(take-it-out-for-a-test-walk (return-from block-name a b c)) -(take-it-out-for-a-test-walk (setq a 1)) -(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3)) -(take-it-out-for-a-test-walk (tagbody a b c (go a))) -(take-it-out-for-a-test-walk (the foo (foo-form a b c))) -(take-it-out-for-a-test-walk (throw tag-form a)) -(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f)) - -(defmacro flet-1 (a b) ''outer) -(defmacro labels-1 (a b) ''outer) - -(take-it-out-for-a-test-walk - (flet ((flet-1 (a b) () (flet-1 a b) (list a b))) - (flet-1 1 2) - (foo 1 2))) -(take-it-out-for-a-test-walk - (labels ((label-1 (a b) () (label-1 a b)(list a b))) - (label-1 1 2) - (foo 1 2))) -(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b))) - (macrolet-1 a b) - (foo 1 2))) - -(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a))) - (foo 1))) - -(take-it-out-for-a-test-walk (progn (bar 1) - (macrolet ((bar (a) - `(inner-bar-expanded ,a))) - (bar 2)))) - -(take-it-out-for-a-test-walk (progn (bar 1) - (macrolet ((bar (s) - (bar s) - `(inner-bar-expanded ,s))) - (bar 2)))) - -(take-it-out-for-a-test-walk (cond (a b) - ((foo bar) a (foo a)))) - - -(let ((the-lexical-variables ())) - (walk-form '(let ((a 1) (b 2)) - #'(lambda (x) (list a b x y))) - () - #'(lambda (form context env) - (when (and (symbolp form) - (variable-lexical-p form env)) - (push form the-lexical-variables)) - form)) - (or (and (= (length the-lexical-variables) 3) - (member 'a the-lexical-variables) - (member 'b the-lexical-variables) - (member 'x the-lexical-variables)) - (error "Walker didn't do lexical variables of a closure properly."))) - -|# - -() diff --git a/obsolete/clos/2.01big/CLOS-BROWSER.TEDIT b/obsolete/clos/2.01big/CLOS-BROWSER.TEDIT deleted file mode 100644 index 21d02b63..00000000 Binary files a/obsolete/clos/2.01big/CLOS-BROWSER.TEDIT and /dev/null differ diff --git a/obsolete/clos/2.01big/NEW-CLOS-BROWSER.DFASL b/obsolete/clos/2.01big/NEW-CLOS-BROWSER.DFASL deleted file mode 100644 index 1add0989..00000000 Binary files a/obsolete/clos/2.01big/NEW-CLOS-BROWSER.DFASL and /dev/null differ diff --git a/obsolete/clos/2.01big/WEB-EDITOR.DFASL b/obsolete/clos/2.01big/WEB-EDITOR.DFASL deleted file mode 100644 index 677def40..00000000 Binary files a/obsolete/clos/2.01big/WEB-EDITOR.DFASL and /dev/null differ diff --git a/obsolete/clos/2.01big/boot.dfasl b/obsolete/clos/2.01big/boot.dfasl deleted file mode 100644 index 06971f5f..00000000 Binary files a/obsolete/clos/2.01big/boot.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/braid.dfasl b/obsolete/clos/2.01big/braid.dfasl deleted file mode 100644 index 6d0d54fa..00000000 Binary files a/obsolete/clos/2.01big/braid.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/cache.dfasl b/obsolete/clos/2.01big/cache.dfasl deleted file mode 100644 index 2371e8e0..00000000 Binary files a/obsolete/clos/2.01big/cache.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/clos-env-internal.DFASL b/obsolete/clos/2.01big/clos-env-internal.DFASL deleted file mode 100644 index 3f4811d6..00000000 Binary files a/obsolete/clos/2.01big/clos-env-internal.DFASL and /dev/null differ diff --git a/obsolete/clos/2.01big/clos-env.DFASL b/obsolete/clos/2.01big/clos-env.DFASL deleted file mode 100644 index 34289504..00000000 Binary files a/obsolete/clos/2.01big/clos-env.DFASL and /dev/null differ diff --git a/obsolete/clos/2.01big/combin.dfasl b/obsolete/clos/2.01big/combin.dfasl deleted file mode 100644 index d5810482..00000000 Binary files a/obsolete/clos/2.01big/combin.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/compat.dfasl b/obsolete/clos/2.01big/compat.dfasl deleted file mode 100644 index f0bae057..00000000 Binary files a/obsolete/clos/2.01big/compat.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/construct.dfasl b/obsolete/clos/2.01big/construct.dfasl deleted file mode 100644 index fd30ec49..00000000 Binary files a/obsolete/clos/2.01big/construct.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/cpl.dfasl b/obsolete/clos/2.01big/cpl.dfasl deleted file mode 100644 index e4334140..00000000 Binary files a/obsolete/clos/2.01big/cpl.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/ctypes.dfasl b/obsolete/clos/2.01big/ctypes.dfasl deleted file mode 100644 index aea567f5..00000000 Binary files a/obsolete/clos/2.01big/ctypes.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/defclass.dfasl b/obsolete/clos/2.01big/defclass.dfasl deleted file mode 100644 index 7a37b676..00000000 Binary files a/obsolete/clos/2.01big/defclass.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/defcombin.dfasl b/obsolete/clos/2.01big/defcombin.dfasl deleted file mode 100644 index 3dd0d755..00000000 Binary files a/obsolete/clos/2.01big/defcombin.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/defs.dfasl b/obsolete/clos/2.01big/defs.dfasl deleted file mode 100644 index 1684e017..00000000 Binary files a/obsolete/clos/2.01big/defs.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/defsys.DFASL b/obsolete/clos/2.01big/defsys.DFASL deleted file mode 100644 index 748c1593..00000000 Binary files a/obsolete/clos/2.01big/defsys.DFASL and /dev/null differ diff --git a/obsolete/clos/2.01big/dfun.dfasl b/obsolete/clos/2.01big/dfun.dfasl deleted file mode 100644 index 035d479a..00000000 Binary files a/obsolete/clos/2.01big/dfun.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/dlap.dfasl b/obsolete/clos/2.01big/dlap.dfasl deleted file mode 100644 index cf52e2b1..00000000 Binary files a/obsolete/clos/2.01big/dlap.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/env.dfasl b/obsolete/clos/2.01big/env.dfasl deleted file mode 100644 index decb1a80..00000000 Binary files a/obsolete/clos/2.01big/env.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/fin.dfasl b/obsolete/clos/2.01big/fin.dfasl deleted file mode 100644 index 715e2d29..00000000 Binary files a/obsolete/clos/2.01big/fin.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/fixup.dfasl b/obsolete/clos/2.01big/fixup.dfasl deleted file mode 100644 index 2f111caf..00000000 Binary files a/obsolete/clos/2.01big/fixup.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/fngen.dfasl b/obsolete/clos/2.01big/fngen.dfasl deleted file mode 100644 index 81212cd5..00000000 Binary files a/obsolete/clos/2.01big/fngen.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/fsc.dfasl b/obsolete/clos/2.01big/fsc.dfasl deleted file mode 100644 index fff65ea9..00000000 Binary files a/obsolete/clos/2.01big/fsc.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/init.dfasl b/obsolete/clos/2.01big/init.dfasl deleted file mode 100644 index ae72d647..00000000 Binary files a/obsolete/clos/2.01big/init.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/iterate.dfasl b/obsolete/clos/2.01big/iterate.dfasl deleted file mode 100644 index ed34b9aa..00000000 Binary files a/obsolete/clos/2.01big/iterate.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/lap.dfasl b/obsolete/clos/2.01big/lap.dfasl deleted file mode 100644 index f587ef04..00000000 Binary files a/obsolete/clos/2.01big/lap.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/load-clos.lisp b/obsolete/clos/2.01big/load-clos.lisp deleted file mode 100644 index 8ba7e9a2..00000000 --- a/obsolete/clos/2.01big/load-clos.lisp +++ /dev/null @@ -1,42 +0,0 @@ -;;; -*- Mode: Lisp; Package: xcl-User ; Base: 10.; Syntax: Common-Lisp -*- -;;; - -(in-package "CLOS" :use (list (or (find-package :walker) - (make-package :walker :use '(:lisp))) - (or (find-package :iterate) - (make-package :iterate - :use '(:lisp :walker))) - (find-package :lisp))) -(export (intern (symbol-name :iterate) ;Have to do this here, - (find-package :iterate)) ;because in the defsystem - (find-package :iterate)) ;(later in this file) - ;we use the symbol iterate - ;to name the file - -(defun load-truename (&optional (errorp nil)) - (flet ((bad-time () - (when errorp - (error "LOAD-TRUENAME called but a file isn't being loaded.")))) - (let ((filename (pathname (il:fullname *standard-input*)))) - (if filename - (make-pathname :host (pathname-host filename) :device - (pathname-device filename) :directory - (pathname-directory filename) :name "") - (bad-time))))) - -(defvar *clos-directory* (load-truename)) - -(defun load-clos (&optional pathname) - (defvar *clos-system-date* "7/14/91 Medley 2.0 (interim)") - (defvar *the-clos-package* (find-package :clos)) - (dolist (filename '(patch pkg walk iterate macros low low2 fin - defclass defs fngen lap plap cache dlap boot - vector slots init std-class cpl braid fsc methods - combin dfun precom1 precom2 precom4 fixup - defcombin ctypes construct env)) - - (load (merge-pathnames - (make-pathname :name (string-downcase filename) :type - "dfasl") (or pathname *clos-directory*)))) - (pushnew :clos cl:*features*)) - diff --git a/obsolete/clos/2.01big/low.dfasl b/obsolete/clos/2.01big/low.dfasl deleted file mode 100644 index 7ba900eb..00000000 Binary files a/obsolete/clos/2.01big/low.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/low2.dfasl b/obsolete/clos/2.01big/low2.dfasl deleted file mode 100644 index f0e021c7..00000000 Binary files a/obsolete/clos/2.01big/low2.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/macros.dfasl b/obsolete/clos/2.01big/macros.dfasl deleted file mode 100644 index c5900f91..00000000 Binary files a/obsolete/clos/2.01big/macros.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/methods.dfasl b/obsolete/clos/2.01big/methods.dfasl deleted file mode 100644 index 0d99a4ea..00000000 Binary files a/obsolete/clos/2.01big/methods.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/patch.dfasl b/obsolete/clos/2.01big/patch.dfasl deleted file mode 100644 index 23d002f8..00000000 Binary files a/obsolete/clos/2.01big/patch.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/pkg.dfasl b/obsolete/clos/2.01big/pkg.dfasl deleted file mode 100644 index 01eb5465..00000000 Binary files a/obsolete/clos/2.01big/pkg.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/plap.dfasl b/obsolete/clos/2.01big/plap.dfasl deleted file mode 100644 index a0e96c70..00000000 Binary files a/obsolete/clos/2.01big/plap.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/precom1.dfasl b/obsolete/clos/2.01big/precom1.dfasl deleted file mode 100644 index 13c3abd2..00000000 Binary files a/obsolete/clos/2.01big/precom1.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/precom2.dfasl b/obsolete/clos/2.01big/precom2.dfasl deleted file mode 100644 index 633f8e42..00000000 Binary files a/obsolete/clos/2.01big/precom2.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/precom4.dfasl b/obsolete/clos/2.01big/precom4.dfasl deleted file mode 100644 index f547707d..00000000 Binary files a/obsolete/clos/2.01big/precom4.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/slots.dfasl b/obsolete/clos/2.01big/slots.dfasl deleted file mode 100644 index ef784156..00000000 Binary files a/obsolete/clos/2.01big/slots.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/std-class.dfasl b/obsolete/clos/2.01big/std-class.dfasl deleted file mode 100644 index 818e18c8..00000000 Binary files a/obsolete/clos/2.01big/std-class.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/vector.dfasl b/obsolete/clos/2.01big/vector.dfasl deleted file mode 100644 index 71697f84..00000000 Binary files a/obsolete/clos/2.01big/vector.dfasl and /dev/null differ diff --git a/obsolete/clos/2.01big/walk.dfasl b/obsolete/clos/2.01big/walk.dfasl deleted file mode 100644 index 93c99e8f..00000000 Binary files a/obsolete/clos/2.01big/walk.dfasl and /dev/null differ diff --git a/obsolete/fonts/xerox/FlemishScriptII.wd.Z b/obsolete/fonts/xerox/FlemishScriptII.wd.Z deleted file mode 100644 index 52d09c10..00000000 Binary files a/obsolete/fonts/xerox/FlemishScriptII.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Helvetica.Bold.Italic.cd.Z b/obsolete/fonts/xerox/Helvetica.Bold.Italic.cd.Z deleted file mode 100644 index e3106f24..00000000 Binary files a/obsolete/fonts/xerox/Helvetica.Bold.Italic.cd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Helvetica.Bold.cd.Z b/obsolete/fonts/xerox/Helvetica.Bold.cd.Z deleted file mode 100644 index 0fbab49b..00000000 Binary files a/obsolete/fonts/xerox/Helvetica.Bold.cd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Helvetica.Italic.cd.Z b/obsolete/fonts/xerox/Helvetica.Italic.cd.Z deleted file mode 100644 index bb58ec0a..00000000 Binary files a/obsolete/fonts/xerox/Helvetica.Italic.cd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Helvetica.cd.Z b/obsolete/fonts/xerox/Helvetica.cd.Z deleted file mode 100644 index 81c1873a..00000000 Binary files a/obsolete/fonts/xerox/Helvetica.cd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus.wd.Z b/obsolete/fonts/xerox/ITCBauhaus.wd.Z deleted file mode 100644 index 333a6174..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus10-C0.DISPLAYFONT.Z b/obsolete/fonts/xerox/ITCBauhaus10-C0.DISPLAYFONT.Z deleted file mode 100644 index 6053d463..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus10-C0.DISPLAYFONT.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus10-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus10-C0.wd.Z deleted file mode 100644 index 333a6174..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus10-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus12-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus12-C0.wd.Z deleted file mode 100644 index 333a6174..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus12-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus14-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus14-C0.wd.Z deleted file mode 100644 index 333a6174..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus14-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus18-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus18-C0.wd.Z deleted file mode 100644 index 333a6174..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus18-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus24-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus24-C0.wd.Z deleted file mode 100644 index 333a6174..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus24-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus6-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus6-C0.wd.Z deleted file mode 100644 index 333a6174..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus6-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCBauhaus8-C0.wd.Z b/obsolete/fonts/xerox/ITCBauhaus8-C0.wd.Z deleted file mode 100644 index 333a6174..00000000 Binary files a/obsolete/fonts/xerox/ITCBauhaus8-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCCushing.wd.Z b/obsolete/fonts/xerox/ITCCushing.wd.Z deleted file mode 100644 index d3be7bac..00000000 Binary files a/obsolete/fonts/xerox/ITCCushing.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond.wd.Z b/obsolete/fonts/xerox/ITCGaramond.wd.Z deleted file mode 100644 index d535b574..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond11-C0.ac.Z b/obsolete/fonts/xerox/ITCGaramond11-C0.ac.Z deleted file mode 100644 index fb85bde7..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond11-C0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond11MRR72C0.ac.Z b/obsolete/fonts/xerox/ITCGaramond11MRR72C0.ac.Z deleted file mode 100644 index fb85bde7..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond11MRR72C0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c0.ac.Z deleted file mode 100644 index 45e9eb07..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c356.ac.Z deleted file mode 100644 index 1fb6daa5..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c357.ac.Z deleted file mode 100644 index 9b1917a9..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c360.ac.Z deleted file mode 100644 index cff07a31..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c361.ac.Z deleted file mode 100644 index a207f341..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-I-c41.ac.Z deleted file mode 100644 index 7d965eef..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c0.ac.Z deleted file mode 100644 index e2cbd66c..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c356.ac.Z deleted file mode 100644 index 4e1279c0..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c357.ac.Z deleted file mode 100644 index f21b1f7c..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c360.ac.Z deleted file mode 100644 index c74d19e9..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c361.ac.Z deleted file mode 100644 index e6f76634..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-B-c41.ac.Z deleted file mode 100644 index 5a50d677..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-B-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c0.ac.Z deleted file mode 100644 index 72dd024c..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c356.ac.Z deleted file mode 100644 index f2117fde..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c357.ac.Z deleted file mode 100644 index b4eddb3c..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c360.ac.Z deleted file mode 100644 index d1d6f897..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c361.ac.Z deleted file mode 100644 index 7d239bda..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-I-c41.ac.Z deleted file mode 100644 index 8c1cd383..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c0.ac.Z deleted file mode 100644 index 2beacb8b..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c356.ac.Z deleted file mode 100644 index 7941fd50..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c357.ac.Z deleted file mode 100644 index 771d5a94..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c360.ac.Z deleted file mode 100644 index 34e2bf98..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c361.ac.Z deleted file mode 100644 index e1c06c38..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond12-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond12-c41.ac.Z deleted file mode 100644 index d832ba8b..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond12-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c0.ac.Z deleted file mode 100644 index c5e2cfac..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c356.ac.Z deleted file mode 100644 index bbb594c9..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c357.ac.Z deleted file mode 100644 index c0123407..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c360.ac.Z deleted file mode 100644 index 970e5718..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c361.ac.Z deleted file mode 100644 index 10a6c9a6..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-I-c41.ac.Z deleted file mode 100644 index ea5552d4..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c0.ac.Z deleted file mode 100644 index cc380da7..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c356.ac.Z deleted file mode 100644 index dceacdd1..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c357.ac.Z deleted file mode 100644 index 92211e14..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c360.ac.Z deleted file mode 100644 index f217ffe4..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c361.ac.Z deleted file mode 100644 index b23504bc..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-B-c41.ac.Z deleted file mode 100644 index 04b46936..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-B-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c0.ac.Z deleted file mode 100644 index c87c32a8..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c356.ac.Z deleted file mode 100644 index c65ed3a9..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c357.ac.Z deleted file mode 100644 index 26c056d5..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c360.ac.Z deleted file mode 100644 index 040e6d9e..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c361.ac.Z deleted file mode 100644 index 7112678f..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-I-c41.ac.Z deleted file mode 100644 index 9bc70c8b..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c0.ac.Z deleted file mode 100644 index e21df0e4..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c356.ac.Z deleted file mode 100644 index d4681ba2..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c357.ac.Z deleted file mode 100644 index 7c5a2761..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c360.ac.Z deleted file mode 100644 index c4722627..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c361.ac.Z deleted file mode 100644 index 55cefc3d..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond14-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond14-c41.ac.Z deleted file mode 100644 index cee5f116..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond14-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c0.ac.Z deleted file mode 100644 index 0dc26d37..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c356.ac.Z deleted file mode 100644 index de8f6ea2..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c357.ac.Z deleted file mode 100644 index 73000d84..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c360.ac.Z deleted file mode 100644 index 63f9a8c9..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c361.ac.Z deleted file mode 100644 index 7e3922ab..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-I-c41.ac.Z deleted file mode 100644 index 3b64e5dc..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c0.ac.Z deleted file mode 100644 index 6865dd3c..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c356.ac.Z deleted file mode 100644 index b85671b6..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c357.ac.Z deleted file mode 100644 index 874c499b..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c360.ac.Z deleted file mode 100644 index 7d598976..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c361.ac.Z deleted file mode 100644 index f8c8ef74..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-B-c41.ac.Z deleted file mode 100644 index 7df9dd52..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-B-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c0.ac.Z deleted file mode 100644 index 90dc8a33..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c356.ac.Z deleted file mode 100644 index 068da7c1..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c357.ac.Z deleted file mode 100644 index 6052cdd5..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c360.ac.Z deleted file mode 100644 index 9fc95f7c..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c361.ac.Z deleted file mode 100644 index a03c4bf2..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-I-c41.ac.Z deleted file mode 100644 index d9550299..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c0.ac.Z deleted file mode 100644 index 33bfdfab..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c356.ac.Z deleted file mode 100644 index 030e8730..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c357.ac.Z deleted file mode 100644 index 36560326..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c360.ac.Z deleted file mode 100644 index 6acb6580..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c361.ac.Z deleted file mode 100644 index 48891c2f..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond18-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond18-c41.ac.Z deleted file mode 100644 index e29fee37..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond18-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c0.ac.Z deleted file mode 100644 index add1317f..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c356.ac.Z deleted file mode 100644 index eabf7ac2..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c357.ac.Z deleted file mode 100644 index 991e23a4..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c360.ac.Z deleted file mode 100644 index 1a9909b6..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c361.ac.Z deleted file mode 100644 index 095cbd60..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-I-c41.ac.Z deleted file mode 100644 index 712612ee..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c0.ac.Z deleted file mode 100644 index 41035a44..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c356.ac.Z deleted file mode 100644 index 5a5f8624..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c357.ac.Z deleted file mode 100644 index a0d8b60a..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c360.ac.Z deleted file mode 100644 index a8dd2c29..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c361.ac.Z deleted file mode 100644 index 53eb96e4..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-B-c41.ac.Z deleted file mode 100644 index 705a6d6e..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-B-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c0.ac.Z deleted file mode 100644 index 253d8e75..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c356.ac.Z deleted file mode 100644 index 07391653..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c357.ac.Z deleted file mode 100644 index 0dcd7d76..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c360.ac.Z deleted file mode 100644 index f583e983..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c361.ac.Z deleted file mode 100644 index 80fedc21..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-I-c41.ac.Z deleted file mode 100644 index 62d2c358..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-c0.ac.Z deleted file mode 100644 index 98e31c3a..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond24-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond24-c356.ac.Z deleted file mode 100644 index 3e253bfc..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond24-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c0.ac.Z deleted file mode 100644 index 221425d2..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c356.ac.Z deleted file mode 100644 index c2fe1db8..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c357.ac.Z deleted file mode 100644 index 1bfec6f1..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c360.ac.Z deleted file mode 100644 index ef2fad40..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c361.ac.Z deleted file mode 100644 index 6dc98ac4..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-I-c41.ac.Z deleted file mode 100644 index ff93943c..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c0.ac.Z deleted file mode 100644 index 5f955ff6..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c356.ac.Z deleted file mode 100644 index 2e7337a6..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c357.ac.Z deleted file mode 100644 index 36cbc9e2..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c360.ac.Z deleted file mode 100644 index 2070f7a7..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c361.ac.Z deleted file mode 100644 index e5acedf2..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-B-c41.ac.Z deleted file mode 100644 index 8455010f..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-B-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c0.ac.Z deleted file mode 100644 index 66fe0025..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c356.ac.Z deleted file mode 100644 index 20460502..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c357.ac.Z deleted file mode 100644 index 6681f4d7..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c360.ac.Z deleted file mode 100644 index d053bd42..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c361.ac.Z deleted file mode 100644 index cefca376..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-I-c41.ac.Z deleted file mode 100644 index f2a32894..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c356.ac.Z deleted file mode 100644 index 2ff79b89..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c357.ac.Z deleted file mode 100644 index a0dc6681..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c360.ac.Z deleted file mode 100644 index 8279eb35..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c361.ac.Z deleted file mode 100644 index 9ef60df8..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond30-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond30-c41.ac.Z deleted file mode 100644 index 21eb2134..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond30-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c0.ac.Z deleted file mode 100644 index 4fe8ccff..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c356.ac.Z deleted file mode 100644 index 94be34d3..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c357.ac.Z deleted file mode 100644 index 96a778ce..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c360.ac.Z deleted file mode 100644 index deb04f24..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c361.ac.Z deleted file mode 100644 index 67b8d99b..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-I-c41.ac.Z deleted file mode 100644 index a9673e1c..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c0.ac.Z deleted file mode 100644 index ae4c196b..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c356.ac.Z deleted file mode 100644 index 7e3040d8..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c357.ac.Z deleted file mode 100644 index 2c7380c5..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c360.ac.Z deleted file mode 100644 index 7afa5f2d..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c361.ac.Z deleted file mode 100644 index c656d8bb..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-B-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-B-c41.ac.Z deleted file mode 100644 index 4aafb785..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-B-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c0.ac.Z deleted file mode 100644 index ff1c8bc9..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c356.ac.Z deleted file mode 100644 index 96391829..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c357.ac.Z deleted file mode 100644 index 5832dbc6..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c360.ac.Z deleted file mode 100644 index d6229cb3..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c361.ac.Z deleted file mode 100644 index 1d528db1..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-I-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-I-c41.ac.Z deleted file mode 100644 index aba4b8f7..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-I-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-c0.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c0.ac.Z deleted file mode 100644 index 2a64e8f9..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-c0.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-c356.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c356.ac.Z deleted file mode 100644 index 1296250e..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-c356.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-c357.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c357.ac.Z deleted file mode 100644 index 37c96ed7..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-c357.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-c360.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c360.ac.Z deleted file mode 100644 index a0f04688..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-c360.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-c361.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c361.ac.Z deleted file mode 100644 index 5c192ef7..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-c361.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ITCGaramond36-c41.ac.Z b/obsolete/fonts/xerox/ITCGaramond36-c41.ac.Z deleted file mode 100644 index d767985e..00000000 Binary files a/obsolete/fonts/xerox/ITCGaramond36-c41.ac.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Logo1.wd.Z b/obsolete/fonts/xerox/Logo1.wd.Z deleted file mode 100644 index 54e8726b..00000000 Binary files a/obsolete/fonts/xerox/Logo1.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C0.wd.Z deleted file mode 100644 index 4b30e124..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C356.wd.Z deleted file mode 100644 index aaeff29c..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C357.wd.Z deleted file mode 100644 index eb9d6d06..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C360.wd.Z deleted file mode 100644 index 0ec03c10..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C361.wd.Z deleted file mode 100644 index dfd7b2e3..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C41.wd.Z deleted file mode 100644 index 6142d5f8..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C42.wd.Z deleted file mode 100644 index d63e9421..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima06-BIR-C43.wd.Z deleted file mode 100644 index 2dd8aae5..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C0.wd.Z deleted file mode 100644 index e678c10c..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C356.wd.Z deleted file mode 100644 index 224abb6e..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C357.wd.Z deleted file mode 100644 index 8aa5cd20..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C360.wd.Z deleted file mode 100644 index d7c50952..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C361.wd.Z deleted file mode 100644 index 41995838..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C41.wd.Z deleted file mode 100644 index 8adf037c..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C42.wd.Z deleted file mode 100644 index f2aa3a91..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima06-BRR-C43.wd.Z deleted file mode 100644 index 225b0585..00000000 Binary files a/obsolete/fonts/xerox/Optima06-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C0.wd.Z deleted file mode 100644 index 851964f6..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C356.wd.Z deleted file mode 100644 index 13c9d752..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C357.wd.Z deleted file mode 100644 index 5a6e2893..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C360.wd.Z deleted file mode 100644 index 2d54f0ee..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C361.wd.Z deleted file mode 100644 index c4e57029..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C41.wd.Z deleted file mode 100644 index bf21c2b1..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C42.wd.Z deleted file mode 100644 index 7f14b0f4..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima06-MIR-C43.wd.Z deleted file mode 100644 index 17bbef89..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C0.wd.Z deleted file mode 100644 index 13bafc69..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C356.wd.Z deleted file mode 100644 index 78db5164..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C357.wd.Z deleted file mode 100644 index 9734d009..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C360.wd.Z deleted file mode 100644 index b3e72dcc..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C361.wd.Z deleted file mode 100644 index 141c4c62..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C41.wd.Z deleted file mode 100644 index 95a5a463..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C42.wd.Z deleted file mode 100644 index 6257198b..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima06-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima06-MRR-C43.wd.Z deleted file mode 100644 index ab5a661c..00000000 Binary files a/obsolete/fonts/xerox/Optima06-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C0.wd.Z deleted file mode 100644 index 392220ed..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C356.wd.Z deleted file mode 100644 index f694754d..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C357.wd.Z deleted file mode 100644 index 2619347f..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C360.wd.Z deleted file mode 100644 index d52c40fa..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C361.wd.Z deleted file mode 100644 index 30dd0f9f..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C41.wd.Z deleted file mode 100644 index c17d6ab2..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C42.wd.Z deleted file mode 100644 index d0e9ab50..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima07-BIR-C43.wd.Z deleted file mode 100644 index e42095e1..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C0.wd.Z deleted file mode 100644 index cc6adc69..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C356.wd.Z deleted file mode 100644 index 1586b2e2..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C357.wd.Z deleted file mode 100644 index 69ba5d6e..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C360.wd.Z deleted file mode 100644 index f318ae18..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C361.wd.Z deleted file mode 100644 index 2a02146f..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C41.wd.Z deleted file mode 100644 index 277c6e3d..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C42.wd.Z deleted file mode 100644 index 4b88cb54..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima07-BRR-C43.wd.Z deleted file mode 100644 index 67e9552c..00000000 Binary files a/obsolete/fonts/xerox/Optima07-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C0.wd.Z deleted file mode 100644 index cb69ab21..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C356.wd.Z deleted file mode 100644 index aee6efe4..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C357.wd.Z deleted file mode 100644 index c2ceac3c..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C360.wd.Z deleted file mode 100644 index 6a7f7b76..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C361.wd.Z deleted file mode 100644 index 78683be0..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C41.wd.Z deleted file mode 100644 index 5bda30c2..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C42.wd.Z deleted file mode 100644 index fa45e730..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima07-MIR-C43.wd.Z deleted file mode 100644 index 92e65aae..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C0.wd.Z deleted file mode 100644 index 9b1fe80f..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C356.wd.Z deleted file mode 100644 index ec943065..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C357.wd.Z deleted file mode 100644 index 9d025257..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C360.wd.Z deleted file mode 100644 index 8e20c318..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C361.wd.Z deleted file mode 100644 index c6661dd0..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C41.wd.Z deleted file mode 100644 index 3089ebe7..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C42.wd.Z deleted file mode 100644 index 58f54ca7..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima07-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima07-MRR-C43.wd.Z deleted file mode 100644 index 95ccddbf..00000000 Binary files a/obsolete/fonts/xerox/Optima07-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C0.wd.Z deleted file mode 100644 index d83e658c..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C356.wd.Z deleted file mode 100644 index 3ec89fc0..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C357.wd.Z deleted file mode 100644 index 33fab467..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C360.wd.Z deleted file mode 100644 index 2f288a0e..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C361.wd.Z deleted file mode 100644 index 5ce7100f..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C41.wd.Z deleted file mode 100644 index e1625c81..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C42.wd.Z deleted file mode 100644 index faa99bc3..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima08-BIR-C43.wd.Z deleted file mode 100644 index 038a0d9d..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C0.wd.Z deleted file mode 100644 index e789ee49..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C356.wd.Z deleted file mode 100644 index d7969a23..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C357.wd.Z deleted file mode 100644 index d5a23ff3..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C360.wd.Z deleted file mode 100644 index b944a223..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C361.wd.Z deleted file mode 100644 index 86c4704e..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C41.wd.Z deleted file mode 100644 index d30f68ef..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C42.wd.Z deleted file mode 100644 index cf016b03..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima08-BRR-C43.wd.Z deleted file mode 100644 index 6c4d0445..00000000 Binary files a/obsolete/fonts/xerox/Optima08-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C0.wd.Z deleted file mode 100644 index 4422e7f9..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C356.wd.Z deleted file mode 100644 index abd7f15f..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C357.wd.Z deleted file mode 100644 index 99b78bcc..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C360.wd.Z deleted file mode 100644 index 95f94777..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C361.wd.Z deleted file mode 100644 index 794b6152..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C41.wd.Z deleted file mode 100644 index 8de1e75a..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C42.wd.Z deleted file mode 100644 index 7cabc977..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima08-MIR-C43.wd.Z deleted file mode 100644 index dde1407b..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C0.wd.Z deleted file mode 100644 index 21449490..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C356.wd.Z deleted file mode 100644 index 25eb065e..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C357.wd.Z deleted file mode 100644 index 379c26a4..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C360.wd.Z deleted file mode 100644 index d7861326..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C361.wd.Z deleted file mode 100644 index 06f45ced..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C41.wd.Z deleted file mode 100644 index baafd8f8..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C42.wd.Z deleted file mode 100644 index 95eba98d..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima08-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima08-MRR-C43.wd.Z deleted file mode 100644 index d3ef2c5b..00000000 Binary files a/obsolete/fonts/xerox/Optima08-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C0.wd.Z deleted file mode 100644 index 19dc6f86..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C356.wd.Z deleted file mode 100644 index 20b8ad7c..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C357.wd.Z deleted file mode 100644 index 8742fb7a..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C360.wd.Z deleted file mode 100644 index 1631c149..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C361.wd.Z deleted file mode 100644 index 159a1dc6..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C41.wd.Z deleted file mode 100644 index b405836f..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C42.wd.Z deleted file mode 100644 index fa504ac5..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima09-BIR-C43.wd.Z deleted file mode 100644 index 7c1f5f34..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C0.wd.Z deleted file mode 100644 index 5eca9f1e..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C356.wd.Z deleted file mode 100644 index 56d11d92..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C357.wd.Z deleted file mode 100644 index 49f5990f..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C360.wd.Z deleted file mode 100644 index fdf13e83..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C361.wd.Z deleted file mode 100644 index 128be853..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C41.wd.Z deleted file mode 100644 index 52c64d3e..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C42.wd.Z deleted file mode 100644 index 58d7f20e..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima09-BRR-C43.wd.Z deleted file mode 100644 index dbfc9b79..00000000 Binary files a/obsolete/fonts/xerox/Optima09-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C0.wd.Z deleted file mode 100644 index 629049ec..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C356.wd.Z deleted file mode 100644 index 605f4f91..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C357.wd.Z deleted file mode 100644 index e524bdab..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C360.wd.Z deleted file mode 100644 index 80a3a47b..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C361.wd.Z deleted file mode 100644 index c2a58ad2..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C41.wd.Z deleted file mode 100644 index df88c545..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C42.wd.Z deleted file mode 100644 index a039faca..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima09-MIR-C43.wd.Z deleted file mode 100644 index 42efc235..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C0.wd.Z deleted file mode 100644 index 341b93ae..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C356.wd.Z deleted file mode 100644 index 3a001681..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C357.wd b/obsolete/fonts/xerox/Optima09-MRR-C357.wd deleted file mode 100644 index 32453eb0..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C357.wd and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C357.wd.Z deleted file mode 100644 index ae0492fc..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C360.wd.Z deleted file mode 100644 index ca260877..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C361.wd.Z deleted file mode 100644 index e2435861..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C41.wd.Z deleted file mode 100644 index c189e6f3..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C42.wd.Z deleted file mode 100644 index 302911c8..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima09-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima09-MRR-C43.wd.Z deleted file mode 100644 index 21545185..00000000 Binary files a/obsolete/fonts/xerox/Optima09-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C0.wd.Z deleted file mode 100644 index 6ebb2335..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C356.wd.Z deleted file mode 100644 index 1502f3a6..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C357.wd.Z deleted file mode 100644 index 4eb51521..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C360.wd.Z deleted file mode 100644 index 848714ad..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C361.wd.Z deleted file mode 100644 index 7fb26430..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C41.wd.Z deleted file mode 100644 index d025e704..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C42.wd.Z deleted file mode 100644 index 7e164fc3..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima10-BIR-C43.wd.Z deleted file mode 100644 index c911ceeb..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C0.wd.Z deleted file mode 100644 index 01af4d2b..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C356.wd.Z deleted file mode 100644 index f8cb632d..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C357.wd.Z deleted file mode 100644 index ac7ec290..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C360.wd.Z deleted file mode 100644 index 812a004a..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C361.wd.Z deleted file mode 100644 index 53d8fd49..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C41.wd.Z deleted file mode 100644 index 8c2a3c10..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C42.wd.Z deleted file mode 100644 index 94556645..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima10-BRR-C43.wd.Z deleted file mode 100644 index 9b9f105f..00000000 Binary files a/obsolete/fonts/xerox/Optima10-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C0.wd.Z deleted file mode 100644 index 88810ac9..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C356.wd.Z deleted file mode 100644 index c401a829..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C357.wd.Z deleted file mode 100644 index 5f01365f..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C360.wd.Z deleted file mode 100644 index 66e7f050..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C361.wd.Z deleted file mode 100644 index c15f1440..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C41.wd.Z deleted file mode 100644 index e9e3bd82..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C42.wd.Z deleted file mode 100644 index 9ba96c80..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima10-MIR-C43.wd.Z deleted file mode 100644 index e53bfb1b..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C0.wd.Z deleted file mode 100644 index 386e0741..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C356.wd.Z deleted file mode 100644 index 346668df..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C357.wd.Z deleted file mode 100644 index 747a378f..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C360.wd.Z deleted file mode 100644 index 1e2d2130..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C361.wd.Z deleted file mode 100644 index d40c8a72..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C41.wd.Z deleted file mode 100644 index 65cfa038..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C42.wd.Z deleted file mode 100644 index 258a03f5..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima10-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima10-MRR-C43.wd.Z deleted file mode 100644 index 897fbe19..00000000 Binary files a/obsolete/fonts/xerox/Optima10-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C0.wd.Z deleted file mode 100644 index 63e5ca83..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C356.wd.Z deleted file mode 100644 index 7e8a45bb..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C357.wd.Z deleted file mode 100644 index d222eecb..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C360.wd.Z deleted file mode 100644 index acdcda50..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C361.wd.Z deleted file mode 100644 index c3beeffb..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C41.wd.Z deleted file mode 100644 index 52992b35..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C42.wd.Z deleted file mode 100644 index dd777ed2..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima11-BIR-C43.wd.Z deleted file mode 100644 index 404da8da..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C0.wd.Z deleted file mode 100644 index aa440c40..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C356.wd.Z deleted file mode 100644 index 07232a8c..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C357.wd.Z deleted file mode 100644 index df460749..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C360.wd.Z deleted file mode 100644 index dd24643d..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C361.wd.Z deleted file mode 100644 index 76f1964a..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C41.wd.Z deleted file mode 100644 index 7eb8e5a1..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C42.wd.Z deleted file mode 100644 index 3c06b609..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima11-BRR-C43.wd.Z deleted file mode 100644 index cde1bf05..00000000 Binary files a/obsolete/fonts/xerox/Optima11-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C0.wd.Z deleted file mode 100644 index 2a81ddce..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C356.wd.Z deleted file mode 100644 index 19b1cfe1..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C357.wd.Z deleted file mode 100644 index efd12b65..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C360.wd.Z deleted file mode 100644 index f21cb75f..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C361.wd.Z deleted file mode 100644 index 12a4d465..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C41.wd.Z deleted file mode 100644 index a582f62d..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C42.wd.Z deleted file mode 100644 index 92bdb901..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima11-MIR-C43.wd.Z deleted file mode 100644 index 6efffd80..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C0.wd.Z deleted file mode 100644 index 43a047ce..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C356.wd.Z deleted file mode 100644 index 46c1a114..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C357.wd.Z deleted file mode 100644 index 424be8d2..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C360.wd.Z deleted file mode 100644 index 1d085005..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C361.wd.Z deleted file mode 100644 index 6d782031..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C41.wd.Z deleted file mode 100644 index 91eb54ae..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C42.wd.Z deleted file mode 100644 index 036a09ba..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima11-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima11-MRR-C43.wd.Z deleted file mode 100644 index e252c335..00000000 Binary files a/obsolete/fonts/xerox/Optima11-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C0.wd.Z deleted file mode 100644 index 4a636f8a..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C356.wd.Z deleted file mode 100644 index cbb77d5a..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C357.wd.Z deleted file mode 100644 index abc6d493..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C360.wd.Z deleted file mode 100644 index d26bda85..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C361.wd.Z deleted file mode 100644 index 8a941be9..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C41.wd.Z deleted file mode 100644 index 817800e9..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C42.wd.Z deleted file mode 100644 index a1e0cfb5..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima12-BIR-C43.wd.Z deleted file mode 100644 index 5aa05a86..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C0.wd.Z deleted file mode 100644 index 464d956b..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C356.wd.Z deleted file mode 100644 index 260459bc..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C357.wd.Z deleted file mode 100644 index 5b2d42ff..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C360.wd.Z deleted file mode 100644 index c90904dd..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C361.wd.Z deleted file mode 100644 index 85fcc676..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C41.wd.Z deleted file mode 100644 index 7365c0ca..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C42.wd.Z deleted file mode 100644 index 5ddd5b8c..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima12-BRR-C43.wd.Z deleted file mode 100644 index 51598167..00000000 Binary files a/obsolete/fonts/xerox/Optima12-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C0.wd.Z deleted file mode 100644 index 37982f24..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C356.wd.Z deleted file mode 100644 index c71e2b5e..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C357.wd.Z deleted file mode 100644 index 5a436382..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C360.wd.Z deleted file mode 100644 index eadb2076..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C361.wd.Z deleted file mode 100644 index e910416c..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C41.wd.Z deleted file mode 100644 index a35b723b..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C42.wd.Z deleted file mode 100644 index 784e0bfc..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima12-MIR-C43.wd.Z deleted file mode 100644 index dd3fe037..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C0.wd.Z deleted file mode 100644 index fead936b..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C356.wd.Z deleted file mode 100644 index 187c28f3..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C357.wd.Z deleted file mode 100644 index aeadbb60..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C360.wd.Z deleted file mode 100644 index 5afd6fd7..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C361.wd.Z deleted file mode 100644 index 4c382f68..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C41.wd.Z deleted file mode 100644 index 920dd62e..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C42.wd.Z deleted file mode 100644 index 60721463..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima12-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima12-MRR-C43.wd.Z deleted file mode 100644 index 8524e14f..00000000 Binary files a/obsolete/fonts/xerox/Optima12-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C0.wd.Z deleted file mode 100644 index 337b4d24..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C356.wd.Z deleted file mode 100644 index 3dc063e1..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C357.wd.Z deleted file mode 100644 index 8bb6b3f1..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C360.wd.Z deleted file mode 100644 index 69ddd6e9..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C361.wd.Z deleted file mode 100644 index 61dcf51f..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C41.wd.Z deleted file mode 100644 index f60133ea..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C42.wd.Z deleted file mode 100644 index f5b4005e..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima14-BIR-C43.wd.Z deleted file mode 100644 index f876ed43..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C0.wd.Z deleted file mode 100644 index 1ce5f133..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C356.wd.Z deleted file mode 100644 index e0ed88e9..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C357.wd.Z deleted file mode 100644 index c35b7dde..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C360.wd.Z deleted file mode 100644 index d688d00d..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C361.wd.Z deleted file mode 100644 index 6fb3733b..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C41.wd.Z deleted file mode 100644 index d58236c8..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C42.wd.Z deleted file mode 100644 index b836b388..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima14-BRR-C43.wd.Z deleted file mode 100644 index 8f912d4c..00000000 Binary files a/obsolete/fonts/xerox/Optima14-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C0.wd.Z deleted file mode 100644 index f1934fb6..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C356.wd.Z deleted file mode 100644 index b00c05be..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C357.wd.Z deleted file mode 100644 index 93108f0e..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C360.wd.Z deleted file mode 100644 index 3ebeec75..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C361.wd.Z deleted file mode 100644 index 73e30ff7..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C41.wd.Z deleted file mode 100644 index b7410d1a..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C42.wd.Z deleted file mode 100644 index 9e37040c..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima14-MIR-C43.wd.Z deleted file mode 100644 index d1361e38..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C0.wd.Z deleted file mode 100644 index 596f7d3a..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C356.wd.Z deleted file mode 100644 index e77e7715..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C357.wd.Z deleted file mode 100644 index fb8b9356..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C360.wd.Z deleted file mode 100644 index 6cc2c7eb..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C361.wd.Z deleted file mode 100644 index 6da624f9..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C41.wd.Z deleted file mode 100644 index fdee537e..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C42.wd.Z deleted file mode 100644 index fefa8e30..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima14-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima14-MRR-C43.wd.Z deleted file mode 100644 index e6cd2a80..00000000 Binary files a/obsolete/fonts/xerox/Optima14-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C0.wd.Z deleted file mode 100644 index 702e419b..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C356.wd.Z deleted file mode 100644 index 914ce963..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C357.wd.Z deleted file mode 100644 index 09811a5c..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C360.wd.Z deleted file mode 100644 index 39f87d98..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C361.wd.Z deleted file mode 100644 index 51bd7d90..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C41.wd.Z deleted file mode 100644 index 5f9d7342..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C42.wd.Z deleted file mode 100644 index 102cf737..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima18-BIR-C43.wd.Z deleted file mode 100644 index eb05afd2..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C0.wd.Z deleted file mode 100644 index b0aa05fe..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C356.wd.Z deleted file mode 100644 index 7801ad7a..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C357.wd.Z deleted file mode 100644 index 5527e63d..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C360.wd.Z deleted file mode 100644 index 4d18dc79..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C361.wd.Z deleted file mode 100644 index cd5602f2..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C41.wd.Z deleted file mode 100644 index 05812d5d..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C42.wd.Z deleted file mode 100644 index 128f4db9..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima18-BRR-C43.wd.Z deleted file mode 100644 index bfa58ac5..00000000 Binary files a/obsolete/fonts/xerox/Optima18-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C0.wd.Z deleted file mode 100644 index c5e017dc..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C356.wd.Z deleted file mode 100644 index 5d6ddf77..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C357.wd.Z deleted file mode 100644 index b23d5426..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C360.wd.Z deleted file mode 100644 index 06aeb2d5..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C361.wd.Z deleted file mode 100644 index b56b9fe3..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C41.wd.Z deleted file mode 100644 index 9021534a..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C42.wd.Z deleted file mode 100644 index 92c99192..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima18-MIR-C43.wd.Z deleted file mode 100644 index 992235c5..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C0.wd.Z deleted file mode 100644 index 5f815a33..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C356.wd.Z deleted file mode 100644 index dfb2c8ca..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C357.wd.Z deleted file mode 100644 index a40ac4be..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C360.wd.Z deleted file mode 100644 index bccfe919..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C361.wd.Z deleted file mode 100644 index f2657a4b..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C41.wd.Z deleted file mode 100644 index 56f25446..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C42.wd.Z deleted file mode 100644 index 6fb38def..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima18-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima18-MRR-C43.wd.Z deleted file mode 100644 index b46621a2..00000000 Binary files a/obsolete/fonts/xerox/Optima18-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BIR-C0.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C0.wd.Z deleted file mode 100644 index b6b0ff19..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BIR-C356.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C356.wd.Z deleted file mode 100644 index 4ff19451..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BIR-C357.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C357.wd.Z deleted file mode 100644 index 89eea879..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BIR-C360.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C360.wd.Z deleted file mode 100644 index ecf6c6a3..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BIR-C361.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C361.wd.Z deleted file mode 100644 index 12ec7819..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BIR-C41.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C41.wd.Z deleted file mode 100644 index d901a3a8..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BIR-C42.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C42.wd.Z deleted file mode 100644 index 862666d9..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BIR-C43.wd.Z b/obsolete/fonts/xerox/Optima24-BIR-C43.wd.Z deleted file mode 100644 index 05b15c53..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BRR-C0.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C0.wd.Z deleted file mode 100644 index baf5e83e..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BRR-C356.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C356.wd.Z deleted file mode 100644 index 1c3a2f85..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BRR-C357.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C357.wd.Z deleted file mode 100644 index e2667a61..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BRR-C360.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C360.wd.Z deleted file mode 100644 index aeebae72..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BRR-C361.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C361.wd.Z deleted file mode 100644 index 6623d118..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BRR-C41.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C41.wd.Z deleted file mode 100644 index 5c86783a..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BRR-C42.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C42.wd.Z deleted file mode 100644 index 7a1107e1..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-BRR-C43.wd.Z b/obsolete/fonts/xerox/Optima24-BRR-C43.wd.Z deleted file mode 100644 index 29208984..00000000 Binary files a/obsolete/fonts/xerox/Optima24-BRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MIR-C0.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C0.wd.Z deleted file mode 100644 index 7bc4898b..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MIR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MIR-C356.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C356.wd.Z deleted file mode 100644 index bf7e6dc6..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MIR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MIR-C357.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C357.wd.Z deleted file mode 100644 index 8b2db7c6..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MIR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MIR-C360.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C360.wd.Z deleted file mode 100644 index a8881d1f..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MIR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MIR-C361.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C361.wd.Z deleted file mode 100644 index 5510824e..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MIR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MIR-C41.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C41.wd.Z deleted file mode 100644 index 8e0e3593..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MIR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MIR-C42.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C42.wd.Z deleted file mode 100644 index 56117b2d..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MIR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MIR-C43.wd.Z b/obsolete/fonts/xerox/Optima24-MIR-C43.wd.Z deleted file mode 100644 index dd708f9d..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MIR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MRR-C0.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C0.wd.Z deleted file mode 100644 index d487e4fd..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MRR-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MRR-C356.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C356.wd.Z deleted file mode 100644 index 74ced308..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MRR-C356.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MRR-C357.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C357.wd.Z deleted file mode 100644 index 3d439655..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MRR-C357.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MRR-C360.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C360.wd.Z deleted file mode 100644 index b3157e80..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MRR-C360.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MRR-C361.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C361.wd.Z deleted file mode 100644 index 0199f570..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MRR-C361.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MRR-C41.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C41.wd.Z deleted file mode 100644 index f3959147..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MRR-C41.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MRR-C42.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C42.wd.Z deleted file mode 100644 index e2fee30e..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MRR-C42.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Optima24-MRR-C43.wd.Z b/obsolete/fonts/xerox/Optima24-MRR-C43.wd.Z deleted file mode 100644 index 7fb8abd6..00000000 Binary files a/obsolete/fonts/xerox/Optima24-MRR-C43.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/OptimaItalic.NovaFont b/obsolete/fonts/xerox/OptimaItalic.NovaFont deleted file mode 100644 index c16887e6..00000000 Binary files a/obsolete/fonts/xerox/OptimaItalic.NovaFont and /dev/null differ diff --git a/obsolete/fonts/xerox/OptimaMedium.NovaFont b/obsolete/fonts/xerox/OptimaMedium.NovaFont deleted file mode 100644 index 0bd7a685..00000000 Binary files a/obsolete/fonts/xerox/OptimaMedium.NovaFont and /dev/null differ diff --git a/obsolete/fonts/xerox/README.TXT b/obsolete/fonts/xerox/README.TXT deleted file mode 100644 index 2bc12d9e..00000000 --- a/obsolete/fonts/xerox/README.TXT +++ /dev/null @@ -1,3 +0,0 @@ -This directory contains fonts and font information which are to be used for Xerox internal uses only. Under no circumstances can these fonts be released for customer use. For information, contact Frank Shih, Lisp Development, Xerox Artificial Intelligence Systems. - -The screen fonts labelled ITCBauhaus are in fact just renamed copies of the font Modern. This is because ITCBauhaus is not yet available at 72 dpi, and so the generic Modern is substituted instead. Printers containing the font ITCBauhaus should be able to correctly render the file, however. diff --git a/obsolete/fonts/xerox/ShimmerWide.wd.Z b/obsolete/fonts/xerox/ShimmerWide.wd.Z deleted file mode 100644 index 8e15b003..00000000 Binary files a/obsolete/fonts/xerox/ShimmerWide.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ShimmerWideMIR.wd.Z b/obsolete/fonts/xerox/ShimmerWideMIR.wd.Z deleted file mode 100644 index f1519951..00000000 Binary files a/obsolete/fonts/xerox/ShimmerWideMIR.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/ShimmerWideMRR.wd.Z b/obsolete/fonts/xerox/ShimmerWideMRR.wd.Z deleted file mode 100644 index 14b49257..00000000 Binary files a/obsolete/fonts/xerox/ShimmerWideMRR.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Souvenir.wd.Z b/obsolete/fonts/xerox/Souvenir.wd.Z deleted file mode 100644 index 42cdef41..00000000 Binary files a/obsolete/fonts/xerox/Souvenir.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/SouvenirBIRC0.wd.Z b/obsolete/fonts/xerox/SouvenirBIRC0.wd.Z deleted file mode 100644 index c5e9deec..00000000 Binary files a/obsolete/fonts/xerox/SouvenirBIRC0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/SouvenirBRRC0.wd.Z b/obsolete/fonts/xerox/SouvenirBRRC0.wd.Z deleted file mode 100644 index 3461533e..00000000 Binary files a/obsolete/fonts/xerox/SouvenirBRRC0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/SouvenirMIRC0.wd.Z b/obsolete/fonts/xerox/SouvenirMIRC0.wd.Z deleted file mode 100644 index 2805dc07..00000000 Binary files a/obsolete/fonts/xerox/SouvenirMIRC0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/SouvenirMRRC0.wd.Z b/obsolete/fonts/xerox/SouvenirMRRC0.wd.Z deleted file mode 100644 index 39c098de..00000000 Binary files a/obsolete/fonts/xerox/SouvenirMRRC0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/TROFF.wd.Z b/obsolete/fonts/xerox/TROFF.wd.Z deleted file mode 100644 index 12afd1b0..00000000 Binary files a/obsolete/fonts/xerox/TROFF.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/TROFFFonts.widths b/obsolete/fonts/xerox/TROFFFonts.widths deleted file mode 100644 index feb89704..00000000 Binary files a/obsolete/fonts/xerox/TROFFFonts.widths and /dev/null differ diff --git a/obsolete/fonts/xerox/Times10-C0.wd.Z b/obsolete/fonts/xerox/Times10-C0.wd.Z deleted file mode 100644 index 515b499f..00000000 Binary files a/obsolete/fonts/xerox/Times10-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Times12-C0.wd.Z b/obsolete/fonts/xerox/Times12-C0.wd.Z deleted file mode 100644 index 515b499f..00000000 Binary files a/obsolete/fonts/xerox/Times12-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Times14-C0.wd.Z b/obsolete/fonts/xerox/Times14-C0.wd.Z deleted file mode 100644 index 515b499f..00000000 Binary files a/obsolete/fonts/xerox/Times14-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Times18-C0.wd.Z b/obsolete/fonts/xerox/Times18-C0.wd.Z deleted file mode 100644 index 515b499f..00000000 Binary files a/obsolete/fonts/xerox/Times18-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Times24-C0.wd.Z b/obsolete/fonts/xerox/Times24-C0.wd.Z deleted file mode 100644 index 515b499f..00000000 Binary files a/obsolete/fonts/xerox/Times24-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Times36-C0.wd.Z b/obsolete/fonts/xerox/Times36-C0.wd.Z deleted file mode 100644 index 515b499f..00000000 Binary files a/obsolete/fonts/xerox/Times36-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Times8-C0.wd.Z b/obsolete/fonts/xerox/Times8-C0.wd.Z deleted file mode 100644 index 515b499f..00000000 Binary files a/obsolete/fonts/xerox/Times8-C0.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.FlemishScriptII b/obsolete/fonts/xerox/Xerox.XC1-1-1.FlemishScriptII deleted file mode 100644 index 3d9f8c79..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.FlemishScriptII and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Gacha b/obsolete/fonts/xerox/Xerox.XC1-1-1.Gacha deleted file mode 100644 index 3b51d735..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Gacha and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Bold.Z deleted file mode 100644 index b3908291..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Bold.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Z deleted file mode 100644 index 499f3154..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCBauhaus.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Italic.Z deleted file mode 100644 index cff26fdb..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Italic.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Z deleted file mode 100644 index 17fd10bb..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Bold.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Italic.Z deleted file mode 100644 index 42d6fb4f..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Italic.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Z deleted file mode 100644 index 5815198f..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.ITCGaramond.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Italic.Z deleted file mode 100644 index 99d8b1da..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Italic.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Z deleted file mode 100644 index 20aa00f4..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Bold.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Italic.Z deleted file mode 100644 index 781b0462..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Italic.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Z deleted file mode 100644 index 451a2921..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Optima.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Italic.Z deleted file mode 100644 index 58b5c603..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Italic.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Z deleted file mode 100644 index d7f9c46b..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Bold.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Italic.Z deleted file mode 100644 index 8c915e9c..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Italic.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Z deleted file mode 100644 index 1095bcc5..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Souvenir.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Italic.Z deleted file mode 100644 index 951d6d68..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Italic.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Z deleted file mode 100644 index 1ed25117..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Bold.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Italic.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Italic.Z deleted file mode 100644 index 9e553fc8..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Italic.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Z b/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Z deleted file mode 100644 index 200fbbef..00000000 Binary files a/obsolete/fonts/xerox/Xerox.XC1-1-1.Times.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/itcberkeley.wd.Z b/obsolete/fonts/xerox/itcberkeley.wd.Z deleted file mode 100644 index 83219d3b..00000000 Binary files a/obsolete/fonts/xerox/itcberkeley.wd.Z and /dev/null differ diff --git a/obsolete/fonts/xerox/tffonts.widths b/obsolete/fonts/xerox/tffonts.widths deleted file mode 100644 index eb47c1f3..00000000 Binary files a/obsolete/fonts/xerox/tffonts.widths and /dev/null differ diff --git a/obsolete/greetfiles/INIT b/obsolete/greetfiles/INIT deleted file mode 100644 index c28c86e5..00000000 Binary files a/obsolete/greetfiles/INIT and /dev/null differ diff --git a/obsolete/greetfiles/INIT.LCOM b/obsolete/greetfiles/INIT.LCOM deleted file mode 100644 index e3628377..00000000 Binary files a/obsolete/greetfiles/INIT.LCOM and /dev/null differ diff --git a/obsolete/greetfiles/LOCAL-INIT b/obsolete/greetfiles/LOCAL-INIT deleted file mode 100644 index 2f56dcaf..00000000 --- a/obsolete/greetfiles/LOCAL-INIT +++ /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/obsolete/greetfiles/LOCAL-INIT.LCOM b/obsolete/greetfiles/LOCAL-INIT.LCOM deleted file mode 100644 index 154e2567..00000000 Binary files a/obsolete/greetfiles/LOCAL-INIT.LCOM and /dev/null differ diff --git a/obsolete/greetfiles/PARC-INIT b/obsolete/greetfiles/PARC-INIT deleted file mode 100644 index 34c1961e..00000000 --- a/obsolete/greetfiles/PARC-INIT +++ /dev/null @@ -1,433 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-Mar-2002 22:47:25" {DSK}medley3.5>current>PARC-INIT.;21 42271 changes to%: (FNS ParcInit) previous date%: "14-Feb-2002 09:12:08" {DSK}medley3.5>current>PARC-INIT.;20) (* ; " Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2002 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PARC-INITCOMS) (RPAQQ PARC-INITCOMS [ (* ;; "PARC/SSL, and IRL system greeting file") (DECLARE%: FIRST (P (* ; "Patch for SOLARIS at DDS??") (CL:INTERN "*YP-DOMAIN*" "YP"))) (FNS PARC-INIT FindSite FindInitHost ParcInit SetDirectories LoadPatches COLLECT-PATCH-FILES INTERLISPMODE FILE-SERVER-UP-P HostPrefix) (FNS SUNOSNAME) (FUNCTIONS WITHOUT.PAGEHOLD) (* ;;  "Initially set LOCALPATCHDIRECTORY to NIL to avoid loading patches if no servers are up.") (VARS (LOCALPATCHDIRECTORY NIL)) (VARS (*USEOLDFONTDIRECTORIES* NIL)) (INITVARS (UNIXMAIL.DOMAIN.NAME "parc.com")) (INITVARS (INIT-NOGREET-FLAG NIL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (PARC-INIT))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "PARC/SSL, and IRL system greeting file") (DECLARE%: FIRST (* ; "Patch for SOLARIS at DDS??") (CL:INTERN "*YP-DOMAIN*" "YP") ) (DEFINEQ (PARC-INIT - [LAMBDA NIL - (DECLARE (GLOBALVARS \INIT.HostName MAKESYSNAME LOCALPATCHDIRECTORY MAKESYSDATE - AUTHENTICATION.NET.HINT CH.NET.HINT NSMAIL.NET.HINT)) - (* ; "Edited 11-Mar-99 17:46 by rmk:") - (* ; - "Edited 7-Mar-99 01:56 by kaplan") - (* ; "Edited 30-Jan-92 16:26 by bbb") - - (* ;; "This is what gets called when PARC-INIT is loaded.") - - (IF (EQ 'MAIKO (MACHINETYPE)) - THEN (SETQ INIT-NOGREET-FLAG (UNIX-GETENV "NOGREET"))) - (LOGIN NIL 'QUIET) - (BKSYSBUF " ") - (AND (GETD 'MEDLEYVERSION) - (SELECTQ (MEDLEYVERSION) - (|2.0| (* ; - "Make sure that the compile extensions are set right, in case they reverted to LCOM, DFASL.") - (SETQ COMPILE.EXT 'MCOM) - (SETQ FASL.EXT 'MFASL) - (SETQ *COMPILED-EXTENSIONS* '(MCOM MFASL))) - NIL)) - - (* ;; "do the real work") - - (WITHOUT.PAGEHOLD (WFROMDS (GETSTREAM T 'OUTPUT)) - (FindSite) - (SETQ YP:*YP-DOMAIN* (IF (EQ \INIT.Location 'ADOC) - THEN "ADOC" - ELSE "PARC")) - - (* ;; "1st floor = 132 204#") - - (* ;; "2nd floor = 89 131#") - - (* ;; "3rd floor = 98 142#") - - (* ;; "Bldg 34 = 106 152#") - - (* ;; "The clearinghouses in Building 35 are on net 132 (two of them), 89 and 98") - - (* ;; "In Building 34 on net 152 and net 146 in building 32") - -(* ;;; " hmmm this is strange.. I don't see net 146... I took 146 out") - - (SAVESET 'AUTHENTICATION.NET.HINT (SAVESET 'CH.NET.HINT - (SELECTQ \INIT.Location - (ENVOS-MTNVIEW (LIST 138)) - (IRL-HANOVER (LIST 132 89 98 152)) - (BLDG34-10MB (LIST 106 132 89 98)) - (BLDG35-1STFLOOR - (LIST 132 89 98 106)) - (BLDG35-2NDFLOOR - (LIST 89 132 98 106)) - (BLDG35-3RDFLOOR - (LIST 98 132 89 106)) - (ADOC (LIST 132 89 98 106)) - (LIST 132 89 98 106)) - T) - T) - - (* ;; " there are mail servers in Building 35 are on nets 89, 98 and 132") - - (SAVESET 'NSMAIL.NET.HINT (SELECTQ \INIT.Location - ((IRL-HANOVER BLDG34-10MB) - (LIST 89)) - AUTHENTICATION.NET.HINT) - T) - (FindInitHost) - (ParcInit) - (CL:WHEN INIT-NOGREET-FLAG - (SAVESET 'USERGREETFILES NIL T)) - (CL:WHEN LOCALPATCHDIRECTORY - (LoadPatches LOCALPATCHDIRECTORY 'SYSLOAD MAKESYSDATE))]) (FindSite - [LAMBDA NIL (* ; "Edited 14-Oct-97 18:38 by rmk:") - (* ; "Edited 8-Dec-89 19:46 by Burwell") - (DECLARE (GLOBALVARS \INIT.Location \MY.NSADDRESS \LOCALPUPNETHOST)) - -(* ;;; "Determine location, for use by other init we have to handle nets 6 and 64 specially since they cover 2 floors. We also have to use etherhostnumbers rather than names, since the name service doesn't appear to work reliably on Dorados (nhb ' 5-Dec-85 11:36:13') Still seeing wrong location occasionally, keep the etherhostnumber for later diagnosis. (nhb '13-Jan-86 20:23:47') problem seems to be that system returns hostnumber with 0 net number, we'll dismiss until it's greater than 255 (nhb '16-Jan-86 10:57:46') Added net 273## for Sunnyvale (nhb ' 9-Feb-88 15:54:17') Edited to reflect move of XAIS to Envos in Mtn. View, and IRL to the Garage (bbb 1-sep-88)") - -(* ;;; "") - -(* ;;; "27-Mar-89 bbb added home dialin lines") - -(* ;;; "13-Sep-89 bvm changed to look at XNS net instead of Pup") - - (SAVESET '\INIT.Location - (SELECTQ (CL:WHEN (STREQUAL "1" (UNIX-GETENV "LDELISPXNS")) - (FOR Delay IN '(20 55 148 403 1096) - DO (IF (AND \MY.NSADDRESS (> (SETQ $$VAL (\GETBASEFIXP - \MY.NSADDRESS 0)) - 0)) - THEN (* ; "Find my XNS net number") - (RETURN $$VAL)) - (DISMISS Delay) FINALLY (PRINTOUT T - "* Warning: Init could not determine your net number" - T - " assuming location is Bldg35-2nd floor" - T) - (RETURN 6))) - (98 'BLDG35-3RDFLOOR) - (89 'BLDG35-2NDFLOOR) - (3 'PARC-NET3) - (17778 'ADOC) - ((52 6 132) - 'BLDG35-1STFLOOR) - (106 'BLDG34-10MB) - ((7 138) - 'ENVOS-MTNVIEW) - ((146 21) - 'IRL-HANOVER) - ((159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175) - 'HOME-DIALIN) - (* ; "Home DIAL-IN 237Q through 257Q") - (OR (MKATOM (UNIX-GETENV "LDESITE")) - 'BLDG35-2NDFLOOR]) (FindInitHost - [LAMBDA NIL - (DECLARE (GLOBALVARS \INIT.HostName \INIT.AlternateHostNames \INIT.Location)) - (* ; "Edited 27-Oct-93 14:56 by rmk:") - -(* ;;; "Lyric PARC people who have NS id's will have all their directories set to IE:PARC:Xerox") - -(* ;;; "") - -(* ;;; "July 28, 1989") - -(* ;;; "Medley is on Phylum, ie and Erinyes. PARC people with NS ids will randomly get assigned to either Pooh or ie:parc:xerox. IRL people will point to ie:parc:xerox") - -(* ;;; "We need to set the default domain and organization before we do a clearinghouse lookup") - -(* ;;; "") - -(* ;;; "October 6, 1989") - -(* ;;; -" PARC people will have their directories set only to pooh (not randomly on ie:parc:xerox or pooh)") - -(* ;;; "") - -(* ;;; "October 3, 1990") - -(* ;;; "Take out all references to Phylum") - -(* ;;; "") - -(* ;;; "January 30, 1992") - -(* ;;; " Replace references to {pooh/n}lisp> with {dsk}/import/lisp") - -(* ;;; "") - - (SAVESET 'CH.DEFAULT.DOMAIN "PARC" T) - (SAVESET 'CH.DEFAULT.ORGANIZATION "Xerox" T) - (SAVESET 'YP:*YP-DOMAIN* (IF (EQ \INIT.Location 'ADOC) - THEN "ADOC" - ELSE "PARC") - T) - (LET (HasNSID? MsgWindowMenu MsgWindow) - (SELECTQ (MKATOM (U-CASE (MKSTRING MAKESYSNAME))) - (MEDLEY2.0 [PROGN (SELECTQ \INIT.Location - ((IRL-HANOVER) - (* ;; "IRL and home dial-in can't talk tcp/ip ") - - (SAVESET '\INIT.HostName "IE:PARC:XEROX") - (SAVESET '\INIT.AlternateHostNames NIL)) - (PROGN (SAVESET '\INIT.HostName "{dsk}medley2.0>") - (SAVESET '\INIT.AlternateHostNames '("IE:PARC:Xerox"]) - (MEDLEY [PROGN (SELECTQ \INIT.Location - ((IRL-HANOVER) - (* ;; "IRL and home dial-in can't talk tcp/ip ") - - (SAVESET '\INIT.HostName "IE:PARC:XEROX") - (SAVESET '\INIT.AlternateHostNames '("Erinyes"))) - (PROGN (SAVESET '\INIT.HostName "{dsk}") - (SAVESET '\INIT.AlternateHostNames '("IE:PARC:Xerox"]) - (PROGN (SAVESET '\INIT.HostName "{dsk}") - (SAVESET '\INIT.AlternateHostNames '("IE:PARC:Xerox"]) (ParcInit [LAMBDA NIL (* ;  "Edited 4-Jan-2002 17:45 by kaplan") (* ;  "Edited 4-Jan-2002 17:45 by kaplan") (* ;  "Edited 3-Mar-2002 22:47 by rmk:") (* "N.H.Briggs" " 2-Nov-87 12:39") (* bbb "29-Oct-87 17:17") (DECLARE (GLOBALVARS \INIT.Location \INIT.HostName \INIT.AlternateHostNames MAKESYSNAME POSTGREETFORMS DEFAULTREGISTRY CH.DEFAULT.ORGANIZATION CH.DEFAULT.DOMAIN YP:*YP-DOMAIN* AUTHENTICATION.NET.HINT CH.NET.HINT PRINTSERVICE DEFAULTPRINTINGHOST DEFAULTFAXHOST FAXADDRESSES NETWORKLOGINFO LISPSUPPORT LAFITESUPPORT TEDITSUPPORT NETWORKOSTYPES LAFITESPECIALFORMS LAFITEFORMSMENU LAFITEFORMDIRECTORIES LAFITEMODEDEFAULT PHONELISTFILES BackgroundMenu BackgroundMenuCommands USERGREETFILES COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTOWNER COPYRIGHTRESERVED SYSOUTFETCHDATE \CURRENTDISPLAYLINE IMAGESTREAMTYPES RECLAIMWAIT LOCALPATCHDIRECTORY CHAT.HOSTINFO EMPRESS#SIDES \INIT.MachineType NFS:*USE-VOLUME-MAP*) (SPECVARS LDFLG)) (PROG (LispusersUpdateHostName FontHostName ReleaseName) (IF (NOT (BOUNDP 'SYSOUTFETCHDATE)) THEN (SETQ SYSOUTFETCHDATE (DATE))) [SETQ ReleaseName (MKATOM (U-CASE (MKSTRING MAKESYSNAME] (* ;;; "Prevent a pagehold from happening") (SETQ \CURRENTDISPLAYLINE -10000) (* ;;; "Do not put any patch-type code before this point. This code will get executed once before the init file realizes that it needs to be updated. Once it updates the init file it will execute the code again up to this point.") (SETQ \INIT.MachineType (MACHINETYPE)) (ADDTOVAR GREETDATES (" 8-MAR" . "It's International Women's Day") ("18-MAY" . "It's Victoria Day") (" 5-NOV" . " it's Guy Fawkes day") (" 1-JUL" . "It's Canada Day") ("12-OCT" . "It's Canada's Thanksgiving Day")) (SAVESET 'USERGREETFILES (LET [[NFSFiles '(({dsk} USER >LISP>INIT. COM) ({dsk} USER >LISP>INIT) ({dsk} USER >INIT. COM) ({dsk} USER >INIT.LISP] (LocalFiles '(({DSK}INIT- USER %. COM) ({DSK}INIT- USER] (APPEND NFSFiles LocalFiles)) T) (* ;; "things to do with the copyright notices in files") (SAVESET 'COPYRIGHTFLG 'DEFAULT T) (SAVESET 'COPYRIGHTOWNERS '((PARC "Palo Alto Research Center Incorporated") (XEROX "Xerox Corporation") (VENUE "Venue Corporation")) T) (COND ((FMEMB \INIT.Location '(ENVOS-MTNVIEW)) (SAVESET 'DEFAULTCOPYRIGHTOWNER 'VENUE T)) (T (SAVESET 'DEFAULTCOPYRIGHTOWNER 'PARC T))) (SAVESET 'COPYRIGHTRESERVED T T) (* ;; "the interpress printers at PARC are all running print services 9.0 or higher now.") (SAVESET 'PRINTSERVICE 10.0 T) (* ;; "Setup docuprint printers at PARC") (SELECTQ \INIT.Location ((BLDG35-3RDFLOOR BLDG35-1STFLOOR BLDG35-2NDFLOOR PARC-NET3) (SETQ EMPRESS#SIDES 2) (FOR P IN '(|Waterman:PARC:xerox| |Mont Blanc:PARC:xerox| |Perfector:PARC:Xerox| |Ansel:PARC:xerox| |Kanji:PARC:xerox| |Squeeze-Box:PARC:xerox| |Papaya:Parc:Xerox|) DO (PUT P 'PRINTERTYPE 'DOCUPRINT))) NIL) (* ;; "Select an appropriate set of printers based on the location.") (SAVESET 'DEFAULTPRINTINGHOST (COPY (SELECTQ \INIT.Location (BLDG35-1STFLOOR '(|Mont Blanc:PARC:xerox| londondailymail |Marker:PARC:Xerox|)) (BLDG35-2NDFLOOR (APPEND '(comicnews) [FOR X IN '(|Waterman:PARC:xerox| |Mont Blanc:PARC:xerox| |Perfector:PARC:Xerox| |Ansel:PARC:xerox| |Kanji:PARC:xerox| |Squeeze-Box:PARC:xerox| |Papaya:Parc:Xerox|) JOIN `((DOCUPRINT ,X INTERPRESS) (DOCUPRINT ,X POSTSCRIPT] (FOR X IN '(|Marker:PARC:Xerox|) COLLECT X) '(londondailymail))) (BLDG35-3RDFLOOR '(|Papermate:Parc:Xerox|)) (BLDG34-10MB '(|Cross:parc:Xerox| |Kanji:PARC:Xerox|)) (PARC-NET3 '(|Scripto:PARC:Xerox| |Perfector:PARC:Xerox|)) NIL)) T) (* ;; "set things related to the Interpress to FAX service") (SAVESET 'DEFAULTFAXHOST "VPFax:Parc:XEROX" T) (ADDTOVAR FAXADDRESSES (NLTT/FAX 94154944374) (POD26/FAX 94154944380) (EUROPARC/FAX 901144223341510) (MICROLYTICS/FAX 97162483868)) (SETQ LispusersUpdateHostName NIL) (SETQ FontHostName (SELECTQ ReleaseName ((MEDLEY2.0 MEDLEY2.1) "{dsk}") \INIT.HostName)) (IF \INIT.HostName THEN (SetDirectories \INIT.HostName LispusersUpdateHostName NIL FontHostName NIL T)) (* ;; "fix up the Unix login method to deal with brain damaged ParcVax") [AND (LISTP (GETTOPVAL 'NETWORKLOGINFO)) (/RPLACD (ASSOC 'LOGIN (CDR (ASSOC 'UNIX NETWORKLOGINFO))) '(WAIT LF WAIT USERNAME LF WAIT PASSWORD LF)) (/RPLACD (ASSOC 'LOGIN (CDR (ASSOC 'NS NETWORKLOGINFO))) '("Logon" CR USERNAME CR PASSWORD CR] (* ;;; "use to have (ADDTOVAR LAFITESUPPORT ...) but that produced the wrong result for already initialized variables") (SELECTQ ReleaseName ((MEDLEY MEDLEY2.0 MEDLEY2.1) [SETQ LISPSUPPORT '((NS "AISupport:MV:Envos, Burwell:PARC:Xerox, vanMelle:PARC:Xerox" ] [SETQ LAFITESUPPORT '((NS "LafiteSupport:PARC:Xerox"] (SETQ TEDITSUPPORT LISPSUPPORT)) NIL) (* ;; "make sure we know about some of the local machine types") (ADDTOVAR NETWORKLOGINFO (INFOVAX (LOGIN "User" CR))) (ADDTOVAR NETWORKOSTYPES (XSVAX . VMS) (MADVAX . VMS) (INFOVAX%: . INFOVAX) (|INFOVAX:PARC:XEROX| . INFOVAX) (FLO . UNIX) (POOH . UNIX) (PIGLET . UNIX) (PALAIN . UNIX) (KANGA . UNIX) (ROO . UNIX) (ROO%: . UNIX) (|ROO:PARC:XEROX| . UNIX) (FREDDYK . UNIX)) (* ;; "Set up the hint to Lafite for finding form files for the PARC archiving") (SELECTQ \INIT.Location ((BLDG35-1STFLOOR BLDG35-2NDFLOOR BLDG35-3RDFLOOR) (SETQ LAFITEFORMSMENU NIL)) ((IRL-HANOVER) (SETQ LAFITEFORMSMENU NIL)) NIL) (SETQ LAFITEMODEDEFAULT 'NS) (* ;; "pointer to the PARC phone list file") (ADDTOVAR PHONELISTFILES {dsk}doc>parcphonelist.txt {dsk}doc>ssutelephonelist.txt) (* ;; "Set the default IDLE options for PARC, a friendly place") (IDLE.SET.OPTION 'FORGET NIL) (/PUTPROP 'NSMAINTAIN 'FILEDEF 'NSMAINTAIN) (IF [AND (NOT (ASSOC 'Set% Directories BackgroundMenuCommands)) (MEMB ReleaseName '(MEDLEY MEDLEY2.0 MEDLEY2.1] THEN (/NCONC1 BackgroundMenuCommands (LIST 'Set% Directories '(SetDirectories) "Set search path and font directories to default" (SELECTQ ReleaseName ((MEDLEY MEDLEY2.0 MEDLEY2.1) '(SUBITEMS (NFS '(SetDirectories "{dsk}" NIL NIL NIL NIL T) "Set search patch and font directories to Import" ))) NIL))) (SETQ BackgroundMenu NIL)) [COND ((FMEMB \INIT.Location '(ENVOS-MTNVIEW)) (IF (MEMB ReleaseName '(MEDLEY MEDLEY2.0 MEDLEY2.1)) THEN (SAVESET 'XCL:*SHORT-SITE-NAME* 'Venue T) (SAVESET 'XCL:*LONG-SITE-NAME* "Venue Corporation, San Carlos" T))) (T (IF (MEMB ReleaseName '(MEDLEY MEDLEY2.0 MEDLEY2.1)) THEN (SAVESET 'XCL:*SHORT-SITE-NAME* "PARC" T) (SAVESET 'XCL:*LONG-SITE-NAME* "Xerox Palo Alto Research Center" T] (* ;;; "We are decommissioning the volume map so tell Lisp not to use it") (SAVESET 'NFS:*USE-VOLUME-MAP* NIL) (FOR VAR IN '(AUTHENTICATION.NET.HINT BackgroundMenu BackgroundMenuCommands CH.DEFAULT.DOMAIN YP:*YP-DOMAIN* CH.DEFAULT.ORGANIZATION CH.NET.HINT NSMAIL.NET.HINT COPYRIGHTFLG COPYRIGHTOWNERS COPYRIGHTRESERVED DEFAULTCOPYRIGHTOWNER DEFAULTFAXHOST DEFAULTPRINTINGHOST DEFAULTREGISTRY FAXADDRESSES GREETDATES LAFITEFORMDIRECTORIES LAFITEFORMSMENU LAFITESPECIALFORMS LAFITESUPPORT LISPSUPPORT NETWORKLOGINFO NETWORKOSTYPES PHONELISTFILES PRINTSERVICE TEDITSUPPORT USERGREETFILES LOCALPATCHDIRECTORY CHAT.HOSTINFO EMPRESS#SIDES NFS:*USE-VOLUME-MAP*) DO (UNMARKASCHANGED VAR 'VARS]) (SetDirectories - [LAMBDA (ReleaseHostName LispusersUpdatesHostName LibraryUpdatesHostName FontHostName ReleaseName - Reset) (* ; "Edited 11-Nov-98 21:57 by rmk:") - (* ; - "Edited 20-Feb-98 12:00 by kaplan") - (* ; - "Edited 12-Feb-93 08:35 by kaplan") - (* "N.H.Briggs" " 2-Nov-87 12:14") - (* bbb "29-Oct-87 17:15") - (* edited%: "11-Jun-87 12:32") - (DECLARE (GLOBALVARS \INIT.Location \INIT.CurrentReleaseName \INIT.PendingReleaseName - DIRECTORIES LISPUSERSDIRECTORIES MAKESYSNAME IRM.HOST&DIR - LOOPSUSERSDIRECTORIES FONTDIRECTORIES DISPLAYFONTDIRECTORIES - DISPLAYFONTEXTENSIONS INTERPRESSFONTDIRECTORIES WHEREIS.HASH - XCL::*WHERE-IS-CASH-FILES* LOCALPATCHDIRECTORY)) - (PROG (NewLispUsersDirectories NewDirectories (Medley1.1VersionNumber 39424)) - - (* ;; "determine the release name, we take the hint from the system when it's present.") - - (SETQ ReleaseName (L-CASE (OR ReleaseName MAKESYSNAME) - T)) - (SETQ ReleaseHostName (L-CASE ReleaseHostName)) - (SETQ LispusersUpdatesHostName (L-CASE (OR LispusersUpdatesHostName ReleaseHostName))) - (SETQ LibraryUpdatesHostName (L-CASE (OR LibraryUpdatesHostName ReleaseHostName))) - (SETQ FontHostName (L-CASE (OR FontHostName ReleaseHostName))) - - (* ;; "set up the pointer to the Interlisp reference manual for use by HELPSYS and DINFO. This depends on the release name.") - - (SAVESET 'IRM.HOST&DIR (SELECTQ ReleaseName - ((Medley Medley2.0 Medley2.1 Medley3.5) - (CONCAT (HostPrefix ReleaseHostName) - "Lisp>Lyric>LispUsers>IRM>")) - NIL) - T) - - (* ;; - "setup pointer to whereis hash files, these differ by version and no pattern has emerged yet") - - (SAVESET 'WHEREIS.HASH (SELECTQ ReleaseName - (Medley NIL) - (Medley2.0 NIL) - (Medley2.1 NIL) - (Medley3.5 NIL) - NIL) - T) - - (* ;; "This is really messy, the general intent is as follows: if the user is running the current release he wants release>library>new, release>library, lispusers, release>lispusers. If running a LispCore or forked LispCore release, put those directories first, then take the pending release If running neither of the above, (could be older or newer than current) try release>library>new, release>library>, release>lispusers, lispusers. This all relies on the theory that has only the new packages for the current release. Currently, sources are only maintained on Eris, so the release>sources is always pointed there. This may change sometime. ") - - (* ;; "") - - (* ;; "8603 Things seemed to have settled down, we have the releasename> directories created and the procedures worked out. It is now not necessary to know if the user is running the %"current%" release in order to get the directories correct.") - - (* ;; "added Lispcore>Internal>Library per request from Masinter") - - (* ;; "") - - [SELECTQ ReleaseName - (Medley2.0 (PUSH NewLispUsersDirectories "{dsk}/project/medley2.0/library/" - "{dsk}/project/medley2.0/lispusers/")) - (Medley2.1 (PUSH NewLispUsersDirectories "{dsk}/project/medley2.1/library/" - "{dsk}/project/medley2.1/lispusers/" - "{dsk}/project/medley2.1/sources/")) - (Medley3.5 (PUSH NewLispUsersDirectories "{dsk}/project/medley3.5/library/" - "{dsk}/project/medley3.5/lispusers/" - "{dsk}/project/medley3.5/sources/")) - (PROGN (PUSH NewLispUsersDirectories (CONCAT (HostPrefix ReleaseHostName) - "Lisp>" ReleaseName ">Library>") - (CONCAT (HostPrefix ReleaseHostName) - "Lisp>" ReleaseName ">Internal>Library>") - (CONCAT (HostPrefix LispusersUpdatesHostName) - "LispUsers>" ReleaseName ">") - (CONCAT (HostPrefix ReleaseHostName) - "Lisp>" ReleaseName ">LispUsers>")) - - (* ;; "Changed to from Library>New>") - - (PUSH NewLispUsersDirectories (CONCAT (HostPrefix LibraryUpdatesHostName - ) - "LispLibrary>" ReleaseName ">"] - [SETQ NewDirectories (APPEND NewDirectories (LDIFFERENCE NewLispUsersDirectories - NewDirectories) - (LIST (CONCAT (HostPrefix ReleaseHostName) - "Lisp>" ReleaseName ">Sources>"] - (SAVESET 'LISPUSERSDIRECTORIES (APPEND NewLispUsersDirectories (AND (NOT Reset) - (LDIFFERENCE - LISPUSERSDIRECTORIES - - NewLispUsersDirectories - ))) - T) - (SAVESET 'LOCALPATCHDIRECTORY (CONCAT (SELECTQ ReleaseName - (Medley (CONCAT (HostPrefix ReleaseHostName) - "Lisp>" ReleaseName - (IF (EQ (LISPVERSION) - Medley1.1VersionNumber - ) - THEN "" - ELSE "1.15"))) - (Medley2.0 "{dsk}medley2.0") - (Medley2.1 "{dsk}medley2.1") - (Medley3.5 "{dsk}medley3.5") - (HELP)) - ">Patches>") - T) - (SAVESET 'DIRECTORIES (APPEND NewDirectories (AND (NOT Reset) - (LDIFFERENCE DIRECTORIES NewDirectories)) - ) - T) - (IF (MEMB ReleaseName '(Medley Medley2.0 Medley2.1 Medley3.5)) - THEN (SAVESET 'XCL::*WHERE-IS-CASH-FILES* (MKLIST (FINDFILE 'SYSTEM.HASH T - DIRECTORIES)) - T)) - (SAVESET 'LOOPSUSERSDIRECTORIES (LIST (PACKFILENAME 'HOST "{NB:PARC:Xerox}" 'BODY - (CONCAT "" ReleaseName ">Users>"))) - T) - - (* ;; "") - - (* ;; "the font directories depend on the release. We also check here whether the user is in bldg 35, in which case we add the Alto fonts. The press font widths must be on a random access device, and are sometimes kept on the local disk. If they aren't randaccessp then we put them on {dsk} if there's room, {core} if not.") - - (* ;; "") - - (SELECTQ ReleaseName - ((Medley Medley2.0 Medley2.1 Medley3.5) - (PROGN (SAVESET 'DISPLAYFONTDIRECTORIES (LIST (CONCAT (HostPrefix FontHostName - ) - "Lisp>DisplayFonts>") - (CONCAT (HostPrefix FontHostName - ) - "AltoFonts>")) - T) - (SAVESET 'DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE) - T) - (SAVESET 'INTERPRESSFONTDIRECTORIES (LIST (CONCAT (HostPrefix - FontHostName) - "Lisp>IPFonts>")) - T))) - (PROGN (SAVESET 'DISPLAYFONTDIRECTORIES (UNION (LIST (CONCAT (HostPrefix - FontHostName) - "Lisp>Fonts>")) - (LIST (CONCAT (HostPrefix - FontHostName) - "AltoFonts>") - (CONCAT (HostPrefix - FontHostName) - "AltoFonts>Original>"))) - T) - (SAVESET 'DISPLAYFONTEXTENSIONS '(DISPLAYFONT STRIKE) - T) - (SAVESET 'INTERPRESSFONTDIRECTORIES (LIST (CONCAT (HostPrefix FontHostName) - "Lisp>Fonts>")) - T))) - (FOR var IN '(DIRECTORIES LISPUSERSDIRECTORIES IRM.HOST&DIR LOOPSUSERSDIRECTORIES - FONTDIRECTORIES DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS - INTERPRESSFONTDIRECTORIES WHEREIS.HASH LOCALPATCHDIRECTORY - XCL::*WHERE-IS-CASH-FILES*) DO (UNMARKASCHANGED - var - 'VARS]) (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))))]) (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"]) (FILE-SERVER-UP-P - [LAMBDA (FILE-SERVER-NAME) (* ; "Edited 12-Oct-89 22:24 by Burwell") - (PROG ([SERVER-TYPE (COND - ((STRPOS ":" (L-CASE FILE-SERVER-NAME)) - 'XNS) - ((STRPOS "/n" (L-CASE FILE-SERVER-NAME)) - 'NFS) - (T 'IFS] - (PROCESS-RESULT (CONS)) - (PROCESS-HANDLE)) - (if (NULL FILE-SERVER-NAME) - then (RETURN NIL)) - (SETQ PROCESS-HANDLE (ADD.PROCESS `(COND - ((DIRECTORYNAMEP ,(SELECTQ SERVER-TYPE - (XNS "DESKTOPS") - (IFS "SYSTEM") - (NFS (CONCAT "{" - FILE-SERVER-NAME - "}")) - NIL) - ,FILE-SERVER-NAME) - (RPLACA ,(KWOTE PROCESS-RESULT) - T))) - 'NAME "file-server-up-p")) - (DISMISS 500) - (forDuration 60 timerUnits 'SECONDS until (CAR PROCESS-RESULT) - do (DISMISS 500) finally (DEL.PROCESS PROCESS-HANDLE)) - (RETURN (CAR PROCESS-RESULT]) (HostPrefix - [LAMBDA (HostName) (* ; "Edited 30-Jan-92 16:25 by bbb") - (if (STRPOS "/n" (L-CASE HostName)) - then (CONCAT "{" HostName "}<" (SUBSTRING HostName 1 (DIFFERENCE (NCHARS HostName) - 2)) - ">") - elseif (OR (STRPOS "nfs}" (L-CASE HostName)) - (STRPOS "dsk}" (L-CASE HostName))) - then (CONCAT HostName) - else (CONCAT "{" HostName "}<"]) ) (DEFINEQ (SUNOSNAME - [LAMBDA NIL (* ; "Edited 7-Dec-94 13:44 by rmk:") - - (* ;; "Returns name of curren SunOS version") - - (SELCHARQ (CHCON1 (UNIX-GETENV "OSVERSION")) - (4 'SUNOS) - (5 'SOLARIS) - (HELP "UNKNOWN SUN OSVERSION" (UNIX-GETENV "OSVERFSION"]) ) (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)) (* ;; "Initially set LOCALPATCHDIRECTORY to NIL to avoid loading patches if no servers are up.") (RPAQQ LOCALPATCHDIRECTORY NIL) (RPAQQ *USEOLDFONTDIRECTORIES* NIL) (RPAQ? UNIXMAIL.DOMAIN.NAME "parc.com") (RPAQ? INIT-NOGREET-FLAG NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (PARC-INIT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS PARC-INIT COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2002)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1800 40555 (PARC-INIT 1810 . 5479) (FindSite 5481 . 8296) (FindInitHost 8298 . 10968) ( ParcInit 10970 . 22993) (SetDirectories 22995 . 34548) (LoadPatches 34550 . 36498) ( COLLECT-PATCH-FILES 36500 . 37477) (INTERLISPMODE 37479 . 38292) (FILE-SERVER-UP-P 38294 . 40000) ( HostPrefix 40002 . 40553)) (40556 40900 (SUNOSNAME 40566 . 40898))))) STOP \ No newline at end of file diff --git a/obsolete/greetfiles/PARC-INIT.LCOM b/obsolete/greetfiles/PARC-INIT.LCOM deleted file mode 100644 index 5dbae95a..00000000 Binary files a/obsolete/greetfiles/PARC-INIT.LCOM and /dev/null differ diff --git a/obsolete/internal/ABC b/obsolete/internal/ABC deleted file mode 100644 index 69ad77ab..00000000 --- a/obsolete/internal/ABC +++ /dev/null @@ -1,62 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "18-Mar-88 16:09:05" {ERIS}INTERNAL>LIBRARY>ABC.;4 2101 - - changes to%: (VARS ABCCOMS) - - previous date%: "29-Jul-87 12:04:16" {ERIS}INTERNAL>LIBRARY>ABC.;3) - - -(* " -Copyright (c) 1986, 1987, 1988 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT ABCCOMS) - -(RPAQQ ABCCOMS ((VARS (MSRECORDTRANFLG T) - (DWIMIFYCOMPFLG) - (MSMACROPROPS COMPILERMACROPROPS) - (CLEANUPOPTIONS '(RC F)) - (CROSSCOMPILING T) - (ASKEDITHIST T) - (RECOMPILEDEFAULT 'CHANGES) - (CROSSCOMPILING 'ASK)) - (FILES (SOURCE) - FILESETS) - (P (MOVD? 'APPLY* 'SPREADAPPLY*) - [RESETVARS ((CROSSCOMPILING T)) - (FILESLOAD EXPORTS.ALL) - (AND (EQ (ASKUSER DWIMWAIT 'N "Check imports? " NIL T) - 'Y) - (ERSETQ (CHECKIMPORTS EXPORTFILES T] - (PRIN1 - "**** SET IL:DFNFLG TO IL:PROP IF YOU EDIT SYSTEM SOURCES THAT CAN'T BE RUN INTERPRETED" - T)))) - -(RPAQQ MSRECORDTRANFLG T) - -(RPAQQ DWIMIFYCOMPFLG NIL) - -(RPAQ MSMACROPROPS COMPILERMACROPROPS) - -(RPAQQ CLEANUPOPTIONS (RC F)) - -(RPAQQ CROSSCOMPILING T) - -(RPAQQ ASKEDITHIST T) - -(RPAQQ RECOMPILEDEFAULT CHANGES) - -(RPAQQ CROSSCOMPILING ASK) -(FILESLOAD (SOURCE) - FILESETS) -(MOVD? 'APPLY* 'SPREADAPPLY*) -[RESETVARS ((CROSSCOMPILING T)) - (FILESLOAD EXPORTS.ALL) - (AND (EQ (ASKUSER DWIMWAIT 'N "Check imports? " NIL T) - 'Y) - (ERSETQ (CHECKIMPORTS EXPORTFILES T] -(PRIN1 "**** SET IL:DFNFLG TO IL:PROP IF YOU EDIT SYSTEM SOURCES THAT CAN'T BE RUN INTERPRETED" T) -(PUTPROPS ABC COPYRIGHT ("Xerox Corporation" 1986 1987 1988)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/internal/ABC.LCOM b/obsolete/internal/ABC.LCOM deleted file mode 100644 index 8f8e8f0f..00000000 --- a/obsolete/internal/ABC.LCOM +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 1-Feb-98 09:30:41" ("compiled on " {DSK}disk2>jdstools>lc3>lispcore3.0>internal>library>ABC.;1) "31-Jan-98 19:10:48" bcompl'd in "Medley 31-Jan-98 ..." dated "31-Jan-98 19:12:50") (FILECREATED "18-Mar-88 16:09:05" {ERIS}INTERNAL>LIBRARY>ABC.;4 2101 changes to%: (VARS ABCCOMS) previous date%: "29-Jul-87 12:04:16" {ERIS}INTERNAL>LIBRARY>ABC.;3) (PRETTYCOMPRINT ABCCOMS) (RPAQQ ABCCOMS ((VARS (MSRECORDTRANFLG T) (DWIMIFYCOMPFLG) (MSMACROPROPS COMPILERMACROPROPS) ( CLEANUPOPTIONS (QUOTE (RC F))) (CROSSCOMPILING T) (ASKEDITHIST T) (RECOMPILEDEFAULT (QUOTE CHANGES)) ( CROSSCOMPILING (QUOTE ASK))) (FILES (SOURCE) FILESETS) (P (MOVD? (QUOTE APPLY*) (QUOTE SPREADAPPLY*)) (RESETVARS ((CROSSCOMPILING T)) (FILESLOAD EXPORTS.ALL) (AND (EQ (ASKUSER DWIMWAIT (QUOTE N) "Check imports? " NIL T) (QUOTE Y)) (ERSETQ (CHECKIMPORTS EXPORTFILES T)))) (PRIN1 "**** SET IL:DFNFLG TO IL:PROP IF YOU EDIT SYSTEM SOURCES THAT CAN'T BE RUN INTERPRETED" T)))) (RPAQQ MSRECORDTRANFLG T) (RPAQQ DWIMIFYCOMPFLG NIL) (RPAQ MSMACROPROPS COMPILERMACROPROPS) (RPAQQ CLEANUPOPTIONS (RC F)) (RPAQQ CROSSCOMPILING T) (RPAQQ ASKEDITHIST T) (RPAQQ RECOMPILEDEFAULT CHANGES) (RPAQQ CROSSCOMPILING ASK) (FILESLOAD (SOURCE) FILESETS) (MOVD? (QUOTE APPLY*) (QUOTE SPREADAPPLY*)) (RESETVARS ((CROSSCOMPILING T)) (FILESLOAD EXPORTS.ALL) (AND (EQ (ASKUSER DWIMWAIT (QUOTE N) "Check imports? " NIL T) (QUOTE Y)) (ERSETQ (CHECKIMPORTS EXPORTFILES T)))) (PRIN1 "**** SET IL:DFNFLG TO IL:PROP IF YOU EDIT SYSTEM SOURCES THAT CAN'T BE RUN INTERPRETED" T) (PUTPROPS ABC COPYRIGHT ("Xerox Corporation" 1986 1987 1988)) NIL \ No newline at end of file diff --git a/obsolete/internal/library/DICOLOR b/obsolete/internal/library/DICOLOR deleted file mode 100644 index a96ec3f0..00000000 --- a/obsolete/internal/library/DICOLOR +++ /dev/null @@ -1,466 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "15-Jun-90 13:49:37" {DSK}local>lde>lispcore>internal>library>DICOLOR.;2 20737 - - changes to%: (VARS DICOLORCOMS) - - previous date%: "15-Aug-85 19:44:58" {DSK}local>lde>lispcore>internal>library>DICOLOR.;1 -) - - -(* ; " -Copyright (c) 1985, 1990 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT DICOLORCOMS) - -(RPAQQ DICOLORCOMS - ((FNS CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL CSLTOHLS - RGBTOCNS) - (VARS DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping NEWCOLORITEM) - (INITVARS (COLORNAMEMENU)) - (FNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN - DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN - DICOLOR.saturationNvalue DICOLOR.saturationNname) - (DECLARE%: DONTCOPY (*) - (RECORDS hueRecord lightnessRecord saturationRecord) - (CONSTANTS * DICOLOR.hueConstants) - (CONSTANTS * DICOLOR.saturationConstants) - (CONSTANTS * DICOLOR.lightnessConstants)))) -(DEFINEQ - -(CNSMENUINIT - [LAMBDA NIL (* gbn " 9-Aug-85 03:11") - [SETQ CNSHUEMENU (create MENU - ITEMS _ (for I in DICOLOR.hueMapping collect (CAR I] - [SETQ CNSSATURATIONMENU (create MENU - ITEMS _ (for I in DICOLOR.saturationMapping - collect (CAR I] - (SETQ CNSLIGHTNESSMENU (create MENU - ITEMS _ (for I in DICOLOR.lightnessMapping - collect (CAR I]) - -(CNSTOCSL - [LAMBDA (hue saturation lightness) (* hdj "12-Apr-85 19:01") - (PROG ((hueAtom (MKATOM hue)) - (saturationAtom (MKATOM saturation)) - (lightnessAtom (MKATOM lightness)) - c s l) - (if [NOT (SETQ c (fetch (hueRecord ordering) of (ASSOC hueAtom - DICOLOR.hueMapping] - then (SETQ c DICOLOR.achromatic)) - (if (EQ c DICOLOR.achromatic) - then (SETQ s DICOLOR.noSaturation) - else (if [NOT (SETQ s (fetch (saturationRecord ordering) - of (ASSOC saturationAtom DICOLOR.saturationMapping] - then (SETQ s DICOLOR.vivid))) - (SELECTQ hueAtom - (Black (SETQ l DICOLOR.black)) - (White (SETQ l DICOLOR.white)) - (if [NOT (SETQ l (fetch (lightnessRecord ordering) of (ASSOC lightnessAtom - - DICOLOR.lightnessMapping - ] - then (SETQ l DICOLOR.medium))) - (RETURN (LIST c s l]) - -(CNSTORGB - [LAMBDA (saturation lightness hue) (* hdj "15-Jul-85 12:33") - (LET ((CSL (CNSTOCSL hue saturation lightness))) - (HLSTORGB (APPLY (FUNCTION CSLTOHLS) - CSL]) - -(CSLTOCNS - [LAMBDA (c s l) (* hdj "15-Jul-85 12:37") - (PROG (hue saturation lightness) - [if (EQ c DICOLOR.achromatic) - then (SETQ saturation "") - [SELECTC l - (DICOLOR.black (SETQ hue "Black") - (SETQ lightness "")) - (DICOLOR.white (SETQ hue "White") - (SETQ lightness "")) - (PROGN (SETQ hue "Gray") - (SETQ lightness (MKSTRING (fetch (lightnessRecord name) - of (DICOLOR.lightnessN l] - else (SETQ hue (fetch (hueRecord name) of (DICOLOR.hueN c))) - (SETQ saturation (fetch (saturationRecord name) of (DICOLOR.saturationN - s))) - (SETQ lightness (fetch (lightnessRecord name) of (DICOLOR.lightnessN - l] - (RETURN (LIST saturation lightness hue]) - -(DICOLOR.FROM.USER - [LAMBDA (NAMES?) (* gbn " 9-Aug-85 04:51") - - (* * returns an RGB triple. If NAMES? prompts the user first with the global - color name menu. She can then choose NEWCOLOR which can be specified as RGB or - CNS) - - (PROG (NAME RGB) - (if NAMES? - then (* first try to get a color name) - [SETQ NAME (MENU (OR COLORNAMEMENU (SETQ COLORNAMEMENU - (CREATE MENU - ITEMS _ - (CONS NEWCOLORITEM - (FOR ENTRY IN COLORNAMES - COLLECT (CAR ENTRY] - (if (NOT NAME) - then (* the user clicked outside the menu) - (RETURN)) - [SETQ RGB (SELECTQ NAME - (RGB (READCOLOR1 "specify new color")) - (CNS (APPLY (FUNCTION CNSTORGB) - (GETCNS))) - (RETURN (CDR (ASSOC NAME COLORNAMES] - (if (NOT (SETQ NAME (TTYIN "New color name? "))) - then (* user must have decided that she - didn't want to keep - (name) the color) - (RETURN)) - (push COLORNAMES (CONS (CAR NAME) - RGB)) - (SETQ COLORNAMEMENU NIL) (* invalidate the menu) - (RETURN RGB]) - -(GETCNS - [LAMBDA NIL (* gbn " 9-Aug-85 03:13") - (LIST (MENU CNSLIGHTNESSMENU) - (MENU CNSSATURATIONMENU) - (MENU CNSHUEMENU]) - -(HLSTOCSL - [LAMBDA (hue lightness saturation) (* hdj "15-Jul-85 12:14") - (LET - ((ISLHue (FQUOTIENT (MOD (PLUS hue 240) - 360) - 360))) - (PROG (c s l) - (for old s from DICOLOR.noSaturation to DICOLOR.vivid - do (if (EQ s DICOLOR.vivid) - then (RETURN)) - (if (LEQ saturation (PLUS (DICOLOR.saturationNvalue s) - (QUOTIENT (DIFFERENCE (DICOLOR.saturationNvalue - (ADD1 s)) - (DICOLOR.saturationNvalue - s)) - 2))) - then (RETURN))) - [if (EQ s DICOLOR.noSaturation) - then (SETQ c DICOLOR.achromatic) - (for old l from DICOLOR.black to DICOLOR.white - do (if (EQ l DICOLOR.white) - then (RETURN)) - (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l) - (QUOTIENT (DIFFERENCE ( - DICOLOR.lightnessNvalue - (ADD1 l)) - ( - DICOLOR.lightnessNvalue - l)) - 2))) - then (RETURN))) - else (for old c from DICOLOR.red to DICOLOR.purplishRed - do (* (HELP c)) - (if (EQ c DICOLOR.purplishRed) - then (if (GREATERP ISLHue - (PLUS (DICOLOR.hueNvalue c) - (QUOTIENT (DIFFERENCE 1 ( - DICOLOR.hueNvalue - c)) - 2))) - then (SETQ c DICOLOR.red)) - (RETURN)) - (if (LEQ ISLHue (PLUS (DICOLOR.hueNvalue c) - (QUOTIENT (DIFFERENCE (DICOLOR.hueNvalue - (ADD1 c)) - (DICOLOR.hueNvalue - c)) - 2))) - then (RETURN))) - (for old l from DICOLOR.veryDark to DICOLOR.veryLight - do (if (EQ l DICOLOR.veryLight) - then (RETURN)) - (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l) - (QUOTIENT (DIFFERENCE ( - DICOLOR.lightnessNvalue - (ADD1 l)) - (DICOLOR.lightnessNvalue - l)) - 2))) - then (RETURN] - (RETURN (LIST c s l]) - -(CSLTOHLS - [LAMBDA (c s l) (* hdj "15-Jul-85 12:23") - (PROG (hue saturation lightness) - (if (EQ c DICOLOR.achromatic) - then (SETQ hue 0.0) - (SETQ saturation 0.0) - (SETQ lightness (DICOLOR.lightnessNvalue l)) - else (SETQ hue (DICOLOR.hueNvalue c)) - (SETQ saturation (DICOLOR.saturationNvalue s)) - (SETQ lightness (DICOLOR.lightnessNvalue l))) - (RETURN (LIST (MOD (FPLUS 120 (FTIMES hue 360)) - 360) - lightness saturation]) - -(RGBTOCNS - [LAMBDA (Red Green Blue) (* hdj "15-Jul-85 12:36") - (APPLY (FUNCTION CSLTOCNS) - (APPLY (FUNCTION HLSTOCSL) - (RGBTOHLS Red Green Blue]) -) - -(RPAQQ DICOLOR.hueMapping - ((Achromatic 0.0 -1) - (Red 0.0 0) - (OrangishRed 0.01 1) - (RedOrange 0.02 2) - (ReddishOrange 0.03 3) - (Orange 0.04 4) - (YellowishOrange 0.07 5) - (OrangeYellow 0.1 6) - (OrangishYellow 0.13 7) - (Yellow 0.1673 8) - (GreenishYellow 0.2073 9) - (YellowGreen 0.2473 10) - (YellowishGreen 0.2873 11) - (Green 0.3333 12) - (BluishGreen 0.4133 13) - (GreenBlue 0.4933 14) - (GreenishBlue 0.5733 15) - (Blue 0.6666 16) - (PurplishBlue 0.6816 17) - (BluePurple 0.6966 18) - (BluishPurple 0.7116 19) - (Purple 0.73 20) - (ReddishPurple 0.8 21) - (PurpleRed 0.87 22) - (PurplishRed 0.94 23) - (BrownishRed 0.01 24) - (RedBrown 0.02 25) - (ReddishBrown 0.03 26) - (Brown 0.04 27) - (YellowishBrown 0.07 28) - (BrownYellow 0.1 29) - (BrownishYellow 0.13 30))) - -(RPAQQ DICOLOR.lightnessMapping ((Black 0.0 0) - (VeryDark 0.1666 1) - (Dark 0.3333 2) - (Medium 0.5 3) - (Light 0.6666 4) - (VeryLight 0.8333 5) - (White 1.0 6))) - -(RPAQQ DICOLOR.saturationMapping ((NoSaturation 0.0 0) - (Grayish 0.25 1) - (Moderate 0.5 2) - (Strong 0.75 3) - (Vivid 1.0 4))) - -(RPAQQ NEWCOLORITEM (New% Color 'CNS "Allows specification of a new color" - (SUBITEMS (RGB 'RGB - "Specify a new color using Red, Green, Blue sliders") - (CNS 'CNS "Specify a new color using English")))) - -(RPAQ? COLORNAMEMENU ) -(DEFINEQ - -(DICOLOR.hueN - [LAMBDA (N) (* hdj "17-Apr-85 13:38") - (DECLARE (GLOBALVARS DICOLOR.hueMapping)) - (for ELT in DICOLOR.hueMapping suchthat (EQ (fetch (hueRecord ordering) - of ELT) - N]) - -(DICOLOR.hueNvalue - [LAMBDA (N) (* hdj "18-Apr-85 09:58") - (fetch (hueRecord value) of (DICOLOR.hueN N]) - -(DICOLOR.hueNname - [LAMBDA (N) (* hdj "18-Apr-85 10:07") - (fetch (hueRecord name) of (DICOLOR.hueN N]) - -(DICOLOR.lightnessN - [LAMBDA (N) (* hdj "17-Apr-85 13:40") - (DECLARE (GLOBALVARS DICOLOR.lightnessMapping)) - (for ELT in DICOLOR.lightnessMapping suchthat (EQ (fetch (lightnessRecord - ordering) - of ELT) - N]) - -(DICOLOR.lightnessNvalue - [LAMBDA (N) (* hdj "17-Apr-85 13:36") - (fetch (lightnessRecord value) of (DICOLOR.lightnessN N]) - -(DICOLOR.lightnessNname - [LAMBDA (N) (* hdj "17-Apr-85 14:02") - (fetch (lightnessRecord name) of (DICOLOR.lightnessN N]) - -(DICOLOR.saturationN - [LAMBDA (N) (* hdj "17-Apr-85 13:39") - (DECLARE (GLOBALVARS DICOLOR.saturationMapping)) - (for ELT in DICOLOR.saturationMapping suchthat (EQ (fetch (saturationRecord - ordering) of - ELT) - N]) - -(DICOLOR.saturationNvalue - [LAMBDA (N) (* hdj "17-Apr-85 13:36") - (fetch (saturationRecord value) of (DICOLOR.saturationN N]) - -(DICOLOR.saturationNname - [LAMBDA (N) (* hdj "17-Apr-85 14:02") - (fetch (saturationRecord name) of (DICOLOR.saturationN N]) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD hueRecord (name value ordering)) - -(RECORD lightnessRecord (name value ordering)) - -(RECORD saturationRecord (name value ordering)) -) - - -(RPAQQ DICOLOR.hueConstants - (DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple - DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow - DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow - DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow - DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red - DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange - DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown - DICOLOR.yellowishGreen DICOLOR.yellowishOrange)) -(DECLARE%: EVAL@COMPILE - -(RPAQQ DICOLOR.achromatic -1) - -(RPAQQ DICOLOR.blue 16) - -(RPAQQ DICOLOR.bluePurple 18) - -(RPAQQ DICOLOR.bluishGreen 13) - -(RPAQQ DICOLOR.bluishPurple 19) - -(RPAQQ DICOLOR.brown 27) - -(RPAQQ DICOLOR.brownYellow 29) - -(RPAQQ DICOLOR.brownishRed 24) - -(RPAQQ DICOLOR.brownishYellow 30) - -(RPAQQ DICOLOR.green 12) - -(RPAQQ DICOLOR.greenBlue 14) - -(RPAQQ DICOLOR.greenishBlue 15) - -(RPAQQ DICOLOR.greenishYellow 9) - -(RPAQQ DICOLOR.orange 4) - -(RPAQQ DICOLOR.orangeYellow 6) - -(RPAQQ DICOLOR.orangishRed 1) - -(RPAQQ DICOLOR.orangishYellow 7) - -(RPAQQ DICOLOR.purple 20) - -(RPAQQ DICOLOR.purpleRed 22) - -(RPAQQ DICOLOR.purplishBlue 17) - -(RPAQQ DICOLOR.purplishRed 23) - -(RPAQQ DICOLOR.red 0) - -(RPAQQ DICOLOR.redBrown 25) - -(RPAQQ DICOLOR.redOrange 2) - -(RPAQQ DICOLOR.reddishBrown 26) - -(RPAQQ DICOLOR.reddishOrange 3) - -(RPAQQ DICOLOR.reddishPurple 21) - -(RPAQQ DICOLOR.yellow 8) - -(RPAQQ DICOLOR.yellowGreen 10) - -(RPAQQ DICOLOR.yellowishBrown 28) - -(RPAQQ DICOLOR.yellowishGreen 11) - -(RPAQQ DICOLOR.yellowishOrange 5) - - -(CONSTANTS DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen - DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed - DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue - DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed - DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue - DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown - DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen - DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange) -) - - -(RPAQQ DICOLOR.saturationConstants (DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate - DICOLOR.strong DICOLOR.vivid)) -(DECLARE%: EVAL@COMPILE - -(RPAQQ DICOLOR.noSaturation 0) - -(RPAQQ DICOLOR.grayish 1) - -(RPAQQ DICOLOR.moderate 2) - -(RPAQQ DICOLOR.strong 3) - -(RPAQQ DICOLOR.vivid 4) - - -(CONSTANTS DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid) -) - - -(RPAQQ DICOLOR.lightnessConstants (DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium - DICOLOR.light DICOLOR.veryLight DICOLOR.white)) -(DECLARE%: EVAL@COMPILE - -(RPAQQ DICOLOR.black 0) - -(RPAQQ DICOLOR.veryDark 1) - -(RPAQQ DICOLOR.dark 2) - -(RPAQQ DICOLOR.medium 3) - -(RPAQQ DICOLOR.light 4) - -(RPAQQ DICOLOR.veryLight 5) - -(RPAQQ DICOLOR.white 6) - - -(CONSTANTS DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight - DICOLOR.white) -) -) -(PUTPROPS DICOLOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1990)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1197 12278 (CNSMENUINIT 1207 . 1838) (CNSTOCSL 1840 . 3245) (CNSTORGB 3247 . 3486) ( -CSLTOCNS 3488 . 4721) (DICOLOR.FROM.USER 4723 . 6789) (GETCNS 6791 . 6991) (HLSTOCSL 6993 . 11386) ( -CSLTOHLS 11388 . 12056) (RGBTOCNS 12058 . 12276)) (14261 16839 (DICOLOR.hueN 14271 . 14660) ( -DICOLOR.hueNvalue 14662 . 14837) (DICOLOR.hueNname 14839 . 15012) (DICOLOR.lightnessN 15014 . 15524) ( -DICOLOR.lightnessNvalue 15526 . 15719) (DICOLOR.lightnessNname 15721 . 15912) (DICOLOR.saturationN -15914 . 16443) (DICOLOR.saturationNvalue 16445 . 16641) (DICOLOR.saturationNname 16643 . 16837))))) -STOP diff --git a/obsolete/internal/library/DICOLOR.LCOM b/obsolete/internal/library/DICOLOR.LCOM deleted file mode 100644 index 21bd1038..00000000 Binary files a/obsolete/internal/library/DICOLOR.LCOM and /dev/null differ diff --git a/obsolete/library/CHARS b/obsolete/library/CHARS deleted file mode 100644 index 6a37c907..00000000 --- a/obsolete/library/CHARS +++ /dev/null @@ -1,17 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 1-Aug-2020 21:16:25" {DSK}kaplan>Local>medley3.5>lispcore>library>CHARS.;1 517 -) - - -(PRETTYCOMPRINT CHARSCOMS) - -(RPAQQ CHARSCOMS ((ALISTS (CHARACTERNAMES RSQ LSQ LDQ RDQ NEQ)))) - -(ADDTOVAR CHARACTERNAMES (RSQ "0,271") - (LSQ "0,251") - (LDQ "0,252") - (RDQ "0,272") - (NEQ "041,142")) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/library/FX-80DRIVER b/obsolete/library/FX-80DRIVER deleted file mode 100644 index 39183cc9..00000000 --- a/obsolete/library/FX-80DRIVER +++ /dev/null @@ -1,4346 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - -(FILECREATED "15-Jul-2025 22:01:24"  -{DSK}kaplan>Local>medley3.5>working-medley>library>FX-80DRIVER.;2 231869 - - :EDIT-BY rmk - - :CHANGES-TO (VARS FX-80.HIGH-QUALITY-DRIVERCOMS) - (FNS \HQFX80.CHANGEFONT) - - :PREVIOUS-DATE "11-Jun-90 15:57:59" -{DSK}kaplan>Local>medley3.5>working-medley>library>FX-80DRIVER.;1) - - -(PRETTYCOMPRINT FX-80DRIVERCOMS) - -(RPAQQ FX-80DRIVERCOMS - ( - -(* ;;; "FX-80 driver") - - (COMS * FX-80.FAST-DRIVERCOMS (* ; "the fast driver")) - (COMS * FX-80.HIGH-QUALITY-DRIVERCOMS (* ; "the higher quality driver")) - (COMS * FX80-PRINTCOMS (* ; "FXPrinter emulation")) - (COMS (* ; "common routines") - (FUNCTIONS (* ; "abort window stuff") - WITH-ABORT-WINDOW \FX80.CREATE-SEND-ABORT-WINDOW) - (FUNCTIONS (* ; "font profile hacking") - \ADD-TO-FONTPROFILE \GET-FROM-FONTPROFILE)) - - -(* ;;; "initialization") - - [COMS (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\HQFX80.INIT) - (\FASTFX80.INIT] - (PROP FILETYPE FX-80DRIVER))) - - - -(* ;;; "FX-80 driver") - - -(RPAQQ FX-80.FAST-DRIVERCOMS - [ - (* ;; "Fast driver") - - - (* ;; "") - - (STRUCTURES FASTFX80DATA) - (FNS \FASTFX80.INIT) - - (* ;; "Imagestream methods") - - (COMS - (* ;; "opening/closing imagestream") - - (COMS (FNS OPENFASTFX80STREAM) - (FUNCTIONS \FASTFX80.PREAMBLE \FASTFX80.RESET-PRINTER \FASTFX80.OUTPUT-SIGNATURE) - ) - (FNS \FASTFX80.CLOSE)) - (COMS - (* ;; "methods that hack fonts") - - (FNS \FASTFX80.CHANGEFONT \FASTFX80.FONTCREATE \FASTFX80.CREATECHARSET) - (FUNCTIONS \FASTFX80.INIT-FONT-PROFILE)) - (COMS - (* ;; "methods for measuring") - - (FNS \FASTFX80.STRINGWIDTH \FASTFX80.CHARWIDTH \FASTFX80.SUBCHARWIDTH) - (FUNCTIONS \FASTFX80.SPACEFACTOR)) - (COMS - (* ;; "methods that affect the current position/size of drawing surface") - - (FNS \FASTFX80.CLIPPINGREGION \FASTFX80.MOVETO \FASTFX80.XPOSITION \FASTFX80.YPOSITION - \FASTFX80.BACKUP.PAPER \FASTFX80.ADVANCE.PAPER \FASTFX80.NEWPAGE \FASTFX80.OUTCHAR - \FASTFX80.NEWLINE \FASTFX80.LINEFEED \FASTFX80.DRAWLINE) - (FUNCTIONS \FASTFX80.STARTPAGE \FASTFX80.SMART-XPOSITION \FASTFX80.TOPMARGIN - \FASTFX80.BOTTOMMARGIN \FASTFX80.LEFTMARGIN \FASTFX80.RIGHTMARGIN - \FASTFX80.CUR-POS-VISIBLE? \FASTFX80.HORIZONTAL)) - (COMS - (* ;; "printer code") - - (FUNCTIONS \FASTFX80.SEND MAKE-FASTFX80 FASTFX80FILEP \FASTFX80.CANNOT-PRINT-BITMAPS) - (FNS \FASTFX80.CONVERT-TEDIT)) - (COMS - (* ;; "Character transmission method") - - (FNS \FASTFX80.BOUT)) - - (* ;; "Miscellany") - - (FUNCTIONS \FASTFX80.TRANSLATE-CHAR WITH-FASTFX80-DATA) - (CONSTANTS (\FASTFX80.DOTSPERINCH 72) - (\FASTFX80.LINESPERINCH 6) - (\FASTFX80.LINEHEIGHT 12) - (* ; "in dots") - (\FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 ")) - (INITVARS (FASTFX80-DEFAULT-DESTINATION "{TTY}") - (\FASTFX80.INCHES-PER-PAGE 11) - (\FASTFX80.INCHES-PER-LINE 8.5)) - (COMS - (* ;; "need to load these exports") - - (DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - ADISPLAY]) - - - -(* ;; "Fast driver") - - - - -(* ;; "") - - -(CL:DEFSTRUCT FASTFX80DATA - - (* ;; "the imagedata vector for a fastfx80 imagestream") - - (VIRTUAL-XPOS 0) - (VIRTUAL-YPOS 0) - (REAL-XPOS 0) - (REAL-YPOS 0) - CLIPPINGREGION BACKINGSTREAM (LEFTMARGIN 72) - RIGHTMARGIN TOPMARGIN (BOTTOMMARGIN 0) - FONT PAPER-WIDTH PAPER-HEIGHT (SPACEFACTOR 1.0)) -(DEFINEQ - -(\FASTFX80.INIT - [LAMBDA NIL (* ; "Edited 16-Dec-86 12:03 by hdj") - - (DECLARE (GLOBALVARS DEFAULTPRINTINGHOST IMAGESTREAMTYPES PRINTERTYPES PRINTFILETYPES - \FASTFX80.IMAGEOPS \FASTFX80.FDEV)) - (SETQ \FASTFX80.FDEV (create FDEV - DEVICENAME _ (LIST 'FASTFX80 'PRINTER) - CLOSEFILE _ (FUNCTION NILL) - BOUT _ (FUNCTION \FASTFX80.BOUT))) - (SETQ \FASTFX80.IMAGEOPS (create IMAGEOPS - IMAGETYPE _ 'FASTFX80 - IMFONT _ (FUNCTION \FASTFX80.CHANGEFONT) - IMLEFTMARGIN _ (FUNCTION \FASTFX80.LEFTMARGIN) - IMRIGHTMARGIN _ (FUNCTION \FASTFX80.RIGHTMARGIN) - IMTOPMARGIN _ (FUNCTION \FASTFX80.TOPMARGIN) - IMBOTTOMMARGIN _ (FUNCTION \FASTFX80.BOTTOMMARGIN) - IMLINEFEED _ (FUNCTION NILL) - IMTERPRI _ (FUNCTION \FASTFX80.NEWLINE) - IMXPOSITION _ (FUNCTION \FASTFX80.XPOSITION) - IMYPOSITION _ (FUNCTION \FASTFX80.YPOSITION) - IMCLOSEFN _ (FUNCTION \FASTFX80.CLOSE) - IMMOVETO _ (FUNCTION \FASTFX80.MOVETO) - IMDRAWCURVE _ (FUNCTION NILL) - IMFILLCIRCLE _ (FUNCTION NILL) - IMDRAWLINE _ (FUNCTION NILL) - IMDRAWELLIPSE _ (FUNCTION NILL) - IMDRAWCIRCLE _ (FUNCTION NILL) - IMBITBLT _ (FUNCTION NILL) - IMBLTSHADE _ (FUNCTION NILL) - IMNEWPAGE _ (FUNCTION \FASTFX80.NEWPAGE) - IMSCALE _ [FUNCTION (LAMBDA NIL 1] - IMSPACEFACTOR _ (FUNCTION NILL) - IMFONTCREATE _ 'FASTFX80 - IMCOLOR _ (FUNCTION NILL) - IMBACKCOLOR _ (FUNCTION NILL) - IMOPERATION _ (FUNCTION NILL) - IMSTRINGWIDTH _ (FUNCTION \FASTFX80.STRINGWIDTH) - IMCHARWIDTH _ (FUNCTION \FASTFX80.CHARWIDTH) - IMCLIPPINGREGION _ (FUNCTION \FASTFX80.CLIPPINGREGION) - IMRESET _ (FUNCTION NILL) - IMDRAWPOLYGON _ (FUNCTION NILL) - IMFILLPOLYGON _ (FUNCTION NILL) - IMSCALEDBITBLT _ (FUNCTION NILL))) - [push IMAGESTREAMTYPES (COPYALL '(FASTFX80 (OPENSTREAM OPENFASTFX80STREAM) - (FONTCREATE \FASTFX80.FONTCREATE) - (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES) - (CREATECHARSET \FASTFX80.CREATECHARSET] - [push PRINTERTYPES (COPYALL '((FASTFX80) - (CANPRINT (FASTFX80)) - (STATUS TRUE) - (SEND \FASTFX80.SEND) - (BITMAPSCALE NIL) - (BITMAPFILE (\FASTFX80.CANNOT-PRINT-BITMAPS FILE BITMAP - SCALEFACTOR REGION ROTATION TITLE)) - (PROPERTIES NILL] - [push PRINTFILETYPES (COPYALL '(FASTFX80 (TEST FASTFX80FILEP) - (EXTENSION (FASTFX80)) - (CONVERSION (TEXT MAKE-FASTFX80 TEDIT - \FASTFX80.CONVERT-TEDIT] - (push DEFAULTPRINTINGHOST (LIST 'FASTFX80 'FASTFX80)) - (PUTPROP 'FASTFX80 'PRINTERTYPE 'FASTFX80) - (\FASTFX80.INIT-FONT-PROFILE) - T]) -) - - - -(* ;; "Imagestream methods") - - - - -(* ;; "opening/closing imagestream") - -(DEFINEQ - -(OPENFASTFX80STREAM - [LAMBDA (FILENAME OPTIONS) (* ; "Edited 20-Jan-88 11:22 by jds") - - (* ;; "open a fastfx80 imagestream") - - (LET* [[BACKING (OPENSTREAM FILENAME 'OUTPUT NIL '((SEQUENTIAL T) - (TYPE FASTFX80] - (PAPER-WIDTH (FIX (TIMES \FASTFX80.INCHES-PER-LINE \FASTFX80.DOTSPERINCH))) - (PAPER-HEIGHT (FIX (TIMES \FASTFX80.INCHES-PER-PAGE \FASTFX80.DOTSPERINCH))) - (FASTFX80STREAM (create STREAM - FULLFILENAME _ (FULLNAME BACKING) - DEVICE _ \FASTFX80.FDEV - ACCESS _ 'OUTPUT - OUTCHARFN _ (FUNCTION \FASTFX80.OUTCHAR) - IMAGEOPS _ \FASTFX80.IMAGEOPS - IMAGEDATA _ (MAKE-FASTFX80DATA :BACKINGSTREAM BACKING - :CLIPPINGREGION (CREATEREGION 0 0 PAPER-WIDTH - PAPER-HEIGHT) - :RIGHTMARGIN - (- PAPER-WIDTH \FASTFX80.DOTSPERINCH) - :TOPMARGIN - (- PAPER-HEIGHT (TIMES 3 \FASTFX80.LINEHEIGHT)) - :BOTTOMMARGIN - (TIMES 3 \FASTFX80.LINEHEIGHT) - :PAPER-WIDTH PAPER-WIDTH :PAPER-HEIGHT - PAPER-HEIGHT] - (replace (STREAM USERVISIBLE) of BACKING with NIL) - (\FASTFX80.PREAMBLE FASTFX80STREAM) - FASTFX80STREAM]) -) - -(CL:DEFUN \FASTFX80.PREAMBLE (FASTFX80STREAM) - - (* ;; "start a FASTFX80 master") - -(* ;;; "must change FASTFX80FILEP when this changes") - - (DECLARE (GLOBALVARS \FASTFX80.INCHES-PER-PAGE)) - (\FASTFX80.RESET-PRINTER FASTFX80STREAM \FASTFX80.INCHES-PER-PAGE) - (\FASTFX80.OUTPUT-SIGNATURE FASTFX80STREAM) - (\FASTFX80.CHANGEFONT FASTFX80STREAM (DEFAULTFONT 'FASTFX80)) - (\FASTFX80.STARTPAGE FASTFX80STREAM)) - -(CL:DEFUN \FASTFX80.RESET-PRINTER (FASTFX80STREAM INCHES-PER-PAGE) - - (* ;; "send a reset sequence to the fx-80") - - (IF (AND (<= 1 INCHES-PER-PAGE) - (<= INCHES-PER-PAGE 21)) - THEN - (* ;; "send a reset sequence to the fx-80...") - - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC)) - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE @)) - - (* ;; "...and set the form length") - - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE ESC)) - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE C)) - (\FASTFX80.BOUT FASTFX80STREAM (FIXR (TIMES INCHES-PER-PAGE \FASTFX80.LINESPERINCH))) - ELSE (ERROR "Illegal page length value" INCHES-PER-PAGE))) - -(CL:DEFUN \FASTFX80.OUTPUT-SIGNATURE (FASTFX80STREAM) - - (* ;; "start the file with an identifying signature. Ensure it is not printed by following it with an equal number of ASCII 127's.") - - (* ;; "This will not work if SIGNATURE contains line-ending characters.") - - (LET ((DEL-BYTE 127)) - (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM BYTE)) - (FOR BYTE INSTRING \FASTFX80.FILE-SIGNATURE DO (\FASTFX80.BOUT FASTFX80STREAM DEL-BYTE)))) -(DEFINEQ - -(\FASTFX80.CLOSE - [LAMBDA (FASTFX80STREAM) (* ; "Edited 2-Jun-87 19:11 by Snow") - - (* ;; "close a fast fx80 stream ") - - (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) - (\FASTFX80.OUTCHAR FASTFX80STREAM (CHARCODE CR)) - - (* ;; - "do a bout here because an outchar will cause a new-page which then adds 4 lines to the output.") - - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE FF)) - (\CLOSEFILE (FASTFX80DATA-BACKINGSTREAM DATA)) - (fetch (STREAM FULLFILENAME) of FASTFX80STREAM]) -) - - - -(* ;; "methods that hack fonts") - -(DEFINEQ - -(\FASTFX80.CHANGEFONT - [LAMBDA (STREAM FONT) (* ; "Edited 14-Aug-87 14:40 by Snow") - - (* ;; "font-change method for the fast fx-80 device") - - (WITH-FASTFX80-DATA (DATA STREAM) - (PROG1 (FASTFX80DATA-FONT DATA) - (COND - (FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL 'FASTFX80)) - (COND - ((NEQ FONT (FASTFX80DATA-FONT DATA)) - [LET [[ITALICP (FMEMB 'ITALIC (FONTPROP FONT 'FACE] - [BOLDP (FMEMB 'BOLD (FONTPROP FONT 'FACE] - (UNDERLINE-NESS 128) - (ITALIC-NESS 64) - (EXPANDED-NESS 32) - (DOUBLE-STRIKE-NESS 16) - (EMPHASIZED-NESS 8) - (COMPRESSED-NESS 4) - (ELITE-NESS 1) - (PICA-NESS 0) - (SIZE (FONTPROP FONT 'SIZE] - - (* ;; "Send master select code and inform printer of boldness, italicism, and new font size: pica for regular sized fonts, emphasized pica for large fonts.") - - (\FASTFX80.BOUT STREAM (CHARCODE ESC)) - (\FASTFX80.BOUT STREAM (CHARCODE !)) - [\FASTFX80.BOUT STREAM (LOGOR (COND - (ITALICP ITALIC-NESS) - (T PICA-NESS)) - (COND - (BOLDP EMPHASIZED-NESS) - (T PICA-NESS)) - (COND - ((> SIZE 12) - EXPANDED-NESS) - ((<= SIZE 8) - COMPRESSED-NESS) - (T PICA-NESS] - - (* ;; "Set italicness, since FX-80 doesn't support the ITALIC bit in master reset.") - - (\FASTFX80.BOUT STREAM (CHARCODE ESC)) - (COND - (ITALICP (* ; "turn it on") - - (\FASTFX80.BOUT STREAM (CHARCODE 4))) - (T (* ; "turn it off") - - (\FASTFX80.BOUT STREAM (CHARCODE 5] - (CL:SETF (FASTFX80DATA-FONT DATA) - FONT]) - -(\FASTFX80.FONTCREATE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* hdj "27-Oct-86 14:59") - - (* ;; " create and return a fontdescriptor for a fastfx80 font") - - (LET ((FONTDESC (create FONTDESCRIPTOR - FONTDEVICE _ 'FASTFX80 - FONTFAMILY _ FAMILY - FONTSIZE _ SIZE - FONTFACE _ FACE - ROTATION _ ROTATION - FONTSCALE _ 1 - \SFHeight _ 9 - \SFAscent _ 7 - \SFDescent _ 2))) - (if (\GETCHARSETINFO CHARSET FONTDESC T) - then FONTDESC - else NIL]) - -(\FASTFX80.CREATECHARSET - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC) - (* hdj "27-Oct-86 14:57") - - (* ;; "Create a character set for the fast fx-80. Really only works for char set 0; returns the same info for all sets.") - - (* * (if (NEQ 0 CHARSET) then (ERROR "FX-80 does not support NS characters."))) - - (LET ((WIDTHS (\CREATECSINFOELEMENT))) - (for C from 32 to 254 do (\FSETWIDTH WIDTHS C (\FASTFX80.SUBCHARWIDTH - C SIZE))) - (create CHARSETINFO - WIDTHS _ WIDTHS - IMAGEWIDTHS _ WIDTHS - YWIDTHS _ (\CREATECSINFOELEMENT) - CHARSETASCENT _ (ffetch \SFAscent of FONTDESC) - CHARSETDESCENT _ (ffetch \SFDescent of FONTDESC]) -) - -(CL:DEFUN \FASTFX80.INIT-FONT-PROFILE () - - (* ;; "set up the fonts for the FASTFX80, based on the DISPLAY font profile entries") - - [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT COMMENTFONT - TEXTFONT) DO (\ADD-TO-FONTPROFILE FONTPROFILE FONT-CLASS 'FASTFX80 - (\GET-FROM-FONTPROFILE FONTPROFILE FONT-CLASS - 'DISPLAY] - (FONTPROFILE FONTPROFILE) - T) - - - -(* ;; "methods for measuring") - -(DEFINEQ - -(\FASTFX80.STRINGWIDTH - [LAMBDA (FASTFX80STREAM STRING RDTBL) (* hdj " 6-Nov-86 15:15") - - (* ;; - " returns STRING's width, relative to STREAM's current font and the readtable RDTBL") - - (if RDTBL - then (bind (FIRSTFLG _ T) - (SA _ (fetch READSA of RDTBL)) - (ESCAPE-CHAR-WIDTH _ (\FASTFX80.CHARWIDTH FASTFX80STREAM - (fetch (READTABLEP ESCAPECHAR) of RDTBL)) - ) - (SYN _ NIL) for CHARCODE instring STRING - sum (PROG1 (+ (\FASTFX80.CHARWIDTH FASTFX80STREAM CHARCODE) - (IF (AND (fetch (READCODE ESCQUOTE) - of (SETQ SYN (\SYNCODE SA CHARCODE))) - (OR FIRSTFLG (fetch (READCODE INNERESCQUOTE) - of SYN))) - THEN ESCAPE-CHAR-WIDTH - ELSE 0)) - (SETQ FIRSTFLG NIL))) - else (for CHAR instring STRING sum (\FASTFX80.CHARWIDTH FASTFX80STREAM CHAR - ]) - -(\FASTFX80.CHARWIDTH - [LAMBDA (STREAM CHARCODE) (* ; "Edited 4-Feb-87 15:52 by hdj") - - (* ;; " returns the width of CHARCODE, relative to STREAM's current font") - - (WITH-FASTFX80-DATA (DATA STREAM) - (LET [(WIDTH (\FASTFX80.SUBCHARWIDTH (\FASTFX80.TRANSLATE-CHAR CHARCODE) - (FONTPROP (FASTFX80DATA-FONT DATA) - 'SIZE] - (IF (EQ CHARCODE (CHARCODE SPACE)) - THEN (FIXR (TIMES WIDTH (FASTFX80DATA-SPACEFACTOR DATA))) - ELSE WIDTH]) - -(\FASTFX80.SUBCHARWIDTH - [LAMBDA (CHARCODE SIZE) (* ; "Edited 21-Jan-88 12:10 by jds") - - (* ;; "Computes the size for a single character in Fast-FX80 mode.") - - (COND - ((IGEQ CHARCODE 31) (* ; - "Only non-control characters have real widths") - - (COND - ((GREATERP SIZE 12) (* ; - "Fonts bigger than 12 are printed EXPANDED.") - - 14) - ((<= SIZE 8) (* ; - "Sizes 8 & under are printed compressed, 17.16 pitch, or 4.19 dots per") - - 4) - (T (* ; - "Should really be 7.2 dots, but this is close.") - - 7))) - (T 0]) -) - -(CL:DEFUN \FASTFX80.SPACEFACTOR (FASTFX80STREAM FACTOR) - - (* ;; "returns/sets the width of the space character (32 ASCII) for FASTFX80STREAM") - - [WITH-FASTFX80-DATA (DATA FASTFX80STREAM) - (PROG1 (FASTFX80DATA-SPACEFACTOR DATA) - (AND FACTOR (IF (NUMBERP FACTOR) - THEN (CL:SETF (FASTFX80DATA-SPACEFACTOR DATA) - FACTOR) - ELSE (\ILLEGAL.ARG FACTOR))))]) - - - -(* ;; "methods that affect the current position/size of drawing surface") - -(DEFINEQ - -(\FASTFX80.CLIPPINGREGION - [LAMBDA (STREAM REGION) (* ; "Edited 8-Dec-86 15:16 by hdj") - - (* ;; - "Returns old clipping region and sets new one. will never set onelarger than the paper size.") - - (DECLARE (GLOBALVARS \FASTFX80.PAGESIZE)) - (WITH-FASTFX80-DATA (DATA STREAM) - (PROG1 (COPY (FASTFX80DATA-CLIPPINGREGION DATA)) - (AND REGION (CL:SETF (FASTFX80DATA-CLIPPINGREGION DATA) - (INTERSECTREGIONS REGION (CREATEREGION 0 0 ( - FASTFX80DATA-PAPER-WIDTH - DATA) - (FASTFX80DATA-PAPER-HEIGHT - DATA]) - -(\FASTFX80.MOVETO - [LAMBDA (STREAM X Y) (* hdj "27-Oct-86 11:40") - - (* ;; " move to (X,Y) on STREAM's drawing surface") - - (\FASTFX80.XPOSITION STREAM X) - (\FASTFX80.YPOSITION STREAM Y]) - -(\FASTFX80.XPOSITION - [LAMBDA (FASTFX80STREAM XPOS) (* hdj "20-Nov-86 17:50") - - (* ;; "Return old x-position, optionally move to new one. If new position would lie outside the clipping region, set the virtual x position, but don't change the real x position or move the printer's print head.") - - (WITH-FASTFX80-DATA - (DATA FASTFX80STREAM) - (LET ((OLD-REAL-XPOS (FASTFX80DATA-REAL-XPOS DATA)) - (OLD-VIRTUAL-XPOS (FASTFX80DATA-VIRTUAL-XPOS DATA)) - (CLIPPINGREGION (FASTFX80DATA-CLIPPINGREGION DATA))) - (PROG1 OLD-VIRTUAL-XPOS - (if XPOS - then - - (* ;; "Space or backspace till new x-pos approximates desired position") - - (LET ((LEFT-BORDER (fetch (REGION LEFT) of CLIPPINGREGION)) - (RIGHT-BORDER (fetch (REGION RIGHT) of CLIPPINGREGION))) - (if (AND (LEQ LEFT-BORDER XPOS) - (LEQ XPOS RIGHT-BORDER)) - then (if (AND (EQP (FASTFX80DATA-LEFTMARGIN DATA) - 0) - (EQP XPOS 0)) - then (* ; "if we can, just send a CR") - - (\FASTFX80.BOUT FASTFX80STREAM - (CHARCODE CR)) - else (* ; "otherwise do the full schmeer") - - (\FASTFX80.SMART-XPOSITION OLD-REAL-XPOS XPOS - FASTFX80STREAM)) - (CL:SETF (FASTFX80DATA-REAL-XPOS DATA) - XPOS))) - (CL:SETF (FASTFX80DATA-VIRTUAL-XPOS DATA) - XPOS]) - -(\FASTFX80.YPOSITION - [LAMBDA (STREAM YPOS) (* ; "Edited 9-Dec-86 22:43 by hdj") - - (* ;; "Return old y position, optionally move to new one. If new position would lie outside the clipping region, set the virtual Y position, but don't change the real Y position or move the printer's print head.") - - (WITH-FASTFX80-DATA - (DATA STREAM) - (LET ((OLD-REAL-YPOS (FASTFX80DATA-REAL-YPOS DATA)) - (OLD-VIRTUAL-YPOS (FASTFX80DATA-VIRTUAL-YPOS DATA)) - (CLIPPINGREGION (FASTFX80DATA-CLIPPINGREGION DATA))) - (PROG1 OLD-VIRTUAL-YPOS - (if YPOS - then [if (NOT (EQP YPOS OLD-REAL-YPOS)) - then (LET ((TOP-BORDER (fetch (REGION TOP) of - CLIPPINGREGION - )) - (BOTTOM-BORDER (fetch (REGION BOTTOM) - of CLIPPINGREGION))) - (if (NOT (EQP YPOS OLD-REAL-YPOS)) - then (LET [(DOTS-TO-MOVE (FIX (- YPOS - OLD-REAL-YPOS - ] - (if (MINUSP DOTS-TO-MOVE) - then ( - \FASTFX80.ADVANCE.PAPER - STREAM DOTS-TO-MOVE) - else ( - \FASTFX80.BACKUP.PAPER - STREAM DOTS-TO-MOVE))) - (CL:SETF (FASTFX80DATA-REAL-YPOS DATA) - YPOS] - (CL:SETF (FASTFX80DATA-VIRTUAL-YPOS DATA) - YPOS]) - -(\FASTFX80.BACKUP.PAPER - [LAMBDA (STREAM DOTS) (* hdj "28-Oct-86 12:59") - - (* ;; "backup the page DOTS raster lines") - - (SETQ DOTS (TIMES 3 (ABS DOTS))) - (while (GREATERP DOTS 0) do (\FASTFX80.BOUT STREAM (CHARCODE ESC)) - (\FASTFX80.BOUT STREAM (CHARCODE j)) - (\FASTFX80.BOUT STREAM (LET ((MAXBACKUP (MIN DOTS 255))) - (add DOTS (MINUS MAXBACKUP - )) - MAXBACKUP]) - -(\FASTFX80.ADVANCE.PAPER - [LAMBDA (STREAM DOTS) (* hdj "28-Oct-86 12:58") - - (* ;; "advance the page DOTS raster lines") - - (SETQ DOTS (TIMES 3 (ABS DOTS))) - (while (GREATERP DOTS 0) do (\FASTFX80.BOUT STREAM (CHARCODE ESC)) - (\FASTFX80.BOUT STREAM (CHARCODE J)) - (\FASTFX80.BOUT STREAM (LET ((MAXADVANCE (MIN DOTS 255))) - (add DOTS (MINUS - MAXADVANCE - )) - MAXADVANCE]) - -(\FASTFX80.NEWPAGE - [LAMBDA (FASTFX80STREAM) (* ; "Edited 17-Dec-86 10:32 by hdj") - - (* ;; "End the old page, start a new one") - - (* ;; "Just send a form-feed") - - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE FF)) - (\FASTFX80.STARTPAGE FASTFX80STREAM]) - -(\FASTFX80.OUTCHAR - [LAMBDA (FASTFX80STREAM CHARCODE) (* ; "Edited 12-Feb-87 09:08 by jds") - - (* ;; "outcharfn for fastfx80 imagestreams") - - (LET ((TRANSLATED-CHAR (\FASTFX80.TRANSLATE-CHAR CHARCODE))) - (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) - (SELCHARQ CHARCODE - (^L (\FASTFX80.NEWPAGE FASTFX80STREAM)) - ((CR EOL) - (\FASTFX80.NEWLINE FASTFX80STREAM)) - (LF (\FASTFX80.LINEFEED FASTFX80STREAM)) - (SPACE [\FASTFX80.XPOSITION FASTFX80STREAM (+ (\FASTFX80.XPOSITION - FASTFX80STREAM) - (\FASTFX80.CHARWIDTH - FASTFX80STREAM - (CHARCODE SPACE] - (COND - ((> (FASTFX80DATA-VIRTUAL-XPOS DATA) - (FASTFX80DATA-RIGHTMARGIN DATA)) - (\FASTFX80.NEWLINE FASTFX80STREAM)))) - (COND - ((GREATERP CHARCODE 32) - - (* ;; "only print graphic characters") - - (LET ((CHARWIDTH (\FASTFX80.CHARWIDTH FASTFX80STREAM TRANSLATED-CHAR))) - - (* ;; "if character will be visible, output it") - - (COND - ((\FASTFX80.CUR-POS-VISIBLE? DATA) - (\FASTFX80.BOUT FASTFX80STREAM TRANSLATED-CHAR))) - (CL:INCF (FASTFX80DATA-REAL-XPOS DATA) - CHARWIDTH) - (CL:INCF (FASTFX80DATA-VIRTUAL-XPOS DATA) - CHARWIDTH) - - (* ;; "if we've passed the margin, DING!, do a newline") - - (COND - ((> (FASTFX80DATA-VIRTUAL-XPOS DATA) - (FASTFX80DATA-RIGHTMARGIN DATA)) - (\FASTFX80.NEWLINE FASTFX80STREAM]) - -(\FASTFX80.NEWLINE - [LAMBDA (FASTFX80STREAM) (* hdj "11-Nov-86 14:02") - - (* ;; -"perform a newline on a fastfx80 imagestream. if we go below the bottom margin, start a new page.") - - (DECLARE (GLOBALVARS \FASTFX80.LINEHEIGHT)) - (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) - (LET ((NEW-Y (- (FASTFX80DATA-VIRTUAL-YPOS DATA) - \FASTFX80.LINEHEIGHT))) - (if (< NEW-Y (FASTFX80DATA-BOTTOMMARGIN DATA)) - then (\FASTFX80.NEWPAGE FASTFX80STREAM) - else (* ; "move to the left margin") - - (\FASTFX80.XPOSITION FASTFX80STREAM (FASTFX80DATA-LEFTMARGIN DATA)) - (FREPLACE (STREAM CHARPOSITION) OF FASTFX80STREAM WITH 0) - (* ; "then move down or newpage") - - (\FASTFX80.YPOSITION FASTFX80STREAM NEW-Y]) - -(\FASTFX80.LINEFEED - [LAMBDA (FASTFX80STREAM) (* hdj " 6-Nov-86 15:38") - - (* ;; "move down 1 line, leaving the x-position alone") - - (DECLARE (GLOBALVARS \FASTFX80.LINEHEIGHT)) - (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) - (LET ((NEW-YPOS (- (FASTFX80DATA-VIRTUAL-YPOS DATA) - \FASTFX80.LINEHEIGHT)) - (OLD-XPOS (FASTFX80DATA-VIRTUAL-XPOS DATA))) - (if (< NEW-YPOS (FASTFX80DATA-BOTTOMMARGIN DATA)) - then (* ; "move to a new page") - - (\FASTFX80.NEWPAGE FASTFX80STREAM) - (* ; "restore the old x position") - - (\FASTFX80.XPOSITION FASTFX80STREAM OLD-XPOS) - else (* ; "move down") - - (\FASTFX80.YPOSITION FASTFX80STREAM NEW-YPOS]) - -(\FASTFX80.DRAWLINE - [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) - (* hdj "31-Oct-86 14:09") - - (* ;; "dummy drawline for the fast fx80 device") - - (MOVETO X2 Y2 STREAM]) -) - -(CL:DEFUN \FASTFX80.STARTPAGE (FASTFX80STREAM) - (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) - (LET [(ASCENT (FONTPROP (DSPFONT NIL FASTFX80STREAM) - 'ASCENT] - - (* ;; "set the %"actual%" position of printhead on paper after a newpage, then let the driver figure out how to get to (leftmargin, topmargin).") - - (CL:SETF (FASTFX80DATA-VIRTUAL-XPOS DATA) - 0) - (CL:SETF (FASTFX80DATA-REAL-XPOS DATA) - 0) - (CL:SETF (FASTFX80DATA-VIRTUAL-YPOS DATA) - (FASTFX80DATA-PAPER-HEIGHT DATA)) - (CL:SETF (FASTFX80DATA-REAL-YPOS DATA) - (FASTFX80DATA-PAPER-HEIGHT DATA)) - - (* ;; "move the paper") - - (MOVETO (FASTFX80DATA-LEFTMARGIN DATA) - (- (FASTFX80DATA-TOPMARGIN DATA) - ASCENT) - FASTFX80STREAM) - FASTFX80STREAM))) - -(CL:DEFUN \FASTFX80.SMART-XPOSITION (CURRENT-XPOS DESIRED-XPOS FASTFX80STREAM) - - (* ;; "if it would create less output to space from the left margin, rather than to backspace from the current position, do so") - - (LET* ((SPACEWIDTH (\FASTFX80.CHARWIDTH FASTFX80STREAM (CHARCODE SP))) - (CURRENT-XPOS-IN-SPACES (IQUOTIENT CURRENT-XPOS SPACEWIDTH)) - (DESIRED-XPOS-IN-SPACES (IQUOTIENT DESIRED-XPOS SPACEWIDTH)) - (NUM-BACKSPACES-NEEDED (- CURRENT-XPOS-IN-SPACES DESIRED-XPOS-IN-SPACES))) - (IF (< NUM-BACKSPACES-NEEDED DESIRED-XPOS-IN-SPACES) - THEN - (* ;; "if backspacing's cheaper, backspace away") - - (\FASTFX80.HORIZONTAL (- NUM-BACKSPACES-NEEDED) - FASTFX80STREAM) - ELSE - (* ;; "otherwise, go to the left margin... ") - - (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE CR)) - - (* ;; "... and then space to the right spot") - - (\FASTFX80.HORIZONTAL DESIRED-XPOS-IN-SPACES FASTFX80STREAM)))) - -(CL:DEFUN \FASTFX80.TOPMARGIN (STREAM &OPTIONAL YPOSITION) - [WITH-FASTFX80-DATA (DATA STREAM) - (PROG1 (FASTFX80DATA-TOPMARGIN DATA) - (AND YPOSITION (IF (SMALLP YPOSITION) - THEN (CL:SETF (FASTFX80DATA-TOPMARGIN DATA) - YPOSITION) - ELSE (\ILLEGAL.ARG YPOSITION))))]) - -(CL:DEFUN \FASTFX80.BOTTOMMARGIN (STREAM &OPTIONAL YPOSITION) - [WITH-FASTFX80-DATA (DATA STREAM) - (PROG1 (FASTFX80DATA-BOTTOMMARGIN DATA) - (AND YPOSITION (IF (SMALLP YPOSITION) - THEN (CL:SETF (FASTFX80DATA-BOTTOMMARGIN DATA) - YPOSITION) - ELSE (\ILLEGAL.ARG YPOSITION))))]) - -(CL:DEFUN \FASTFX80.LEFTMARGIN (STREAM &OPTIONAL XPOSITION) - [WITH-FASTFX80-DATA (DATA STREAM) - (PROG1 (FASTFX80DATA-LEFTMARGIN DATA) - (AND XPOSITION (IF (SMALLP XPOSITION) - THEN (CL:SETF (FASTFX80DATA-LEFTMARGIN DATA) - XPOSITION) - ELSE (\ILLEGAL.ARG XPOSITION))))]) - -(CL:DEFUN \FASTFX80.RIGHTMARGIN (STREAM &OPTIONAL XPOSITION) - [WITH-FASTFX80-DATA (DATA STREAM) - (PROG1 (FASTFX80DATA-RIGHTMARGIN DATA) - (AND XPOSITION (IF (SMALLP XPOSITION) - THEN (CL:SETF (FASTFX80DATA-RIGHTMARGIN DATA) - XPOSITION) - ELSE (\ILLEGAL.ARG XPOSITION))))]) - -(DEFMACRO \FASTFX80.CUR-POS-VISIBLE? (FASTFX80DATA) - `(INSIDEP (FASTFX80DATA-CLIPPINGREGION ,FASTFX80DATA) - (FASTFX80DATA-REAL-XPOS ,FASTFX80DATA) - (FASTFX80DATA-REAL-YPOS ,FASTFX80DATA))) - -(CL:DEFUN \FASTFX80.HORIZONTAL (SPACES FASTFX80STREAM) - - (* ;; "print SPACES space characters if SPACES > 0, print SPACES backspaces if < 0, and do nothing if SPACES=0.") - - [if (MINUSP SPACES) - then (for SPACE from 1 to (ABS SPACES) by 1 do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE BS))) - else (for SPACE from 1 to SPACES by 1 do (\FASTFX80.BOUT FASTFX80STREAM (CHARCODE SP]) - - - -(* ;; "printer code") - - -(CL:DEFUN \FASTFX80.SEND (PRINTER FILENAME &OPTIONAL OPTIONS) - - (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS. Since we only have one fx-80 per machine, ignore PRINTER and send to FASTFX80-DEFAULT-DESTINATION") - - (DECLARE (GLOBALVARS FASTFX80-DEFAULT-DESTINATION)) - [LET [(COPIES (LISTGET OPTIONS '%#COPIES] - (FOR COPY FROM 1 TO COPIES DO - (* ;; "allow the user to abort it while running") - - (WITH-ABORT-WINDOW ((THIS.PROCESS) - FILENAME PRINTER COPY) - (COPYFILE FILENAME FASTFX80-DEFAULT-DESTINATION - '((TYPE FASTFX80]) - -(CL:DEFUN MAKE-FASTFX80 (FILE FASTFX80FILE &OPTIONAL FONTS HEADING TABS OPTIONS) - - (* ;; "turn FILE into a FASTFX80 master") - - (TEXTTOIMAGEFILE FILE FASTFX80FILE 'FASTFX80 FONTS HEADING TABS OPTIONS)) - -(CL:DEFUN FASTFX80FILEP (FASTFX80FILE?) - - (* ;; "is FILE (a filename or stream) a fastfx80 file?") - - [LET [(FILE-TYPE (GETFILEINFO FASTFX80FILE? 'TYPE] - (IF (EQ FILE-TYPE 'FASTFX80) - THEN (* ; - "if file has a type, and type=FASTFX80, we win") - T - ELSE (* ; - "no filetype or filetype not FASTFX80, so read the file") - (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING FASTFX80FILE?) - 'INPUT - 'OLD - '(SEQUENTIAL] - - (* ;; "file looks like ESC@ESCCn...") - - (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH) - (+ 5 (NCHARS \FASTFX80.FILE-SIGNATURE))) - - (* ;; "yuck...") - - (EQ (CHARCODE ESC) - (BIN STREAM)) - (EQ (CHARCODE @) - (BIN STREAM)) - (EQ (CHARCODE ESC) - (BIN STREAM)) - (EQ (CHARCODE C) - (BIN STREAM)) - (BIN STREAM) - (FOR CH INSTRING \FASTFX80.FILE-SIGNATURE - ALWAYS (EQ CH (BIN STREAM] - (CLOSEF STREAM]) - -(CL:DEFUN \FASTFX80.CANNOT-PRINT-BITMAPS (&OPTIONAL FILE BITMAP SCALEFACTOR REGION ROTATION TITLE) - (PRINTOUT PROMPTWINDOW "Sorry, FASTFX80 cannot render graphics." T "Use HQFX80 instead.")) -(DEFINEQ - -(\FASTFX80.CONVERT-TEDIT - [LAMBDA (TEDIT-FILE IMAGESTREAM) (* ; "Edited 11-Dec-86 17:29 by hdj") - - (* ;; "Send the text to the printer.") - - (SETQ TEDIT-FILE (OPENTEXTSTREAM TEDIT-FILE)) - (TEDIT.FORMAT.HARDCOPY TEDIT-FILE IMAGESTREAM T NIL NIL NIL 'FASTFX80) - (CLOSEF? IMAGESTREAM) - IMAGESTREAM]) -) - - - -(* ;; "Character transmission method") - -(DEFINEQ - -(\FASTFX80.BOUT - [LAMBDA (FASTFX80STREAM BYTE) (* hdj "27-Oct-86 11:51") - - (* ;; "send a byte to the fx80") - - (WITH-FASTFX80-DATA (DATA FASTFX80STREAM) - (BOUT (FASTFX80DATA-BACKINGSTREAM DATA) - BYTE]) -) - - - -(* ;; "Miscellany") - - -(DEFMACRO \FASTFX80.TRANSLATE-CHAR (CHARCODE) - `(SELCHARQ ,CHARCODE - (357,146 (* ; "bullet") - (CHARCODE *)) - (357,45 (* ; "em-dash") - 95) - (357,44 (* ; "en-dash") - 45) - (\CHAR8CODE ,CHARCODE))) - -(DEFMACRO WITH-FASTFX80-DATA ((VAR-NAME STREAM) - &BODY - (BODY DECLS ENV)) - `(LET [(,VAR-NAME (FETCH (STREAM IMAGEDATA) OF ,STREAM] - ,@DECLS - ,@BODY)) -(DECLARE%: EVAL@COMPILE - -(RPAQQ \FASTFX80.DOTSPERINCH 72) - -(RPAQQ \FASTFX80.LINESPERINCH 6) - -(RPAQQ \FASTFX80.LINEHEIGHT 12) - -(RPAQ \FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 ") - - -(CONSTANTS (\FASTFX80.DOTSPERINCH 72) - (\FASTFX80.LINESPERINCH 6) - (\FASTFX80.LINEHEIGHT 12) - (\FASTFX80.FILE-SIGNATURE "FastFX-80/Xerox/1.0 ")) -) - -(RPAQ? FASTFX80-DEFAULT-DESTINATION "{TTY}") - -(RPAQ? \FASTFX80.INCHES-PER-PAGE 11) - -(RPAQ? \FASTFX80.INCHES-PER-LINE 8.5) - - - -(* ;; "need to load these exports") - -(DECLARE%: EVAL@LOAD EVAL@COMPILE DONTCOPY - -(FILESLOAD (LOADCOMP) - ADISPLAY) -) - -(RPAQQ FX-80.HIGH-QUALITY-DRIVERCOMS - [ - (* ;; "High-quality driver") - - - (* ;; "") - - (STRUCTURES HQFX80DATA) - (FNS \HQFX80.INIT) - (COMS - (* ;; "imagestream methods") - - (COMS - (* ;; "opening/closing imagestream") - - (COMS (FNS OPENHQFX80STREAM) - (FUNCTIONS \HQFX80.PREAMBLE \HQFX80.RESET-PRINTER \HQFX80.OUTPUT-SIGNATURE) - ) - (FNS \HQFX80.CLOSE)) - (COMS - (* ;; "methods that hack fonts") - - (FNS \HQFX80.FONTCREATE \HQFX80.CHANGEFONT \HQFX80.CREATECHARSET - \HQFX80.CHANGE-CHARSET \HQFX80.READ-FONT-FILE \HQFX80.SEARCH-FONTS) - (FUNCTIONS \HQFX80.INIT-FONT-PROFILE)) - (COMS - (* ;; "methods for measuring") - - (FNS \HQFX80.CHARWIDTH \HQFX80.STRINGWIDTH) - (FUNCTIONS \HQFX80.SPACEFACTOR)) - (COMS - (* ;; "methods that affect the current position/size of drawing surface") - - (FNS \HQFX80.CLIPPINGREGION \HQFX80.LEFTMARGIN \HQFX80.RIGHTMARGIN - \HQFX80.TOPMARGIN \HQFX80.BOTTOMMARGIN \HQFX80.XPOSITION \HQFX80.YPOSITION - \HQFX80.NEWLINE \HQFX80.NEWPAGE \HQFX80.LINEFEED \HQFX80.RESET - \HQFX80.STARTPAGE) - (FUNCTIONS \HQFX80.CUR-POS-VISIBLE?)) - (COMS - (* ;; "graphical operations") - - (RESOURCES \HQFX80.BRUSHBBT) - (FNS \HQFX80.BITBLT \HQFX80.BLTSHADE \HQFX80.DRAWELLIPSE \HQFX80.OPERATION - \HQFX80.DRAWPOINT) - (FNS \HQFX80.DRAWLINE \HQFX80.CLIP-AND-DRAW-LINE \HQFX80.CLIP-AND-DRAW-LINE1) - (COMS (FNS \HQFX80.DRAWCIRCLE \HQFX80.CREATE-BRUSH-BBT) - (FUNCTIONS \HQFX80.DRAW-4-CIRCLE-POINTS)) - (COMS (FNS \HQFX80.FILLCIRCLE \HQFX80.DRAWARC) - (FUNCTIONS \HQFX80.FILL-CIRCLE-BLT)) - (COMS - (* ;; "curve-drawing") - - (FNS \HQFX80.DRAWCURVE \HQFX80.DRAWCURVE2 \HQFX80.DRAWCURVE3 - \HQFX80.LINEWITHBRUSH) - (FNS \HQFX80.BBTCURVEPT) - (MACROS \HQFX80.CURVEPT) - (FUNCTIONS \HQFX80.SMOOTH-CURVE .SETUP.FOR.\HQFX80.BBTCURVEPT.))) - (COMS - (* ;; "character printing methods") - - (FNS \HQFX80.OUTCHAR \HQFX80.BLT-CHAR)) - (COMS - (* ;; "printer code") - - (FNS \HQFX80.DUMP-PAGE-BUFFER \HQFX80.ADVANCE-8-LINES) - (FUNCTIONS \HQFX80.EIGHT-LINES-BLANK? \HQFX80.BITMAP-LDB \HQFX80.CLEAR-SCANLINE - \HQFX80.CLEAR-WORD-BOX) - (FUNCTIONS \HQFX80.SEND MAKE-HQFX80 HQFX80FILEP)) - (COMS - (* ;; "window hardcopy") - - (FNS \HQFX80.BITMAP-FILE \HQFX80.CONVERT-TEDIT)) - (COMS - (* ;; "character transmission method") - - (FNS \HQFX80.BOUT)) - (COMS - (* ;; "handling font-information caching") - - (FNS \HQFX80.FIX-LINE-LENGTH \HQFX80.FIX-FONT \HQFX80.FIX-Y) - (FUNCTIONS \HQFX80.INVALIDATE-CACHE \HQFX80.INVALIDATE-FONT-CACHE - \HQFX80.GET-CACHED-CHAR-WIDTH \HQFX80.GET-CHARACTER-OFFSET)) - (COMS - (* ;; "auxiliary functions") - - (FUNCTIONS \HQFX80.GRAPHICS-MODE) - (FNS \HQFX80.PRINTER-MODE) - (FUNCTIONS WITH-HQFX80-DATA)) - - (* ;; "and miscellany") - - (CONSTANTS (\HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ") - (\HQFX80.1-TO-1-MODE-DPI 72) - (\HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120)) - (INITVARS (\HQFX80.INCHES-PER-PAGE 11) - (\HQFX80.INCHES-PER-LINE 8.5) - (HQFX80-DEFAULT-DESTINATION "{TTY}") - (HQFX80-FONT-EXTENSIONS DISPLAYFONTEXTENSIONS) - (HQFX80-FONT-DIRECTORIES DISPLAYFONTDIRECTORIES) - (HQFX80-FONT-COERCIONS DISPLAYFONTCOERCIONS) - (HQFX80-MISSING-FONT-COERCIONS DISPLAYFONTCOERCIONS]) - - - -(* ;; "High-quality driver") - - - - -(* ;; "") - - -(CL:DEFSTRUCT HQFX80DATA - - (* ;; "the imagedata vector for an HQFX80 imagestream") - - BACKINGBITMAP - BACKINGSTREAM - (XPOS 0) - (YPOS 0) - (CLIPPINGREGION (create REGION)) - LINEFEED RIGHTMARGIN (LEFTMARGIN 0) - TOPMARGIN - (BOTTOMMARGIN 0) - OPERATION SOURCETYPE (PILOTBBT (create PILOTBBT - PBTDISJOINT _ T)) - (TEXTURE WHITESHADE) - FONT - (CHARSET-ASCENT-CACHE MAX.SMALLP) - WIDTHS-CACHE OFFSETS-CACHE IMAGE-WIDTHS-CACHE (CHARSET-CACHE MAX.SMALLP) - CHARSET-DESCENT-CACHE CHARHEIGHTDELTA (SPACEWIDTH 1.0) (* ; - "a misnomer -- this is actually the space factor, not its width") - [SERIALIZING-BOX (fetch (ARRAYP BASE) of (ARRAY 1 'BYTE] - SERIALIZING-PILOTBBT SCRATCH-SCANLINE SCRATCH-SCANLINE-PILOTBBT [EIGHT-LINES-BLANK - (fetch (ARRAYP BASE) - of (ARRAY 1 'WORD] - EIGHT-LINES-BLANK-PILOTBBT COMPRESSED?) -(DEFINEQ - -(\HQFX80.INIT - [LAMBDA NIL (* ; "Edited 3-Feb-87 17:23 by hdj") - - (* ;; "Initializes global variables for the FX80") - - (DECLARE (GLOBALVARS DEFAULTPRINTINGHOST IMAGESTREAMTYPES PRINTERTYPES PRINTFILETYPES - \HQFX80.IMAGEOPS \HQFX80.FDEV)) - (SETQ \HQFX80.FDEV (create FDEV - DEVICENAME _ (LIST 'HQFX80 'PRINTER) - CLOSEFILE _ (FUNCTION NILL) - BOUT _ (FUNCTION \HQFX80.OUTCHAR))) - (SETQ \HQFX80.IMAGEOPS (create IMAGEOPS - IMAGETYPE _ 'HQFX80 - IMFONT _ (FUNCTION \HQFX80.CHANGEFONT) - IMLEFTMARGIN _ (FUNCTION \HQFX80.LEFTMARGIN) - IMRIGHTMARGIN _ (FUNCTION \HQFX80.RIGHTMARGIN) - IMTOPMARGIN _ (FUNCTION \HQFX80.TOPMARGIN) - IMBOTTOMMARGIN _ (FUNCTION \HQFX80.BOTTOMMARGIN) - IMLINEFEED _ (FUNCTION \HQFX80.LINEFEED) - IMXPOSITION _ (FUNCTION \HQFX80.XPOSITION) - IMYPOSITION _ (FUNCTION \HQFX80.YPOSITION) - IMCLOSEFN _ (FUNCTION \HQFX80.CLOSE) - IMDRAWCURVE _ (FUNCTION \HQFX80.DRAWCURVE) - IMFILLCIRCLE _ (FUNCTION \HQFX80.FILLCIRCLE) - IMDRAWLINE _ (FUNCTION \HQFX80.DRAWLINE) - IMDRAWELLIPSE _ (FUNCTION \HQFX80.DRAWELLIPSE) - IMDRAWCIRCLE _ (FUNCTION \HQFX80.DRAWCIRCLE) - IMBITBLT _ (FUNCTION \HQFX80.BITBLT) - IMBLTSHADE _ (FUNCTION \HQFX80.BLTSHADE) - IMNEWPAGE _ (FUNCTION \HQFX80.NEWPAGE) - IMSCALE _ [FUNCTION (LAMBDA NIL 1] - IMSPACEFACTOR _ (FUNCTION \HQFX80.SPACEFACTOR) - IMFONTCREATE _ 'HQFX80 - IMCOLOR _ (FUNCTION NILL) - IMBACKCOLOR _ (FUNCTION NILL) - IMOPERATION _ (FUNCTION \HQFX80.OPERATION) - IMSTRINGWIDTH _ (FUNCTION \HQFX80.STRINGWIDTH) - IMCHARWIDTH _ (FUNCTION \HQFX80.CHARWIDTH) - IMCLIPPINGREGION _ (FUNCTION \HQFX80.CLIPPINGREGION) - IMRESET _ (FUNCTION \HQFX80.RESET) - IMDRAWPOINT _ (FUNCTION \HQFX80.DRAWPOINT) - IMDRAWARC _ (FUNCTION \HQFX80.DRAWARC) - IMFILLPOLYGON _ (FUNCTION POLYSHADE.BLT))) - [push IMAGESTREAMTYPES (COPYALL '(HQFX80 (OPENSTREAM OPENHQFX80STREAM) - (FONTCREATE \HQFX80.FONTCREATE) - (CREATECHARSET \HQFX80.CREATECHARSET) - (FONTSAVAILABLE \HQFX80.SEARCH-FONTS] - [push PRINTERTYPES (COPYALL '((HQFX80) - (CANPRINT (HQFX80)) - (STATUS TRUE) - (PROPERTIES NILL) - (SEND \HQFX80.SEND) - (BITMAPSCALE NIL) - (BITMAPFILE (\HQFX80.BITMAP-FILE FILE BITMAP SCALEFACTOR REGION - ROTATION TITLE] - [push PRINTFILETYPES (COPYALL '(HQFX80 (TEST HQFX80FILEP) - (EXTENSION (HQFX80)) - (CONVERSION (TEXT MAKE-HQFX80 TEDIT \HQFX80.CONVERT-TEDIT] - (push DEFAULTPRINTINGHOST (LIST 'HQFX80 'HQFX80)) - (PUTPROP 'HQFX80 'PRINTERTYPE 'HQFX80) - (\HQFX80.INIT-FONT-PROFILE) - T]) -) - - - -(* ;; "imagestream methods") - - - - -(* ;; "opening/closing imagestream") - -(DEFINEQ - -(OPENHQFX80STREAM - [LAMBDA (FILENAME OPTIONS) (* ; "Edited 29-May-87 19:30 by Snow") - - (* ;; "Opens an imagestream on a high-quality FX80") - - (LET* ([BACKING (OPENSTREAM FILENAME 'OUTPUT NIL '((SEQUENTIAL T) - (TYPE HQFX80] - (COMPRESSED? (LISTGET OPTIONS 'COMPRESSED)) - [DOTS-PER-LINE (FIX (TIMES \HQFX80.INCHES-PER-LINE (if COMPRESSED? - then - \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI - else \HQFX80.1-TO-1-MODE-DPI] - (DOTS-PER-PAGE (ITIMES 8 (CL:CEILING (FIX (TIMES \HQFX80.INCHES-PER-PAGE - (if COMPRESSED? - then - \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI - else \HQFX80.1-TO-1-MODE-DPI))) - 8))) - (BACKING-BITMAP (BITMAPCREATE DOTS-PER-LINE DOTS-PER-PAGE)) - (BACKING-BITMAP-WORD-WIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BACKING-BITMAP)) - (DATA (MAKE-HQFX80DATA :BACKINGSTREAM BACKING :CLIPPINGREGION (CREATEREGION 0 0 - DOTS-PER-LINE - DOTS-PER-PAGE) - :BACKINGBITMAP BACKING-BITMAP :RIGHTMARGIN DOTS-PER-LINE :TOPMARGIN - (- DOTS-PER-PAGE 15) - :BOTTOMMARGIN 30 :PILOTBBT (create PILOTBBT - PBTDISJOINT _ T - PBTDESTBPL _ (UNFOLD - BACKING-BITMAP-WORD-WIDTH - BITSPERWORD)) - :SCRATCH-SCANLINE - (fetch (BITMAP BITMAPBASE) of (BITMAPCREATE DOTS-PER-LINE 1)) - :OPERATION - 'REPLACE :SOURCETYPE 'INPUT :COMPRESSED? COMPRESSED?)) - (HQFX80STREAM (create STREAM - FULLFILENAME _ (FULLNAME BACKING) - DEVICE _ \HQFX80.FDEV - ACCESS _ 'OUTPUT - OUTCHARFN _ (FUNCTION \HQFX80.OUTCHAR) - STRMBOUTFN _ (FUNCTION \HQFX80.OUTCHAR) - IMAGEOPS _ \HQFX80.IMAGEOPS - USERCLOSEABLE _ T - USERVISIBLE _ T - IMAGEDATA _ DATA))) - - (* ;; - "set up the BitBLT table that transforms 8-bit columns of bitmap data into single BOUT-able bytes") - - (CL:SETF (HQFX80DATA-SERIALIZING-PILOTBBT DATA) - (create PILOTBBT - PBTDISJOINT _ T - PBTDEST _ (HQFX80DATA-SERIALIZING-BOX DATA) - PBTWIDTH _ 1 - PBTHEIGHT _ 8 - PBTSOURCEBPL _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD) - PBTDESTBPL _ 1)) - - (* ;; "set up the BitBLT table that ORs together eight sequential scanlines (for blank-line group detection) into one scanline") - - (CL:SETF (HQFX80DATA-SCRATCH-SCANLINE-PILOTBBT DATA) - (create PILOTBBT - PBTDISJOINT _ T - PBTDEST _ (HQFX80DATA-SCRATCH-SCANLINE DATA) - PBTWIDTH _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD) - PBTHEIGHT _ 8 - PBTSOURCEBPL _ (UNFOLD BACKING-BITMAP-WORD-WIDTH BITSPERWORD) - PBTDESTBPL _ 0 - PBTSOURCEBIT _ 0 - PBTDESTBIT _ 0 - PBTOPERATION _ 2)) - - (* ;; "set up the BitBLT table that ORs one scanline into one 16-bit word") - - (CL:SETF (HQFX80DATA-EIGHT-LINES-BLANK-PILOTBBT DATA) - (create PILOTBBT - PBTDISJOINT _ T - PBTSOURCE _ (HQFX80DATA-SCRATCH-SCANLINE DATA) - PBTDEST _ (HQFX80DATA-EIGHT-LINES-BLANK DATA) - PBTWIDTH _ BITSPERWORD - PBTHEIGHT _ (FOLDHI DOTS-PER-LINE BITSPERWORD) - PBTSOURCEBPL _ BITSPERWORD - PBTDESTBPL _ 0 - PBTSOURCEBIT _ 0 - PBTDESTBIT _ 0 - PBTOPERATION _ 2)) - - (* ;; "make the backing file invisible") - - (replace (STREAM USERVISIBLE) of BACKING with NIL) - - (* ;; "put the preamble on the master") - - (\HQFX80.PREAMBLE HQFX80STREAM) - HQFX80STREAM]) -) - -(CL:DEFUN \HQFX80.PREAMBLE (HQFX80STREAM) - - (* ;; "start an HQFX80 master") - - (DECLARE (GLOBALVARS \HQFX80.INCHES-PER-PAGE)) - (\HQFX80.RESET-PRINTER HQFX80STREAM \HQFX80.INCHES-PER-PAGE) - (\HQFX80.OUTPUT-SIGNATURE HQFX80STREAM) - (DSPFONT (DEFAULTFONT 'HQFX80) - HQFX80STREAM) - (\HQFX80.STARTPAGE HQFX80STREAM)) - -(CL:DEFUN \HQFX80.RESET-PRINTER (HQFX80STREAM INCHES-PER-PAGE) - - (* ;; "send a reset sequence to the fx-80") - - (IF (AND (<= 1 INCHES-PER-PAGE) - (<= INCHES-PER-PAGE 22)) - THEN - (* ;; "send a reset sequence to the fx-80...") - - (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC)) - (\HQFX80.BOUT HQFX80STREAM (CHARCODE @)) - - (* ;; "...and set the form length") - - (\HQFX80.BOUT HQFX80STREAM (CHARCODE ESC)) - (\HQFX80.BOUT HQFX80STREAM (CHARCODE C)) - (\HQFX80.BOUT HQFX80STREAM (FIXR (TIMES 6 INCHES-PER-PAGE))) - ELSE (ERROR "Illegal page length value" INCHES-PER-PAGE))) - -(CL:DEFUN \HQFX80.OUTPUT-SIGNATURE (HQFX80TREAM) - - (* ;; "start the file with an identifying signature. Ensure it is not printed by following it with an equal number of ASCII 127's.") - - (* ;; "This will not work if SIGNATURE contains line-ending characters.") - - (LET ((DEL-BYTE 127)) - (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM BYTE)) - (FOR BYTE INSTRING \HQFX80.FILE-SIGNATURE DO (\HQFX80.BOUT HQFX80TREAM DEL-BYTE)))) -(DEFINEQ - -(\HQFX80.CLOSE - [LAMBDA (HQFX80STREAM) (* ; "Edited 21-Jan-88 12:20 by jds") - - (* ;; "do the cleanup prefatory to closing the HQFX80STREAM") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) (* ; "") - - (LET ((BACKING-STREAM (HQFX80DATA-BACKINGSTREAM DATA))) - (\HQFX80.DUMP-PAGE-BUFFER (HQFX80DATA-BACKINGBITMAP DATA) - HQFX80STREAM) - (\BOUT BACKING-STREAM (CHARCODE ESCAPE)) - (\BOUT BACKING-STREAM (CHARCODE !)) - (\BOUT BACKING-STREAM 0) - (\BOUT BACKING-STREAM (CHARCODE ESCAPE)) - (\BOUT BACKING-STREAM (CHARCODE 5)) - (\CLOSEFILE BACKING-STREAM) - (fetch (STREAM FULLFILENAME) of HQFX80STREAM]) -) - - - -(* ;; "methods that hack fonts") - -(DEFINEQ - -(\HQFX80.FONTCREATE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* hdj "10-Nov-86 11:30") - - (* ;; "create a font for the hqfx80") - - (LET [(FONTDESC (create FONTDESCRIPTOR - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ SIZE - FONTFACE _ FACE - \SFAscent _ 0 - \SFDescent _ 0 - \SFHeight _ 0 - ROTATION _ ROTATION - FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE] - (AND (\GETCHARSETINFO CHARSET FONTDESC T) - FONTDESC]) - -(\HQFX80.CHANGEFONT - [LAMBDA (HQFX80STREAM FONT) (* ; "Edited 15-Jul-2025 22:01 by rmk") - (* ; "Edited 4-Feb-87 11:48 by hdj") - - (* ;; "sets/returns the font of an HQFX80 imagestream") - - (WITH-HQFX80-DATA - (HQFX80DATA HQFX80STREAM) - (LET ((OLD-FONT (HQFX80DATA-FONT HQFX80DATA))) - - (* ;; "save old value to return, smash new value and update the record.") - - (PROG1 OLD-FONT - [if FONT - then (LET [(NEW-FONT (OR (FONTCREATE FONT NIL NIL NIL HQFX80STREAM T) - (FONTCOPY (HQFX80DATA-FONT HQFX80DATA) - FONT] - - (* ;; - "updating font information is fairly expensive operation. Don't bother unless font has changed.") - - (OR (EQ OLD-FONT NEW-FONT) - (UNINTERRUPTABLY - (CL:SETF (HQFX80DATA-FONT HQFX80DATA) - NEW-FONT) - (CL:SETF (HQFX80DATA-LINEFEED HQFX80DATA) - (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of NEW-FONT))) - (\HQFX80.FIX-FONT HQFX80STREAM HQFX80DATA))])]) - -(\HQFX80.CREATECHARSET - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) - (* ; "Edited 1-Jun-87 13:08 by Snow") - -(* ;;; "Tries to build the csinfo required for CHARSET. Does the necessary coercions.") - -(* ;;; -"NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL.") - - (DECLARE (GLOBALVARS HQFX80-FONT-COERCIONS HQFX80-MISSING-FONT-COERCIONS)) - - (* ;; "HQFX80-FONT-COERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...). Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a similar list.") - - (PROG (XCSINFO) - [SETQ XCSINFO (COND - [(PROGN - - (* ;; "Just recursively call ourselves to handle entries in HQFX80-FONT-COERCIONS") - - (for TRANSL in HQFX80-FONT-COERCIONS bind NEWCSINFO USRFONT - REALFONT - when (AND (SETQ USRFONT (CAR TRANSL)) - (EQ FAMILY (CAR USRFONT)) - (OR (NOT (CADR USRFONT)) - (EQ SIZE (CADR USRFONT))) - (OR (NOT (CADDR USRFONT)) - (EQ CHARSET (CADDR USRFONT))) - (SETQ REALFONT (CADR TRANSL)) - (SETQ NEWCSINFO (\HQFX80.CREATECHARSET - (OR (CAR REALFONT) - FAMILY) - (OR (CADR REALFONT) - SIZE) - FACE ROTATION DEVICE - (OR (CADDR REALFONT) - CHARSET) - FONTDESC NOSLUG?))) - do (RETURN NEWCSINFO] - ((AND (EQ ROTATION 0) - - (* ;; - "If it is available, this will force the appropriate file to be read to fill in the charset entry") - - (\HQFX80.READ-FONT-FILE FAMILY SIZE FACE ROTATION 'HQFX80 CHARSET))) - (T - - (* ;; "if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised 'by hand'") - - (PROG (NEWFONT XFONT XLATEDFAM CSINFO) - (RETURN (COND - [(NEQ ROTATION 0) - - (* ;; "to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.") - - (OR (MEMB ROTATION '(90 270)) - (ERROR - "only implemented rotations are 0, 90 and 270." - ROTATION)) - (COND - ((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0 - 'HQFX80 T CHARSET)) - - (* ;; "actually call FONTCREATE here, rather than a device-specific method, so that the vanilla font that is built in this process will be cached and not repeated.") - - (COND - ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T - )) - (\SFROTATECSINFO CSINFO ROTATION)) - (T NIL] - ((AND (EQ (fetch (FONTFACE WEIGHT) of FACE) - 'BOLD) - (SETQ XFONT - (FONTCREATE FAMILY SIZE - (create FONTFACE using FACE WEIGHT _ - 'MEDIUM) - 0 - 'HQFX80 T CHARSET))) - - (* ;; "if we want a bold font, and the medium weight font is available, build the medium weight version then call \SFMAKEBOLD on the csinfo") - - (COND - ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) - (\SFMAKEBOLD CSINFO)) - (T NIL))) - ((AND (EQ (fetch (FONTFACE SLOPE) of FACE) - 'ITALIC) - (SETQ XFONT - (FONTCREATE FAMILY SIZE - (create FONTFACE using FACE SLOPE _ - 'REGULAR) - 0 - 'HQFX80 T CHARSET))) - (COND - ((SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) - (\SFMAKEITALIC CSINFO)) - (T NIL))) - ((for TRANSL in HQFX80-MISSING-FONT-COERCIONS - bind NEWCSINFO USRFONT REALFONT - when (AND (SETQ USRFONT (CAR TRANSL)) - (EQ FAMILY (CAR USRFONT)) - (OR (NOT (CADR USRFONT)) - (EQ SIZE (CADR USRFONT))) - (OR (NOT (CADDR USRFONT)) - (EQ CHARSET (CADDR USRFONT))) - (SETQ REALFONT (CADR TRANSL)) - (SETQ NEWCSINFO - (\HQFX80.CREATECHARSET - (OR (CAR REALFONT) - FAMILY) - (OR (CADR REALFONT) - SIZE) - FACE ROTATION DEVICE - (OR (CADDR REALFONT) - CHARSET) - FONTDESC NOSLUG?))) - do (RETURN NEWCSINFO))) - ((NOT NOSLUG?) - (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR - FONTAVGCHARWIDTH) - of FONTDESC) - (FONTPROP FONTDESC 'ASCENT) - (FONTPROP FONTDESC 'DESCENT) - (FONTPROP FONTDESC 'DEVICE] - (RETURN XCSINFO]) - -(\HQFX80.CHANGE-CHARSET - [LAMBDA (HQFX80DATA CHARSET) (* hdj "10-Nov-86 16:00") - - (* ;; - "Called when the character set information cached in hqfx80 stream doesn't correspond to CHARSET") - - (LET* ((PBT (HQFX80DATA-PILOTBBT HQFX80DATA)) - (CSINFO (\GETCHARSETINFO CHARSET (HQFX80DATA-FONT HQFX80DATA))) - (CHARACTER-BITMAP (ffetch CHARSETBITMAP of CSINFO))) - - (* ;; "Since we called \GETCHARSETINFO without the NOSLUG? flag, we presume we will get back a CSINFO , even if it is a slug csinfo") - - (UNINTERRUPTABLY - (CL:SETF (HQFX80DATA-WIDTHS-CACHE HQFX80DATA) - (ffetch (CHARSETINFO WIDTHS) of CSINFO)) - (CL:SETF (HQFX80DATA-OFFSETS-CACHE HQFX80DATA) - (ffetch (CHARSETINFO OFFSETS) of CSINFO)) - (CL:SETF (HQFX80DATA-IMAGE-WIDTHS-CACHE HQFX80DATA) - (ffetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) - (CL:SETF (HQFX80DATA-CHARSET-CACHE HQFX80DATA) - CHARSET) - (freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch (BITMAP BITMAPRASTERWIDTH) - of CHARACTER-BITMAP) - BITSPERWORD)) - [IF (OR (NEQ (HQFX80DATA-CHARSET-ASCENT-CACHE HQFX80DATA) - (ffetch CHARSETASCENT of CSINFO)) - (NEQ (HQFX80DATA-CHARSET-DESCENT-CACHE HQFX80DATA) - (ffetch CHARSETDESCENT of CSINFO))) - THEN (\HQFX80.FIX-Y HQFX80DATA CSINFO) - ELSE (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch (BITMAP BITMAPBASE) - of CHARACTER-BITMAP) - (ITIMES (ffetch (BITMAP BITMAPRASTERWIDTH - ) of - CHARACTER-BITMAP - ) - (HQFX80DATA-CHARHEIGHTDELTA - HQFX80DATA])]) - -(\HQFX80.READ-FONT-FILE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 6-Jan-87 17:52 by hdj") - - (* ;; "Look for new filename convention, then old file name convention, with extensions. Note we assume \FONTFILENAME calls \FONTFILENAME.NEW") - - (DECLARE (GLOBALVARS HQFX80-FONT-EXTENSIONS HQFX80-FONT-DIRECTORIES)) - (bind FONTFILE CSINFO STRM for EXT inside HQFX80-FONT-EXTENSIONS - when (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET - HQFX80-FONT-DIRECTORIES (LIST EXT))) - do (SETQ STRM (OPENSTREAM FONTFILE 'INPUT)) - [RESETLST (SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T) - (STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF) - STRM)) - (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE)) - (AC - - (* ;; "CLOSEF is guaranteed inside \READACFONTFILE, against the possibility that we have to copy to make randaccessp") - - (\READACFONTFILE STRM FAMILY SIZE FACE)) - (PROG1 (CLOSEF STRM) - (SHOULDNT) (* ; - "This would get done by RESETSAVE if AC's were read sequentially and we could factor the RESETSAVE") - ] - - (* ;; "If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also be nice to tell the user that he has a bogus file.") - - (RETURN CSINFO]) - -(\HQFX80.SEARCH-FONTS - [LAMBDA (FAMILY SIZE FACE ROTATION) (* hdj "10-Nov-86 12:09") - -(* ;;; "returns a list of the fonts that can be read in for the hqfx80 device. (This is the same as all fonts for the dissplay device.) Rotation is ignored because it is assumed that all devices support 0 90 and 270") - - (DECLARE (GLOBALVARS HQFX80-FONT-EXTENSIONS HQFX80-FONT-DIRECTORIES)) - (for E FILENAMEPATTERN FONTSFOUND THISFONT THISFACE inside HQFX80-FONT-EXTENSIONS - do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E)) - [for DIR inside HQFX80-FONT-DIRECTORIES - do (for FONTFILE in (DIRECTORY (PACKFILENAME 'DIRECTORY DIR 'BODY FILENAMEPATTERN)) - do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE 'DISPLAY)) - FONTSFOUND) - (COND - ((AND [OR (EQ FACE '*) - (EQUAL FACE (SETQ THISFACE (CADDR THISFONT))) - (AND (OR (EQ (CAR FACE) - '*) - (EQ (CAR FACE) - (CAR THISFACE))) - (OR (EQ (CADR FACE) - '*) - (EQ (CADR FACE) - (CADR THISFACE))) - (OR (EQ (CADR FACE) - '*) - (EQ (CADR FACE) - (CADR THISFACE] - (OR (EQ FAMILY '*) - (EQ FAMILY (CAR THISFONT)) - (STRPOS "*" FAMILY))) - - (* ;; "make sure the face, size, and family really match. Family name match allows anything if the family has a * in it. This is wrong but better than what was there before which let in anything with the right beginning.") - - (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND] finally (RETURN FONTSFOUND]) -) - -(CL:DEFUN \HQFX80.INIT-FONT-PROFILE () - - (* ;; "set up the fonts for the HQFX80, based on the DISPLAY font profile entries") - - [FOR FONT-CLASS IN '(DEFAULTFONT ITALICFONT BOLDFONT LITTLEFONT TINYFONT BIGFONT COMMENTFONT - TEXTFONT) DO (\ADD-TO-FONTPROFILE FONTPROFILE FONT-CLASS 'HQFX80 - (\GET-FROM-FONTPROFILE FONTPROFILE FONT-CLASS - 'DISPLAY] - (FONTPROFILE FONTPROFILE) - T) - - - -(* ;; "methods for measuring") - -(DEFINEQ - -(\HQFX80.CHARWIDTH - [LAMBDA (HQFX80STREAM CHARCODE) (* ; "Edited 4-Feb-87 13:20 by hdj") - - (* ;; - "gets the width of the rendering of charcode on an hqfx80 image stream. We treat space specially.") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (LET ((WIDTH (\FGETCHARWIDTH (HQFX80DATA-FONT DATA) - CHARCODE))) - (if (EQ CHARCODE (CHARCODE SPACE)) - then (FIXR (TIMES WIDTH (HQFX80DATA-SPACEWIDTH DATA))) - else WIDTH]) - -(\HQFX80.STRINGWIDTH - [LAMBDA (HQFX80STREAM STRING RDTBL) (* ; "Edited 3-Feb-87 17:36 by hdj") - - (* ;; - " returns STRING's width, relative to HQFX80STREAM's current font and the readtable RDTBL") - - (IF RDTBL - THEN (BIND (FIRSTFLG _ T) - (SA _ (FETCH READSA OF RDTBL)) - (ESCAPE-CHAR-WIDTH _ (\HQFX80.CHARWIDTH HQFX80STREAM (FETCH (READTABLEP ESCAPECHAR - ) OF RDTBL))) - (SYN _ NIL) FOR CHARCODE INSTRING STRING - SUM (PROG1 (IPLUS (COND - ((AND (FETCH (READCODE ESCQUOTE) OF (SETQ SYN (\SYNCODE SA - CHARCODE))) - (OR FIRSTFLG (FETCH (READCODE INNERESCQUOTE) OF SYN))) - ESCAPE-CHAR-WIDTH) - (T 0)) - (\FASTFX80.CHARWIDTH HQFX80STREAM CHARCODE)) - (SETQ FIRSTFLG NIL))) - ELSE (FOR CHAR INSTRING STRING SUM (\HQFX80.CHARWIDTH HQFX80STREAM CHAR]) -) - -(CL:DEFUN \HQFX80.SPACEFACTOR (HQFX80STREAM FACTOR) - - (* ;; "returns/sets the width of the space character (32 ASCII) for HQFX80STREAM") - - [WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-SPACEWIDTH DATA) - (AND FACTOR (IF (NUMBERP FACTOR) - THEN (CL:SETF (HQFX80DATA-SPACEWIDTH DATA) - FACTOR) - ELSE (\ILLEGAL.ARG FACTOR))))]) - - - -(* ;; "methods that affect the current position/size of drawing surface") - -(DEFINEQ - -(\HQFX80.CLIPPINGREGION - [LAMBDA (HQFX80STREAM REGION) (* ; "Edited 8-Dec-86 14:04 by hdj") - - (* ;; "sets the clipping region of an HQFX80 image stream. do not allow it to exceed the confines of the bitmap.") - - (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) - (PROG1 (COPY (HQFX80DATA-CLIPPINGREGION HQFX80DATA)) - (* ; - "copy so it can't be side-effected later") - (LET ((BACKING (HQFX80DATA-BACKINGBITMAP HQFX80DATA))) - (AND REGION (OR (type? REGION REGION) - (ERROR REGION " is not a REGION.")) - (UNINTERRUPTABLY - (CL:SETF (HQFX80DATA-CLIPPINGREGION HQFX80DATA) - (INTERSECTREGIONS (CREATEREGION 0 0 (BITMAPWIDTH BACKING) - (BITMAPHEIGHT BACKING)) - REGION)) - (\HQFX80.INVALIDATE-FONT-CACHE HQFX80DATA))]) - -(\HQFX80.LEFTMARGIN - [LAMBDA (HQFX80STREAM XPOSITION) (* ; "Edited 3-Feb-87 17:11 by hdj") - - (* ;; "sets/returns the position that a carriage return returns to for an hqfx80stream") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-LEFTMARGIN DATA) - (AND XPOSITION (if (SMALLP XPOSITION) - then (UNINTERRUPTABLY - (CL:SETF (HQFX80DATA-LEFTMARGIN DATA) - XPOSITION) - (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM)) - else (\ILLEGAL.ARG XPOSITION]) - -(\HQFX80.RIGHTMARGIN - [LAMBDA (HQFX80STREAM XPOSITION) (* ; "Edited 10-Dec-86 18:17 by hdj") - - (* ;; "Sets the right margin of an HQFX80STREAM") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-RIGHTMARGIN DATA) - (AND XPOSITION (IF (SMALLP XPOSITION) - THEN (UNINTERRUPTABLY - (CL:SETF (HQFX80DATA-RIGHTMARGIN DATA) - XPOSITION) - (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM)) - ELSE (\ILLEGAL.ARG XPOSITION]) - -(\HQFX80.TOPMARGIN - [LAMBDA (HQFX80STREAM YPOSITION) (* ; "Edited 10-Dec-86 18:16 by hdj") - - (* ;; "Sets the top margin of an hqfx80stream") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-TOPMARGIN DATA) - (AND YPOSITION (IF (SMALLP YPOSITION) - THEN (CL:SETF (HQFX80DATA-TOPMARGIN DATA) - YPOSITION) - ELSE (\ILLEGAL.ARG YPOSITION]) - -(\HQFX80.BOTTOMMARGIN - [LAMBDA (HQFX80STREAM YPOSITION) (* ; "Edited 10-Dec-86 18:17 by hdj") - - (* ;; "Sets the bottom margin of an HQFX80STREAM") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-BOTTOMMARGIN DATA) - (AND YPOSITION (IF (SMALLP YPOSITION) - THEN (CL:SETF (HQFX80DATA-BOTTOMMARGIN DATA) - YPOSITION) - ELSE (\ILLEGAL.ARG YPOSITION]) - -(\HQFX80.XPOSITION - [LAMBDA (HQFX80STREAM XPOSITION) (* hdj " 3-Nov-86 15:14") - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-XPOS DATA) - (AND XPOSITION (IF (NUMBERP XPOSITION) - THEN (CL:SETF (HQFX80DATA-XPOS DATA) - XPOSITION) - ELSE (\ILLEGAL.ARG XPOSITION]) - -(\HQFX80.YPOSITION - [LAMBDA (HQFX80STREAM YPOSITION) (* ; "Edited 5-Jan-87 17:25 by hdj") - - (* ;; "set the y-pos of an HQFX80STREAM") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-YPOS DATA) - (AND YPOSITION (if (NUMBERP YPOSITION) - then (UNINTERRUPTABLY - (CL:SETF (HQFX80DATA-YPOS DATA) - YPOSITION) - (\HQFX80.INVALIDATE-CACHE DATA)) - else (\ILLEGAL.ARG YPOSITION]) - -(\HQFX80.NEWLINE - [LAMBDA (CHARCODE HQFX80STREAM) (* hdj "14-Nov-86 17:44") - - (* ;; - "CODE is EOL, CR, or LF. Performs the appropriate printing operation on hqfx80stream.") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (LET [(NEW-Y (+ (HQFX80DATA-YPOS DATA) - (HQFX80DATA-LINEFEED DATA] - (if (< NEW-Y (HQFX80DATA-BOTTOMMARGIN DATA)) - then - - (* ;; - "we're below the bottom margin, so eject the page. If this was a LF, restore the old x-position") - - (LET ((OLD-X (HQFX80DATA-XPOS DATA))) - (\HQFX80.NEWPAGE HQFX80STREAM) - (if (EQ CHARCODE (CHARCODE LF)) - then (\HQFX80.XPOSITION HQFX80STREAM OLD-X))) - else - - (* ;; "just decrement the y coord") - - (\HQFX80.YPOSITION HQFX80STREAM NEW-Y) - - (* ;; "if this was a CR or EOL, set the x-position too.") - - (if (NEQ CHARCODE (CHARCODE LF)) - then (\HQFX80.XPOSITION HQFX80STREAM (HQFX80DATA-LEFTMARGIN DATA)) - (freplace (STREAM CHARPOSITION) of HQFX80STREAM with 0]) - -(\HQFX80.NEWPAGE - [LAMBDA (HQFX80STREAM) (* ; "Edited 8-Dec-86 15:18 by hdj") - - (* ;; "end an HQFX80 page") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (\HQFX80.DUMP-PAGE-BUFFER (HQFX80DATA-BACKINGBITMAP DATA) - HQFX80STREAM) - - (* ;; "start a new page") - - (\HQFX80.STARTPAGE HQFX80STREAM]) - -(\HQFX80.LINEFEED - [LAMBDA (HQFX80STREAM DELTAY) (* hdj " 3-Nov-86 14:58") - - (* ;; "Sets the linefeed distance for an HQFX80 stream") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-LINEFEED DATA) - (AND DELTAY (IF (NUMBERP DELTAY) - THEN (CL:SETF (HQFX80DATA-LINEFEED DATA) - DELTAY) - ELSE (\ILLEGAL.ARG DELTAY]) - -(\HQFX80.RESET - [LAMBDA (HQFX80STREAM) (* hdj " 4-Nov-86 15:35") - - (* ;; "resets an hqfx80 image stream to a virgin state") - - (\HQFX80.STARTPAGE HQFX80STREAM]) - -(\HQFX80.STARTPAGE - [LAMBDA (HQFX80STREAM) (* ; "Edited 18-Dec-86 15:25 by hdj") - - (* ;; "start a new page for an HQFX80 imagestream") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (LET* ((CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA)) - (FONT (HQFX80DATA-FONT DATA)) - (FONT-ASCENT (FONTASCENT FONT))) - - (* ;; "first clear the backing bitmap...") - - (BLTSHADE (HQFX80DATA-TEXTURE DATA) - (HQFX80DATA-BACKINGBITMAP DATA) - NIL NIL NIL NIL 'REPLACE) - - (* ;; "... and then reset the current position") - - (\HQFX80.XPOSITION HQFX80STREAM (HQFX80DATA-LEFTMARGIN DATA)) - (\HQFX80.YPOSITION HQFX80STREAM (ADD1 (- (HQFX80DATA-TOPMARGIN DATA) - FONT-ASCENT]) -) - -(DEFMACRO \HQFX80.CUR-POS-VISIBLE? (HQFX80DATA) - `(INSIDEP (HQFX80DATA-CLIPPINGREGION ,HQFX80DATA) - (HQFX80DATA-XPOS ,HQFX80DATA) - (HQFX80DATA-YPOS ,HQFX80DATA))) - - - -(* ;; "graphical operations") - -(DECLARE%: EVAL@COMPILE - -[PUTDEF '\HQFX80.BRUSHBBT 'RESOURCES '(NEW (CREATE PILOTBBT] -) -(DEFINEQ - -(\HQFX80.BITBLT - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM HQFX80STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH - HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM) (* ; "Edited 1-Jun-87 13:07 by Snow") - -(* ;;; "BITBLT onto the HQFX80 page") - -(* ;;; "") - - (DECLARE (LOCALVARS . T)) - (COND - ((NEQ 1 (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)) - - (* ;; "going from color bitmap into black and white bitmap.") - - (ERROR "Cannot BitBLT a color bitmap onto the FX-80 page"))) - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG (SOURCE-TO-DEST-X SOURCE-TO-DEST-Y LEFT TOP BOTTOM RIGHT DESTBITMAP) - (SETQ DESTBITMAP (HQFX80DATA-BACKINGBITMAP DATA)) - [LET ((FXCLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA))) - - (* ;; "compute limits based on clipping regions.") - - (SETQ LEFT (fetch (REGION LEFT) of FXCLIPPINGREGION)) - (SETQ BOTTOM (fetch (REGION BOTTOM) of FXCLIPPINGREGION)) - (SETQ RIGHT (fetch (REGION RIGHT) of FXCLIPPINGREGION)) - (SETQ TOP (fetch (REGION TOP) of FXCLIPPINGREGION)) - (COND - (CLIPPINGREGION - - (* ;; "hard case, two destination clipping regions: do calculations to merge them.") - - (PROG (CRLEFT CRBOTTOM) - [SETQ LEFT (IMAX LEFT (SETQ CRLEFT (fetch (REGION LEFT) - of CLIPPINGREGION] - [SETQ BOTTOM (IMAX BOTTOM (SETQ CRBOTTOM (fetch (REGION BOTTOM) - of CLIPPINGREGION] - [SETQ RIGHT (IMIN RIGHT (IPLUS CRLEFT (fetch (REGION WIDTH) - of CLIPPINGREGION] - (SETQ TOP (IMIN TOP (IPLUS CRBOTTOM (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)) - (AND WIDTH (SETQ RIGHT (IMIN (IPLUS DESTINATIONLEFT WIDTH) - RIGHT)))(* ; "WIDTH is optional") - - (AND HEIGHT (SETQ TOP (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) - TOP))) (* ; "HEIGHT is optional") - - ) (* ; "Clip and translate coordinates.") - - (SETQ SOURCE-TO-DEST-X (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) - (SETQ SOURCE-TO-DEST-Y (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 SOURCE-TO-DEST-X) - 0)) (* ; "compute bottom margin") - - (SETQ BOTTOM (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE BOTTOM SOURCE-TO-DEST-Y) - 0)) - [PROGN (* ; "compute right margin") - - (SETQ RIGHT (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP) - (IDIFFERENCE RIGHT SOURCE-TO-DEST-X) - (IPLUS CLIPPEDSOURCELEFT WIDTH] - (PROGN (* ; "compute top margin") - - (SETQ TOP (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) - (IDIFFERENCE TOP SOURCE-TO-DEST-Y) - (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] - (COND - ((OR (ILEQ RIGHT LEFT) - (ILEQ TOP BOTTOM)) (* ; "there is nothing to move.") - - (RETURN))) - (OR OPERATION (SETQ OPERATION (HQFX80DATA-OPERATION DATA))) - (SELECTQ SOURCETYPE - (MERGE (* ; "Need to use complement of TEXTURE") - - [SETQ TEXTURE (COND - ((NULL TEXTURE) - BLACKSHADE) - ((FIXP TEXTURE) - (LOGXOR (LOGAND TEXTURE BLACKSHADE) - BLACKSHADE)) - [(type? BITMAP TEXTURE) - (INVERT.TEXTURE.BITMAP TEXTURE - (OR \BBSCRATCHTEXTURE (SETQ \BBSCRATCHTEXTURE - (BITMAPCREATE 16 16] - (T (\ILLEGAL.ARG TEXTURE]) - NIL) - (UNINTERRUPTABLY - [PROG ([PILOTBBT (COND - ((type? PILOTBBT \SYSPILOTBBT) - \SYSPILOTBBT) - (T (SETQ \SYSPILOTBBT (create PILOTBBT] - (HEIGHT (IDIFFERENCE TOP BOTTOM)) - (WIDTH (IDIFFERENCE RIGHT LEFT)) - (DTY (\SFInvert DESTBITMAP (IPLUS TOP SOURCE-TO-DEST-Y))) - (DLX (IPLUS LEFT SOURCE-TO-DEST-X)) - (STY (\SFInvert SOURCEBITMAP TOP)) - (SLX LEFT)) - (replace PBTWIDTH of PILOTBBT with WIDTH) - (replace PBTHEIGHT of PILOTBBT with HEIGHT) - (COND - ((EQ SOURCETYPE 'MERGE) - (\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH - HEIGHT OPERATION TEXTURE)) - (T (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT - SOURCETYPE OPERATION TEXTURE]) - (RETURN T]) - -(\HQFX80.BLTSHADE - [LAMBDA (TEXTURE HQFX80STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION - CLIPPINGREGION) (* ; "Edited 1-Jun-87 13:05 by Snow") - - (* ;; "BLTSHADE to an HQFX80 imagestream") - - (DECLARE (LOCALVARS . T)) - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG (LEFT TOP BOTTOM RIGHT DESTINATIONBITMAP) - - (* ;; "compute limits based on clipping regions.") - - (LET ((FXCLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA))) - (SETQ LEFT (fetch (REGION LEFT) of FXCLIPPINGREGION)) - (SETQ BOTTOM (fetch (REGION BOTTOM) of FXCLIPPINGREGION)) - (SETQ RIGHT (fetch (REGION RIGHT) of FXCLIPPINGREGION)) - (SETQ TOP (fetch (REGION TOP) of FXCLIPPINGREGION))) - [COND - (CLIPPINGREGION - - (* ;; "hard case, two destination clipping regions: do calculations to merge them.") - - (PROG (CRLEFT CRBOTTOM) - [SETQ LEFT (IMAX LEFT (SETQ CRLEFT (fetch (REGION LEFT) of - CLIPPINGREGION - ] - [SETQ BOTTOM (IMAX BOTTOM (SETQ CRBOTTOM (fetch (REGION BOTTOM) - of CLIPPINGREGION] - [SETQ RIGHT (IMIN RIGHT (IPLUS CRLEFT (fetch (REGION WIDTH) - of CLIPPINGREGION] - (SETQ TOP (IMIN TOP (IPLUS CRBOTTOM (fetch (REGION HEIGHT) - of CLIPPINGREGION] - (SETQ DESTINATIONBITMAP (HQFX80DATA-BACKINGBITMAP DATA)) - - (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") - - (SETQ LEFT (IMAX DESTINATIONLEFT LEFT)) - (SETQ BOTTOM (IMAX DESTINATIONBOTTOM BOTTOM)) - (AND WIDTH (SETQ RIGHT (IMIN (IPLUS DESTINATIONLEFT WIDTH) - RIGHT))) (* ; "WIDTH is optional") - - (AND HEIGHT (SETQ TOP (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) - TOP))) (* ; "HEIGHT is optional") - - (COND - ((AND (IGREATERP RIGHT LEFT) - (IGREATERP TOP BOTTOM))) - (T (* ; "there is nothing to move.") - - (RETURN NIL))) - (CL:ETYPECASE TEXTURE [LITATOM (* ; "includes NIL case") - - (COND - ((NULL TEXTURE) - (* ; - "default texture to background texture.") - - (SETQ TEXTURE (HQFX80DATA-TEXTURE DATA))) - (T (\ILLEGAL.ARG TEXTURE] - (SMALLP (SETQ TEXTURE (LOGAND TEXTURE BLACKSHADE))) - (FIXP (SETQ TEXTURE (LOGAND TEXTURE BLACKSHADE))) - (BITMAP NIL)) - (UNINTERRUPTABLY - (LET ([PILOTBBT (IF (type? PILOTBBT \SYSPILOTBBT) - THEN \SYSPILOTBBT - ELSE (SETQ \SYSPILOTBBT (create PILOTBBT] - (HEIGHT (IDIFFERENCE TOP BOTTOM))) - (replace PBTWIDTH of PILOTBBT with (IDIFFERENCE RIGHT LEFT)) - (replace PBTHEIGHT of PILOTBBT with HEIGHT) - (\BITBLTSUB PILOTBBT NIL LEFT NIL DESTINATIONBITMAP LEFT (\SFInvert - DESTINATIONBITMAP - TOP) - HEIGHT - 'TEXTURE - (OR OPERATION (HQFX80DATA-OPERATION DATA)) - TEXTURE))) - (RETURN T]) - -(\HQFX80.DRAWELLIPSE - [LAMBDA (HQFX80STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) - (* ; "Edited 12-Feb-87 14:37 by jds") - (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 HQFX80STREAM) - (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))) - - (* ;; "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. 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.") - - (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) - (GLOBALRESOURCE \HQFX80.BRUSHBBT - (PROG (DESTINATION-BITMAP LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH - TOPMINUSBRUSH LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE - BRUSHHEIGHT BRUSHWIDTH RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM - OPERATION HEIGHTMINUS1 (BBT \HQFX80.BRUSHBBT) - (COS-ORIENTATION (COS ORIENTATION)) - (SIN-ORIENTATION (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 (USERFN (AND (LITATOM BRUSH) - BRUSH))) - [COND - (USERFN (* ; - "if calling user fn, don't bother with set up") - (SETQ CX CENTERX) - (SETQ CY CENTERY)) - (T (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA) - (* ; - "take into account the brush thickness.") - (SETQ CX (- CENTERX (FOLDLO BRUSHWIDTH 2))) - (SETQ CY (- CENTERY (FOLDLO BRUSHHEIGHT 2] - (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED COS-ORIENTATION - COS-ORIENTATION) - (FTIMES SEMIMINORRADIUSSQUARED SIN-ORIENTATION - SIN-ORIENTATION))) - (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED - COS-ORIENTATION COS-ORIENTATION) - (FTIMES SEMIMAJORRADIUSSQUARED - SIN-ORIENTATION SIN-ORIENTATION))) - 3)) - (SETQ G (FTIMES COS-ORIENTATION SIN-ORIENTATION (LSH (- - SEMIMINORRADIUSSQUARED - SEMIMAJORRADIUSSQUARED - ) - 1))) - [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS) - (SQRT A] - (SETQ CYPlusOffset (+ CY yOffset)) - (SETQ CYMinusOffset (- 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 (- k1 G)) - (SETQ k3 (- k2 (+ B G))) - (SETQ b (+ U (RSH (+ A G) - 1))) - (SETQ a (IMINUS (+ b V))) - (SETQ d (+ 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 (- k1 G)) - (SETQ k3 (+ k2 B (IMINUS G))) - (SETQ b (+ U (RSH (- G A) - 1))) - (SETQ a (- V b)) - (SETQ d (+ b K (IMINUS (+ (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 (+ k1 G)) - (SETQ k3 (+ k2 A G)) - [SETQ b (IMINUS (+ V (RSH (+ B G) - 1] - (SETQ a (- U b)) - (SETQ d (+ b K (IMINUS (+ (RSH A 3) - (RSH U 1] - (T (* ; "start in octant 8") - (SETQ y2 -1) - (SETQ k1 (IMINUS B)) - (SETQ k2 (+ k1 G)) - (SETQ k3 (+ k2 G (IMINUS A))) - (SETQ b (+ V (RSH (- B G) - 1))) - (SETQ a (- U b)) - (SETQ d (+ b (RSH A 3) - (IMINUS (+ 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 (+ x x1)) - (SETQ y (+ y y1)) - (SETQ b (- b k1)) - (SETQ a (+ a k2)) - (SETQ d (+ b d))) - (T (* ; "move 2") - (SETQ x (+ x x2)) - (SETQ y (+ y y2)) - (SETQ b (- b k2)) - (SETQ a (+ a k3)) - (SETQ d (- d a] - (COND - ((MINUSP x) - (MOVETO CENTERX CENTERY HQFX80STREAM) - (RETURN NIL))) - [COND - (USERFN (APPLY* USERFN (+ CX x) - (+ CYPlusOffset y) - HQFX80STREAM) - (APPLY* USERFN (- CX x) - (- CYMinusOffset y) - HQFX80STREAM)) - (T (\HQFX80.CURVEPT (+ CX x) - (+ CYPlusOffset y)) - (\HQFX80.CURVEPT (- CX x) - (- CYMinusOffset y] - (AND (MINUSP b) - (GO SQUARE)) - DIAGONAL - (OR (MINUSP a) - (GO MOVE)) (* ; "diagonal octant change") - (SETQ x1 (- x2 x1)) - (SETQ y1 (- y2 y1)) - (SETQ w (- (LSH k2 1) - k3)) - (SETQ k1 (- w k1)) - (SETQ k2 (- k2 k3)) - (SETQ k3 (IMINUS k3)) - [SETQ b (+ b a (IMINUS (RSH (ADD1 k2) - 1] - [SETQ d (+ b (RSH (+ k3 4) - 3) - (IMINUS d) - (IMINUS (RSH (ADD1 a) - 1] - (SETQ a (- (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 (- k2 k1)) - (SETQ k1 (IMINUS k1)) - (SETQ k2 (+ w k1)) - (SETQ k3 (- (LSH w 2) - k3)) - (SETQ b (- (IMINUS b) - w)) - (SETQ d (- (- b a) - d)) - (SETQ a (- (- a w) - (LSH b 1))) - (GO DIAGONAL]) - -(\HQFX80.OPERATION - [LAMBDA (HQFX80STREAM OPERATION) (* hdj " 4-Nov-86 17:25") - - (* ;; "sets the operation field of an hqfx80 stream") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (PROG1 (HQFX80DATA-OPERATION DATA) - (AND OPERATION (OR (FMEMB OPERATION '(PAINT REPLACE INVERT ERASE)) - (\ILLEGAL.ARG OPERATION)) - (UNINTERRUPTABLY - (CL:SETF (HQFX80DATA-OPERATION DATA) - OPERATION) (* ; - "update other fields that depend on operation.") - (\SETPBTFUNCTION (HQFX80DATA-PILOTBBT DATA) - (HQFX80DATA-SOURCETYPE DATA) - OPERATION))]) - -(\HQFX80.DRAWPOINT - [LAMBDA (HQFX80STREAM X Y BRUSH OPERATION) (* hdj "19-Nov-86 15:21") - - (* ;; "draws a brush point at position X Y on an HQFX80STREAM") - - (LET ((BRUSHBM (\GETBRUSH BRUSH))) (* ; - "SUB1 is to put extra bit of even brush on the top or left.") - (BITBLT BRUSHBM 0 0 HQFX80STREAM [IDIFFERENCE X (HALF (SUB1 (BITMAPWIDTH BRUSHBM] - [IDIFFERENCE Y (HALF (SUB1 (BITMAPHEIGHT BRUSHBM] - NIL NIL NIL OPERATION]) -) -(DEFINEQ - -(\HQFX80.DRAWLINE - [LAMBDA (HQFX80STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) - (* ; "Edited 5-Jan-87 18:10 by hdj") - - (* ;; - "Draws a line from (x1,y1) to (x2,y2) on an hqfx80 imagestream, leaving the position at (x2,y2).") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (LET ((CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION DATA))) - - (* ;; "draw the line ...") - - (if DASHING - then (GLOBALRESOURCE \HQFX80.BRUSHBBT (LET ((BBT \HQFX80.BRUSHBBT) - (BRUSH (LIST 'ROUND WIDTH COLOR))) - (\HQFX80.LINEWITHBRUSH - (OR (FIXP X1) - (FIXR X1)) - (OR (FIXP Y1) - (FIXR Y1)) - (OR (FIXP X2) - (FIXR X2)) - (OR (FIXP Y2) - (FIXR Y2)) - BRUSH - (\GOOD.DASHLST DASHING BRUSH) - HQFX80STREAM BBT))) - else (\HQFX80.CLIP-AND-DRAW-LINE (OR (FIXP X1) - (FIXR X1)) - (OR (FIXP Y1) - (FIXR Y1)) - (OR (FIXP X2) - (FIXR X2)) - (OR (FIXP Y2) - (FIXR Y2)) - [COND - ((NULL WIDTH) - 1) - ((OR (FIXP WIDTH) - (FIXR WIDTH] - (SELECTQ OPERATION - (NIL (HQFX80DATA-OPERATION DATA)) - ((REPLACE PAINT INVERT ERASE) - OPERATION) - (\ILLEGAL.ARG OPERATION)) - (HQFX80DATA-BACKINGBITMAP DATA) - (ffetch (REGION LEFT) of CLIPPINGREGION) - (SUB1 (ffetch (REGION RIGHT) of CLIPPINGREGION)) - (ffetch (REGION BOTTOM) of CLIPPINGREGION) - (SUB1 (ffetch (REGION TOP) of CLIPPINGREGION)) - HQFX80STREAM)) - - (* ;; "... then move to (x2,y2)") - - (\HQFX80.XPOSITION HQFX80STREAM X2) - (\HQFX80.YPOSITION HQFX80STREAM Y2]) - -(\HQFX80.CLIP-AND-DRAW-LINE - [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP HQFX80STREAM) - (* ; "Edited 5-Jan-87 17:59 by hdj") - - (* ;; "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") - - (PROG NIL - (COND - [(EQP X1 X2) (* ; "special case of vertical line.") - [COND - ((IGREATERP WIDTH 2) - (COND - ((EQP Y1 Y2) - - (* ;; "special case. Since we don't know whether the guy is headed horizontally or vertically, put out a round brush.") - - (RETURN (\HQFX80.DRAWPOINT HQFX80STREAM X1 Y1 (LIST 'ROUND WIDTH) - 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 (BLTSHADE BLACKSHADE BITMAP (SETQ X1 (IMAX X1 LEFT)) - (SETQ MIN (IMAX MIN BOTTOM)) - (IDIFFERENCE (IMIN X2 (ADD1 RIGHT)) - X1) - (ADD1 (IDIFFERENCE (IMIN MAX TOP) - MIN)) - OPERATION] - [(EQP 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 (BLTSHADE BLACKSHADE BITMAP (SETQ MIN (IMAX MIN LEFT)) - (SETQ Y1 (IMAX Y1 BOTTOM)) - (ADD1 (IDIFFERENCE (IMIN MAX RIGHT) - MIN)) - (IDIFFERENCE (IMIN Y2 (ADD1 TOP)) - Y1) - OPERATION] - ((EQP WIDTH 1) (* ; "special case of width 1") - (\HQFX80.CLIP-AND-DRAW-LINE1 X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP - HQFX80STREAM)) - ((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 (\HQFX80.CLIP-AND-DRAW-LINE1 X1 I X2 J OPERATION BITMAP LEFT RIGHT BOTTOM TOP))) - (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 (\HQFX80.CLIP-AND-DRAW-LINE1 I Y1 J Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP]) - -(\HQFX80.CLIP-AND-DRAW-LINE1 - [LAMBDA (X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP) - (* hdj " 6-Nov-86 14:30") - - (* ;; "LEFT, RIGHT, BOTTOM, TOP are set to the boundaries of the clipping region") - - (PROG (DX DY YMOVEUP HALFDX HALFDY (BMRASTERWIDTH (fetch (BITMAP 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.") - (\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 (\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] - [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]) -) -(DEFINEQ - -(\HQFX80.DRAWCIRCLE - [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS BRUSH DASHING)(* hdj "21-Nov-86 17:11") - - (* ;; "draw a circle on a hqfx80 stream") - - (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) - (T (GLOBALRESOURCE \HQFX80.BRUSHBBT - (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) - (PROG ((X 0) - (Y RADIUS) - (D (ITIMES 2 (- 1 RADIUS))) - LEFT RIGHTPLUS1 TOP BOTTOM DESTINATION-BITMAP BRUSHWIDTH BRUSHHEIGHT - LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE - BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH OPERATION HEIGHTMINUS1 CX CY - (BBT \HQFX80.BRUSHBBT) - (USERFN (AND (LITATOM BRUSH) - BRUSH))) - - (* ;; "many of these variables are used by the macro for \HQFX80.CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\HQFX80.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.\HQFX80.BBTCURVEPT. HQFX80DATA) - (SETQ CX (- CENTERX (FOLDLO BRUSHWIDTH 2))) - (* ; - "take into account the brush thickness.") - (SETQ CY (- CENTERY (FOLDLO BRUSHHEIGHT 2] - [COND - ((EQ RADIUS 1) (* ; "put a single brush down.") - (* ; - "draw the top and bottom most points.") - (COND - (USERFN (APPLY* USERFN CX CY HQFX80STREAM)) - (T (\HQFX80.CURVEPT CX CY))) - (RETURN)) - (T (* ; - "draw the top and bottom most points.") - (COND - (USERFN (APPLY* USERFN CX (+ CY RADIUS) - HQFX80STREAM) - (APPLY* USERFN CX (- CY RADIUS) - HQFX80STREAM)) - (T (\HQFX80.CURVEPT CX (+ CY RADIUS)) - (\HQFX80.CURVEPT CX (- CY RADIUS] - LP (* ; - "(UNFOLD x 2) is used instead of (ITIMES x 2)") - [COND - [(IGREATERP 0 D) - (SETQ X (ADD1 X)) - (COND - ((IGREATERP (UNFOLD (+ D Y) - 2) - 1) - (SETQ D (+ D (UNFOLD (- X Y) - 2) - 4)) - (SETQ Y (SUB1 Y))) - (T (SETQ D (+ D (UNFOLD X 2) - 1] - ((OR (EQ 0 D) - (IGREATERP X D)) - (SETQ X (ADD1 X)) - (SETQ D (+ D (UNFOLD (- X Y) - 2) - 4)) - (SETQ Y (SUB1 Y))) - (T (SETQ D (+ (- 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 (+ CX X) - CY HQFX80STREAM) - (APPLY* USERFN (- CX X) - CY HQFX80STREAM)) - (T (\HQFX80.CURVEPT (+ CX X) - CY) - (\HQFX80.CURVEPT (- CX X) - CY] - (T (COND - (USERFN (APPLY* USERFN (+ CX X) - (+ CY Y) - HQFX80STREAM) - (APPLY* USERFN (- CX X) - (+ CY Y) - HQFX80STREAM) - (APPLY* USERFN (+ CX X) - (- CY Y) - HQFX80STREAM) - (APPLY* USERFN (- CX X) - (- CY Y) - HQFX80STREAM)) - (T (\HQFX80.DRAW-4-CIRCLE-POINTS CX CY X Y))) - (GO LP))) - (MOVETO CENTERX CENTERY HQFX80STREAM) - (RETURN NIL]) - -(\HQFX80.CREATE-BRUSH-BBT - [LAMBDA (BRUSHBM HQFX80DATA BITBLT-TABLE) (* hdj "18-Nov-86 17:33") - - (* ;; "Initializes BITBLT-TABLE for the BRUSHBM and an HQFX80 stream and returns BITBLT-TABLE, unless the BRUSHBM is a 1-point brush, in which case it returns NIL.") - - (COND - ((AND (EQ (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM) - 1) - (EQ (fetch (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 HQFX80DATA.") - (replace (PILOTBBT PBTDESTBPL) of BITBLT-TABLE with (UNFOLD (fetch (BITMAP - BITMAPRASTERWIDTH - ) - of (HQFX80DATA-BACKINGBITMAP - HQFX80DATA)) - BITSPERWORD)) - (replace (PILOTBBT PBTSOURCEBPL) of BITBLT-TABLE with (UNFOLD (fetch (BITMAP - BITMAPRASTERWIDTH - ) of BRUSHBM) - BITSPERWORD)) - (replace (PILOTBBT PBTFLAGS) of BITBLT-TABLE with 0) - (replace (PILOTBBT PBTDISJOINT) of BITBLT-TABLE with T) - (\SETPBTFUNCTION BITBLT-TABLE (HQFX80DATA-SOURCETYPE HQFX80DATA) - (SELECTQ (HQFX80DATA-OPERATION HQFX80DATA) - ((PAINT REPLACE) - 'PAINT) - ((INVERT ERASE) - 'ERASE) - (SHOULDNT))) - BITBLT-TABLE]) -) - -(DEFMACRO \HQFX80.DRAW-4-CIRCLE-POINTS (CENTER-X CENTER-Y EDGE-X EDGE-Y) - - (* ;; "draw four points 90 degress apart on the circumference of a circle") - - `[PROGN (\HQFX80.CURVEPT (+ ,CENTER-X ,EDGE-X) - (+ ,CENTER-Y ,EDGE-Y)) - (\HQFX80.CURVEPT (- ,CENTER-X ,EDGE-X) - (+ ,CENTER-Y ,EDGE-Y)) - (\HQFX80.CURVEPT (+ ,CENTER-X ,EDGE-X) - (- ,CENTER-Y ,EDGE-Y)) - (\HQFX80.CURVEPT (- ,CENTER-X ,EDGE-X) - (- ,CENTER-Y ,EDGE-Y]) -(DEFINEQ - -(\HQFX80.FILLCIRCLE - [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS TEXTURE) (* hdj " 6-Nov-86 15:45") - (COND - ((OR (NOT (NUMBERP RADIUS)) - (ILESSP (SETQ RADIUS (FIXR RADIUS)) - 0)) - (\ILLEGAL.ARG RADIUS)) - (T (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) - (GLOBALRESOURCE \HQFX80.BRUSHBBT - (LET* [(CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION HQFX80DATA)) - (TOP (SUB1 (fetch (REGION TOP) of CLIPPINGREGION))) - (BOTTOM (fetch (REGION BOTTOM) of CLIPPINGREGION)) - (LEFT (fetch (REGION LEFT) of CLIPPINGREGION)) - (RIGHT (SUB1 (fetch (REGION RIGHT) of HQFX80DATA] - (PROG (TOP BOTTOM RIGHT LEFT OPERATION DESTINATION-BITMAP (X 0) - (Y RADIUS) - (D (ITIMES 2 (- 1 RADIUS))) - DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT - GRAYWIDTH GRAYBASE (FCBBT \HQFX80.BRUSHBBT)) - (SETQ OPERATION (HQFX80DATA-OPERATION HQFX80DATA)) - (SETQ DESTINATION-BITMAP (HQFX80DATA-BACKINGBITMAP HQFX80DATA)) - [SETQ TEXTUREBM (COND - ((BITMAPP TEXTURE)) - [(AND (NULL TEXTURE) - (BITMAPP (HQFX80DATA-TEXTURE HQFX80DATA] - ([OR (FIXP TEXTURE) - (AND (NULL TEXTURE) - (SETQ TEXTURE (HQFX80DATA-TEXTURE - HQFX80DATA] - (* ; - "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 - DESTINATION-BITMAP - )) - (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of - DESTINATION-BITMAP - )) - - (* ;; "update as many fields in the brush bitblt table as possible from the stream.") - - (replace PBTFLAGS of FCBBT with 0) - (replace PBTDESTBPL of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD - )) - - (* ;; "clear gray information. PBTSOURCEBPL is used for gray information too.") - - (replace PBTSOURCEBPL of FCBBT with 0) - (replace PBTUSEGRAY of FCBBT with T) - [replace PBTGRAYWIDTHLESSONE of FCBBT - with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH) - of TEXTUREBM) - 16] - [replace PBTGRAYHEIGHTLESSONE of FCBBT - with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT) - of TEXTUREBM) - 16] - (replace PBTDISJOINT of FCBBT with T) - (\SETPBTFUNCTION FCBBT 'TEXTURE OPERATION) - (replace PBTHEIGHT of FCBBT with 1) - (* ; - "take into account the brush thickness.") - (SETQ CX (\DSPTRANSFORMX CENTERX HQFX80DATA)) - (SETQ CY (\DSPTRANSFORMY CENTERY HQFX80DATA)) - (* ; - "change Y TOP and BOTTOM to be in bitmap coordinates") - (SETQ CY (\SFInvert DESTINATION-BITMAP CY)) - [SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DESTINATION-BITMAP TOP)) - (SETQ TOP (SUB1 (\SFInvert DESTINATION-BITMAP - BOTTOM] - (COND - ((EQ RADIUS 0) (* ; - "put a single point down. Use \LINEBLT to get proper texture. NIL") - (\LINEBLT FCBBT CX CY CX DESTINATIONBASE RASTERWIDTH LEFT - RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1) - (RETURN))) - LOOP - (* ; - "(UNFOLD x 2) is used instead of (ITIMES x 2)") - [COND - [(IGREATERP 0 D) - (SETQ X (ADD1 X)) - (COND - ((IGREATERP (UNFOLD (+ D Y) - 2) - 1) - (SETQ D (+ D (UNFOLD (- X Y) - 2) - 4))) - (T (SETQ D (+ D (UNFOLD X 2) - 1)) (* ; "don't draw unless Y changes.") - (GO LOOP] - ((OR (EQ 0 D) - (IGREATERP X D)) - (SETQ X (ADD1 X)) - (SETQ D (+ D (UNFOLD (- X Y) - 2) - 4))) - (T (SETQ D (+ (- D (UNFOLD Y 2)) - 3] - (COND - ((EQ Y 0) (* ; - "draw the middle line differently to avoid duplication.") - (\LINEBLT FCBBT (- CX X) - CY - (+ CX X) - DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP - GRAYWIDTH GRAYHEIGHT GRAYBASE 1)) - (T (\HQFX80.FILL-CIRCLE-BLT CX CY X Y) - (SETQ Y (SUB1 Y)) - (GO LOOP))) - (MOVETO CENTERX CENTERY HQFX80STREAM) - (RETURN NIL]) - -(\HQFX80.DRAWARC - [LAMBDA (HQFX80STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) - (* hdj "20-Nov-86 14:27") - - (* ;; "draws an arc on an hqfx80stream") - - (\DRAWARC.GENERIC HQFX80STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING]) -) - -(DEFMACRO \HQFX80.FILL-CIRCLE-BLT (CENTER-X CENTER-Y X Y) - - (* ;; "calls bitblt twice to fill in one line of the circle.") - - `(PROGN (\LINEBLT FCBBT (- ,CENTER-X ,X) - (+ ,CENTER-Y ,Y) - (+ ,CENTER-X ,X) - DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1) - (\LINEBLT FCBBT (- ,CENTER-X ,X) - (- ,CENTER-Y ,Y) - (+ ,CENTER-X ,X) - DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE 1))) - - - -(* ;; "curve-drawing") - -(DEFINEQ - -(\HQFX80.DRAWCURVE - [LAMBDA (HQFX80STREAM KNOTS CLOSED BRUSH DASHING) (* hdj "19-Nov-86 14:42") - - (* ;; "draws a spline curve with a given brush on HQFX80STREAM") - - (GLOBALRESOURCE \HQFX80.BRUSHBBT - (LET ([DASHLST (AND DASHING (OR (AND (LISTP DASHING) - (EVERY DASHING (FUNCTION FIXP)) - DASHING) - (\ILLEGAL.ARG DASHING] - (BBT \HQFX80.BRUSHBBT)) - (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 (fetch XCOORD of (CAR KNOTS)) - (fetch YCOORD of (CAR KNOTS)) - BRUSH HQFX80STREAM)) - (2 (OR (type? POSITION (CAR KNOTS)) - (ERROR "bad knot" (CAR KNOTS))) - (OR (type? POSITION (CADR KNOTS)) - (ERROR "bad knot" (CADR KNOTS))) - (\HQFX80.LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS)) - (fetch YCOORD of (CAR KNOTS)) - (fetch XCOORD of (CADR KNOTS)) - (fetch YCOORD of (CADR KNOTS)) - BRUSH DASHLST HQFX80STREAM BBT)) - (\HQFX80.DRAWCURVE2 (PARAMETRICSPLINE KNOTS CLOSED) - BRUSH DASHLST BBT HQFX80STREAM)) - HQFX80STREAM]) - -(\HQFX80.DRAWCURVE2 - [LAMBDA (SPLINE BRUSH DASHLST BBT HQFX80STREAM) (* hdj "19-Nov-86 11:58") - -(* ;;; "Given a spline curve, represented as a set of derivatives for each segment, draw it on HQFX80STREAM using the brush BRUSH, and dashing it according to DASHLST. For speed, use the bitblt table BBT.") - - (DECLARE (SPECVARS . T)) - - (* ;; "Should declare most of these variables local but currently have the \CURVE function between here and \CURVEBBT so can't") - - (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) - (PROG (BRUSHBM DESTINATION-BITMAP OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE - BRUSHRASTERWIDTH LEFT RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH - BOTTOMMINUSBRUSH TOPMINUSBRUSH RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 \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)) - (USERFN (AND (LITATOM BRUSH) - BRUSH))) - - (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\HQFX80.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.\HQFX80.BBTCURVEPT. HQFX80DATA) - (* ; - "curve pts will be kept in screen coordinates, start smoothing values there.") - (\CURVESTART (IDIFFERENCE (ELT (fetch (SPLINE SPLINEX) of SPLINE) - 1) - (LRSH (SUB1 BRUSHWIDTH) - 1)) - (IDIFFERENCE (ELT (fetch (SPLINE SPLINEY) of SPLINE) - 1) - (LRSH (SUB1 BRUSHHEIGHT) - 1] - [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) - when (PROGN - -(* ;;; "Loop thru the segments of the spline curve, drawing each in turn.") - - (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) - KNOT)) (* ; - "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.") - (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS - BRUSHBM HQFX80DATA BBT NIL USERFN HQFX80STREAM)) - (T (* ; - "Draw this run of points, using the brush.") - (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS - BRUSHBM HQFX80DATA BBT NIL NIL HQFX80STREAM] - (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 (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y - 64 BRUSHBM HQFX80DATA BBT NIL USERFN - HQFX80STREAM)) - (T (\HQFX80.DRAWCURVE3 X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 - BRUSHBM HQFX80DATA BBT NIL NIL HQFX80STREAM))) - (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 (\HQFX80.DRAWCURVE3 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM HQFX80DATA BBT T USERFN - HQFX80STREAM)) - (T (\HQFX80.DRAWCURVE3 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM HQFX80DATA BBT T NIL - HQFX80STREAM]) - -(\HQFX80.DRAWCURVE3 - [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM HQFX80DATA BBT ENDING USERFN HQFX80STREAM) - (* hdj "19-Nov-86 12:18") - (DECLARE (LOCALVARS . T) - (USEDFREE BRUSHWIDTH BRUSHHEIGHT \CURX \OLDX \CURY \OLDY)) - - (* ;; "Puts a spline segment down. Since it calls BitBlt 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 (IDIFFERENCE X0 (LRSH (SUB1 BRUSHWIDTH) - 1))) - (SETQ OLDY (IDIFFERENCE Y0 (LRSH (SUB1 BRUSHHEIGHT) - 1] (* ; "draw origin point") - (\HQFX80.SMOOTH-CURVE OLDX OLDY USERFN HQFX80STREAM) - (* ; - "convert the derivatives to fractional representation.") - (* ; "\CONVERTTOFRACTION always returns a large number box. This uses .49 because .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) - (\HQFX80.SMOOTH-CURVE OLDX OLDY USERFN HQFX80STREAM))) - (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 (\HQFX80.SMOOTH-CURVE ( - \GETINTEGERPART - TX) - (\GETINTEGERPART TY) - USERFN HQFX80STREAM) - (\BOXIPLUS TX DELTAX) - (\BOXIPLUS TY DELTAY] - (* ; "draw the end point") - (COND - (USERFN (\HQFX80.SMOOTH-CURVE X1 Y1 USERFN HQFX80STREAM)) - (T (\HQFX80.SMOOTH-CURVE (IDIFFERENCE X1 (LRSH (SUB1 BRUSHWIDTH) - 1)) - (IDIFFERENCE Y1 (LRSH (SUB1 BRUSHHEIGHT) - 1)) - NIL HQFX80STREAM))) - (AND HQFX80STREAM (MOVETO (FIX X1) - (FIX Y1) - HQFX80STREAM] - (COND - (ENDING (\HQFX80.SMOOTH-CURVE (IPLUS \CURX \CURX (IMINUS \OLDX)) - (IPLUS \CURY \CURY (IMINUS \OLDY)) - USERFN HQFX80STREAM) - (\HQFX80.SMOOTH-CURVE (IPLUS \CURX \CURX (IMINUS \OLDX)) - (IPLUS \CURY \CURY (IMINUS \OLDY)) - USERFN HQFX80STREAM))) - (RETURN NIL]) - -(\HQFX80.LINEWITHBRUSH - [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST HQFX80STREAM BBT) (* ; "Edited 5-Jan-87 16:57 by hdj") - - (* ;; "draws a line with a brush on a HQFX80STREAM") - - (DECLARE (LOCALVARS . T)) - (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) - (PROG (DESTINATION-BITMAP LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH - BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH - BRUSHRASTERWIDTH OPERATION HEIGHTMINUS1 HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY - YINC CDL (DASHON T) - (DASHTAIL DASHLST) - (DASHCNT (CAR DASHLST)) - (USERFN (AND (LITATOM BRUSH) - BRUSH))) - - (* ;; "many of these variables are used by the macro for \HQFX80.CURVEPT that passes them to \HQFX80.BBTCURVEPT and .SETUP.FOR.\\HQFX80.BBTCURVEPT. sets them up.") - - [COND - ((NOT USERFN) - (.SETUP.FOR.\HQFX80.BBTCURVEPT. HQFX80DATA) - (* ; - "SUB1 is so that the extra bit goes on the top and right as it is documented as doing for lines.") - [SETQ X1 (- X1 (SETQ HALFBRUSHWIDTH (FOLDLO (SUB1 BRUSHWIDTH) - 2] - (SETQ X2 (- X2 HALFBRUSHWIDTH)) - [SETQ Y1 (- Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO (SUB1 BRUSHHEIGHT) - 2] - (* ; - "take into account the brush thickness.") - (SETQ Y2 (- Y2 HALFBRUSHHEIGHT] (* ; - "arrange things so that dx is positive.") - (COND - ((> X1 X2) (* ; "switch points") - (swap X1 X2) - (swap Y1 Y2))) - (SETQ DX (ADD1 (- X2 X1))) - [SETQ DY (ADD1 (COND - ((> Y2 Y1) - (SETQ YINC 1) - (- Y2 Y1)) - (T (SETQ YINC -1) - (- Y1 Y2] - [SETQ CDL (HALF (COND - ((> 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 (> X1 X2) - do (* ; "main loop") - (COND - (DASHON (APPLY* USERFN X1 Y1 HQFX80STREAM))) - [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 (> DX (add CDL DY))) - (add Y1 YINC) - (COND - ((COND - ((EQ YINC -1) - (ILESSP Y1 Y2)) - ((> Y1 Y2))) - (RETURN))) - (SETQ CDL (- CDL DX] - (add X1 1))) - (T (* ; "Y is the fastest mover.") - (until (COND - ((EQ YINC -1) - (ILESSP Y1 Y2)) - ((> Y1 Y2))) - do (* ; "main loop") - (COND - (DASHON (APPLY* USERFN X1 Y1 HQFX80STREAM))) - [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 (> DY (SETQ CDL (+ CDL DX] - (COND - ((> (SETQ X1 (ADD1 X1)) - X2) - (RETURN))) - (SETQ CDL (- CDL DY] - (add Y1 YINC] - (T (COND - [(IGEQ DX DY) (* ; "X is the fastest mover.") - (until (> X1 X2) do (* ; "main loop") - (COND - (DASHON (\HQFX80.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 (> DX (SETQ CDL (+ CDL DY] - (SETQ Y1 (+ Y1 YINC)) - (COND - ((COND - ((EQ YINC -1) - (ILESSP Y1 Y2)) - ((> Y1 Y2))) - (RETURN))) - (SETQ CDL (- CDL DX] - (SETQ X1 (ADD1 X1] - (T (* ; "Y is the fastest mover.") - (until (COND - ((EQ YINC -1) - (ILESSP Y1 Y2)) - ((> Y1 Y2))) - do (* ; "main loop") - (COND - (DASHON (\HQFX80.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 (> DY (SETQ CDL (+ CDL DX] - (COND - ((> (SETQ X1 (ADD1 X1)) - X2) - (RETURN))) - (SETQ CDL (- CDL DY] - (SETQ Y1 (+ Y1 YINC] - (RETURN NIL]) -) -(DEFINEQ - -(\HQFX80.BBTCURVEPT - [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 TOPMINUSBRUSH DESTINATION-BITMAP - BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH - HQFX80DATA) (* hdj " 6-Nov-86 14:36") - - (* ;; "Called by \hqfx80.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) - (replace 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] - (replace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT (IDIFFERENCE Y - BOTTOMMINUSBRUSH - )) - STY] - (replace PBTDEST of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH (\SFInvert - - DESTINATION-BITMAP - CLIPPEDTOP] - [COND - [(ILESSP X LEFT) (* ; - "only the right part of the brush is visible") - (replace PBTDESTBIT of BBT with LEFT) - (replace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH (replace PBTWIDTH of BBT - with (IDIFFERENCE X - LEFTMINUSBRUSH] - (T (* ; "left edge is visible") - (replace PBTDESTBIT of BBT with X) - (replace PBTSOURCEBIT of BBT with 0) (* ; - "set width to the amount that is visible") - (replace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X] - (\PILOTBITBLT BBT 0]) -) -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \HQFX80.CURVEPT MACRO [OPENLAMBDA (X Y) - - (* ;; "puts a brush shape at point X,Y. Assumes X and Y have been corrected so that it is the lower left corner of the brush. Does a clipping to the region defined by LEFT RIGHTPLUS1 BOTTOM and LEFTMINUSBRUSH TOPMINUSBRUSH BOTTOMMINUSBRUSH.") - - (COND - ((OR (ILEQ X LEFTMINUSBRUSH) - (IGEQ X RIGHTPLUS1) - (ILEQ Y BOTTOMMINUSBRUSH) - (IGEQ Y TOP)) (* ; "Brush is entirely out of region") - NIL) - ((NULL BBT) (* ; - "Special case of single point brush") - (\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 - RASTERWIDTH)) - (T (* ; - "Some part of the brush in in the region") - (\HQFX80.BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH - RIGHTPLUS1 TOPMINUSBRUSH DESTINATION-BITMAP - BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE - DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH - HQFX80DATA]) -) - -(DEFMACRO \HQFX80.SMOOTH-CURVE (NEWX NEWY USERFN HQFX80STREAM) - `(LET [(DX (IABS (- ,NEWX \OLDX))) - (DY (IABS (- ,NEWY \OLDY] - (COND - ((OR (> DX 1) - (> DY 1)) - [COND - ((NEQ [+ (ADD1 (- \OLDX \OLDERX)) - (ITIMES 3 (ADD1 (- \OLDY \OLDERY] - 4) - [COND - (DASHON (COND - (,USERFN (APPLY* ,USERFN \OLDX \OLDY ,HQFX80STREAM)) - (T (\HQFX80.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))) - -(DEFMACRO .SETUP.FOR.\HQFX80.BBTCURVEPT. (HQFX80DATA) - `(LET [(CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION ,HQFX80DATA] - (SETQ BOTTOM (ffetch (REGION BOTTOM) of CLIPPINGREGION)) - (SETQ TOP (ffetch (REGION TOP) of CLIPPINGREGION)) - (SETQ RIGHTPLUS1 (ffetch (REGION RIGHT) of CLIPPINGREGION)) - (SETQ LEFT (ffetch (REGION LEFT) of CLIPPINGREGION)) - (SETQ DESTINATION-BITMAP (HQFX80DATA-BACKINGBITMAP ,HQFX80DATA)) - (SETQ OPERATION (HQFX80DATA-OPERATION ,HQFX80DATA)) - (SETQ BRUSHBM (\GETBRUSH BRUSH)) - (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of DESTINATION-BITMAP)) - (SETQ DESTINATIONBASE (fetch (BITMAP BITMAPBASE) of DESTINATION-BITMAP)) - (SETQ BBT (\HQFX80.CREATE-BRUSH-BBT BRUSHBM ,HQFX80DATA BBT)) - (SETQ BRUSHBASE (fetch (BITMAP BITMAPBASE) of BRUSHBM)) - - (* ;; "keep Brush width and raster width in number of bits units.") - - (SETQ BRUSHRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BRUSHBM)) - [COND - ((NULL BBT) - - (* ;; "BBT is NIL if single point brush. Set the destination bitmap base.") - - (SETQ HEIGHTMINUS1 (SUB1 (fetch (BITMAP BITMAPHEIGHT) of DESTINATION-BITMAP))) - (COND - ((EQ (HQFX80DATA-OPERATION ,HQFX80DATA) - 'INVERT) - - (* ;; "really do invert in single brush case.") - - (SETQ OPERATION 'INVERT] - (SETQ BRUSHWIDTH (fetch (BITMAP BITMAPWIDTH) of BRUSHBM)) - (SETQ BRUSHHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM)) - (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT BRUSHWIDTH)) - (SETQ BOTTOMMINUSBRUSH (IDIFFERENCE BOTTOM BRUSHHEIGHT)) - (SETQ TOPMINUSBRUSH (IDIFFERENCE TOP BRUSHHEIGHT)))) - - - -(* ;; "character printing methods") - -(DEFINEQ - -(\HQFX80.OUTCHAR - [LAMBDA (HQFX80STREAM CHARCODE) (* ; "Edited 4-Feb-87 15:11 by hdj") - - (* ;; "Displays the character and increments the Xposition on the HQFX80STREAM.") - - (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) - - (* ;; "If necessary, change the charset ") - - (if (NEQ (HQFX80DATA-CHARSET-CACHE HQFX80DATA) - (\CHARSET CHARCODE)) - then (\HQFX80.CHANGE-CHARSET HQFX80DATA (\CHARSET CHARCODE))) - (SELCHARQ CHARCODE - (^L (* ; "form-feed") - (\HQFX80.NEWPAGE HQFX80STREAM)) - ((EOL CR LF) (* ; "various line-enders") - (\HQFX80.NEWLINE CHARCODE HQFX80STREAM)) - (LET ((CHARWIDTH (\HQFX80.CHARWIDTH HQFX80STREAM CHARCODE))) - - (* ;; "if character will be at least partly visible, output it") - - (if (\HQFX80.CUR-POS-VISIBLE? HQFX80DATA) - then (IF (NEQ CHARCODE (CHARCODE SPACE)) - THEN - - (* ;; - "only bitblt real, printing characters -- pilotbbt won't do the right thing with amplified spaces") - - (\HQFX80.BLT-CHAR CHARCODE CHARWIDTH HQFX80STREAM HQFX80DATA)) - ) - (CL:INCF (HQFX80DATA-XPOS HQFX80DATA) - CHARWIDTH) - - (* ;; "if we've passed the margin, DING!, do a newline") - - (if (> (HQFX80DATA-XPOS HQFX80DATA) - (HQFX80DATA-RIGHTMARGIN HQFX80DATA)) - then (\HQFX80.NEWLINE (CHARCODE EOL) - HQFX80STREAM]) - -(\HQFX80.BLT-CHAR - [LAMBDA (CHARCODE CHARWIDTH HQFX80STREAM HQFX80DATA) (* ; "Edited 12-Feb-87 14:17 by jds") - - (* ;; "puts a character on an HQFX80 stream. Much of the information needed by the BitBlt microcode is prestored by the routines that change it. This is kept in the BitBltTable.") - (* (DECLARE (LOCALVARS . T))) - (LET* ((CURX (FIXR (HQFX80DATA-XPOS HQFX80DATA))) - (CHAR8CODE (\CHAR8CODE CHARCODE)) - (RIGHT (+ CURX CHARWIDTH)) - (LEFT NIL) - (CLIPPINGREGION (HQFX80DATA-CLIPPINGREGION HQFX80DATA)) - (RIGHT-CLIPPING-EDGE (fetch (REGION RIGHT) of CLIPPINGREGION)) - (LEFT-CLIPPING-EDGE (fetch (REGION LEFT) of CLIPPINGREGION)) - (PILOTBBT (HQFX80DATA-PILOTBBT HQFX80DATA))) - -(* ;;; "clip the bitmap to fit the stream's clipping region") - - (* ;; "does character overlap right edge of clipping region?") - - (SETQ RIGHT (MIN RIGHT-CLIPPING-EDGE RIGHT)) - - (* ;; "does character overlap left edge of clipping region?") - - (SETQ LEFT (MAX CURX LEFT-CLIPPING-EDGE)) - (COND - ((AND (< LEFT RIGHT) - (NEQ (fetch (PILOTBBT PBTHEIGHT) of PILOTBBT) - 0)) - (UNINTERRUPTABLY - (freplace (PILOTBBT PBTDESTBIT) of PILOTBBT with LEFT) - (freplace (PILOTBBT PBTWIDTH) of PILOTBBT with (- RIGHT LEFT)) - (freplace (PILOTBBT PBTSOURCEBIT) of PILOTBBT with (- (+ ( - \HQFX80.GET-CHARACTER-OFFSET - CHAR8CODE HQFX80DATA) - LEFT) - CURX)) - (\PILOTBITBLT PILOTBBT 0)) - T]) -) - - - -(* ;; "printer code") - -(DEFINEQ - -(\HQFX80.DUMP-PAGE-BUFFER - [LAMBDA (BITMAP HQFX80STREAM) (* ; "Edited 23-Sep-88 10:25 by jds") - -(* ;;; "send a bitmap to the FX-80") - - (* ;; "how it works: we use a specially created bitblt table (HQFX80DATA-SERIALIZING-PILOTBBT) to turn eight-bit-high by one-bit-wide columns of BITMAP into eight-bit-wide by one-bit-high bytes. This extraction is done by \HQFX80.BITMAP-LDB.") - - (DECLARE (LOCALVARS . T)) - (WITH-HQFX80-DATA (HQFX80DATA HQFX80STREAM) - (LET* ((WIDTH (BITMAPWIDTH BITMAP)) - (WIDTH-MINUS-1 (SUB1 WIDTH)) - [HEIGHT (FIX (TIMES \HQFX80.INCHES-PER-PAGE (if (HQFX80DATA-COMPRESSED? - HQFX80DATA) - then - \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI - else \HQFX80.1-TO-1-MODE-DPI] - (HEIGHT-MINUS-1 (SUB1 HEIGHT)) - (BACKING-STREAM (HQFX80DATA-BACKINGSTREAM HQFX80DATA)) - (BITMAP-BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) - (BITMAP-WIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) - (MAPPING-TABLE (HQFX80DATA-SERIALIZING-PILOTBBT HQFX80DATA)) - (BYTE-BOX (HQFX80DATA-SERIALIZING-BOX HQFX80DATA)) - (SCRATCH-SCANLINE-PILOTBBT (HQFX80DATA-SCRATCH-SCANLINE-PILOTBBT HQFX80DATA)) - (EIGHT-LINES-BLANK (HQFX80DATA-EIGHT-LINES-BLANK HQFX80DATA)) - (EIGHT-LINES-BLANK-PILOTBBT (HQFX80DATA-EIGHT-LINES-BLANK-PILOTBBT HQFX80DATA)) - (COMPRESSED? (HQFX80DATA-COMPRESSED? HQFX80DATA))) - - (* ;; "set the mode") - - (\HQFX80.PRINTER-MODE :UNIDIRECTIONAL-ON BACKING-STREAM) - (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM) - - (* ;; "pack the bitmap into FX80 format and ship it") - - [for EIGHT-SCANLINE-SWATH from 0 to HEIGHT-MINUS-1 by 8 - do [COND - ((ILESSP (IDIFFERENCE HEIGHT-MINUS-1 EIGHT-SCANLINE-SWATH) - 8) (* ; - "There are fewer than 8 scan lines left on the page image; only advance by that amount.") - (\HQFX80.PRINTER-MODE :N-SPACING-ON BACKING-STREAM - (IDIFFERENCE HEIGHT-MINUS-1 EIGHT-SCANLINE-SWATH] - (COND - ((\HQFX80.EIGHT-LINES-BLANK? BITMAP-BASE EIGHT-SCANLINE-SWATH - BITMAP-WIDTH SCRATCH-SCANLINE-PILOTBBT - EIGHT-LINES-BLANK-PILOTBBT EIGHT-LINES-BLANK) - - (* ;; "skip the next eight blank lines") - - (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM) - (\HQFX80.ADVANCE-8-LINES HQFX80STREAM)) - (T - (* ;; "something to print in the next eight scanlines; do so") - - (\HQFX80.PRINTER-MODE :EIGHT-SPACING-ON BACKING-STREAM) - (\HQFX80.GRAPHICS-MODE WIDTH COMPRESSED? BACKING-STREAM) - (for COLUMN from 0 to WIDTH-MINUS-1 - do (\HQFX80.BITMAP-LDB BITMAP-BASE COLUMN EIGHT-SCANLINE-SWATH - MAPPING-TABLE BITMAP-WIDTH) - (BOUT BACKING-STREAM (\GETBASEBYTE BYTE-BOX 0))) - (BOUT BACKING-STREAM (CHARCODE CR)) - (BOUT BACKING-STREAM (CHARCODE LF] - (\HQFX80.PRINTER-MODE :UNIDIRECTIONAL-OFF BACKING-STREAM) - (\HQFX80.PRINTER-MODE :TWELVE-SPACING-ON BACKING-STREAM]) - -(\HQFX80.ADVANCE-8-LINES - [LAMBDA (HQFX80STREAM) (* ; "Edited 11-Feb-87 11:03 by jds") - - (* ;; "advance the printhead 8 raster lines. since we assume that we're in the :eight-spacing-on printermode, just send an LF") - - (\HQFX80.BOUT HQFX80STREAM (CHARCODE LF]) -) - -(DEFMACRO \HQFX80.EIGHT-LINES-BLANK? (BITMAP-BASE Y-COORD BITMAP-WIDTH-IN-WORDS EIGHT-INTO-ONE-PBBT - SCANLINE-INTO-WORD-PBBT WORD-BOX) - - (* ;; "returns T if the next 8 lines of the bitmap are all blank. This is done by or'ing the 8 scanlines into a scratch bitmap, then or'ing the words of that scanline into a result word, and comparing that to 0. We clear the scanline and word buffers at the end.") - - `(LET ((EIGHT-INTO-ONE-PBBT ,EIGHT-INTO-ONE-PBBT) - (SCANLINE-INTO-WORD-PBBT ,SCANLINE-INTO-WORD-PBBT) - (WORD-BOX ,WORD-BOX) - (BITMAP-WIDTH-IN-WORDS ,BITMAP-WIDTH-IN-WORDS)) - [FREPLACE (PILOTBBT PBTSOURCE) OF EIGHT-INTO-ONE-PBBT WITH (\ADDBASE ,BITMAP-BASE - (TIMES - , - BITMAP-WIDTH-IN-WORDS - ,Y-COORD] - (\PILOTBITBLT EIGHT-INTO-ONE-PBBT 0) - (\PILOTBITBLT SCANLINE-INTO-WORD-PBBT 0) - (PROG1 (EQ (\GETBASE WORD-BOX 0) - 0) - (\HQFX80.CLEAR-SCANLINE EIGHT-INTO-ONE-PBBT BITMAP-WIDTH-IN-WORDS) - (\HQFX80.CLEAR-WORD-BOX WORD-BOX)))) - -(DEFMACRO \HQFX80.BITMAP-LDB (BITMAP-BASE X Y PILOTBBT BITMAP-WIDTH-IN-WORDS) - - (* ;; "point the serializing bitblt table at a new column of the bitmap. The X coord increases left to right, the Y coord increases top to bottom, and names the uppermost pixel of the column we're moving.") - - `(LET ((X ,X) - (PILOTBBT ,PILOTBBT)) - [FREPLACE (PILOTBBT PBTSOURCE) OF PILOTBBT WITH (\ADDBASE ,BITMAP-BASE - (+ (TIMES ,Y ,BITMAP-WIDTH-IN-WORDS) - (FOLDLO X BITSPERWORD] - (FREPLACE (PILOTBBT PBTSOURCEBIT) OF PILOTBBT WITH (LOGAND 15 X)) - (\PILOTBITBLT PILOTBBT 0))) - -(DEFMACRO \HQFX80.CLEAR-SCANLINE (SCANLINE-PILOTBBT SCANLINE-WIDTH-IN-WORDS) - - (* ;; "clear out the destination of the pilotbbt the fast way - store a zero in its last word and perform an overlapping blt (which runs back to front).") - - `(LET [(SCANLINE (FETCH (PILOTBBT PBTDEST) OF ,SCANLINE-PILOTBBT)) - (LAST-WORD (SUB1 ,SCANLINE-WIDTH-IN-WORDS] - (\PUTBASE SCANLINE LAST-WORD 0) - (\BLT SCANLINE (\ADDBASE SCANLINE 1) - LAST-WORD))) - -(DEFMACRO \HQFX80.CLEAR-WORD-BOX (WORD-BOX) - `(\PUTBASE ,WORD-BOX 0 0)) - -(CL:DEFUN \HQFX80.SEND (PRINTER FILENAME &OPTIONAL OPTIONS) - - (* ;; "send the file designated by FILENAME to PRINTER, obeying OPTIONS. Since we only have one fx-80 per machine, ignore PRINTER and send to HQFX80-DEFAULT-DESTINATION") - - (DECLARE (GLOBALVARS HQFX80-DEFAULT-DESTINATION)) - [LET ((COPIES (OR (LISTGET OPTIONS '%#COPIES) - 1))) - (FOR COPY FROM 1 TO COPIES DO - (* ;; "allow the user to abort it while running") - - (WITH-ABORT-WINDOW ((THIS.PROCESS) - FILENAME PRINTER COPY) - (COPYFILE FILENAME HQFX80-DEFAULT-DESTINATION - '((TYPE HQFX80]) - -(CL:DEFUN MAKE-HQFX80 (FILE HQFX80FILE &OPTIONAL FONTS HEADING TABS OPTIONS) - - (* ;; "turn FILE into an HQFX80 master") - - (TEXTTOIMAGEFILE FILE HQFX80FILE 'HQFX80 FONTS HEADING TABS OPTIONS)) - -(CL:DEFUN HQFX80FILEP (HQFX80FILE?) - - (* ;; "is FILE (a filename or stream) an hqfx80 file?") - - [LET [(FILE-TYPE (GETFILEINFO HQFX80FILE? 'TYPE] - (IF (EQ FILE-TYPE 'HQFX80) - THEN (* ; - "if file has a type, and type=HQFX80, we win") - T - ELSE (* ; - "no filetype or filetype not HQFX80, so read the file") - (LET [(STREAM (OPENSTREAM (INTERLISP-NAMESTRING HQFX80FILE?) - 'INPUT - 'OLD - '(SEQUENTIAL] - - (* ;; "file looks like ESC@...") - - (PROG1 [AND (> (GETFILEINFO STREAM 'LENGTH) - (+ 2 (NCHARS \HQFX80.FILE-SIGNATURE))) - (EQ (CHARCODE ESC) - (BIN STREAM)) - (EQ (CHARCODE @) - (BIN STREAM)) - (FOR CH INSTRING \HQFX80.FILE-SIGNATURE - ALWAYS (EQ CH (BIN STREAM] - (CLOSEF STREAM]) - - - -(* ;; "window hardcopy") - -(DEFINEQ - -(\HQFX80.BITMAP-FILE - [LAMBDA (FILE BITMAP SCALEFACTOR REGION ROTATION TITLE) (* ; "Edited 1-Jun-87 13:10 by Snow") - - (* ;; "print a bitmap on the fx-80. ignore SCALEFACTOR and ROTATION for now.") - - (LET* ((HQFX80STREAM (OPENIMAGESTREAM FILE 'HQFX80)) - (NEWBITMAP (COND - (REGION (BITMAPCREATE (fetch (REGION WIDTH) of REGION) - (fetch (REGION HEIGHT) of REGION))) - (T BITMAP))) - (WIDTH (BITMAPWIDTH NEWBITMAP)) - (HEIGHT (BITMAPHEIGHT NEWBITMAP)) - (PAGE-REGION (DSPCLIPPINGREGION NIL HQFX80STREAM)) - (PAGE-WIDTH (fetch (REGION WIDTH) of PAGE-REGION)) - (PAGE-HEIGHT (fetch (REGION HEIGHT) of PAGE-REGION))) - - (* ;; "clip the bitmap, if requested") - - (AND REGION (BITBLT BITMAP (fetch (REGION LEFT) of REGION) - (fetch (REGION BOTTOM) of REGION) - NEWBITMAP)) - (LET* ((PORTRAIT-OVERHANG (- WIDTH (fetch (REGION WIDTH) of PAGE-REGION))) - (LANDSCAPE-OVERHANG (- HEIGHT (fetch (REGION WIDTH) of PAGE-REGION))) - (BITS-LOST (AND (> PORTRAIT-OVERHANG 0) - (> LANDSCAPE-OVERHANG 0))) - (LANDSCAPE-PRINT (> PORTRAIT-OVERHANG LANDSCAPE-OVERHANG))) - - (* ;; "print the title of the image on the top of the page") - - (LET* ((IMAGE-TITLE (OR TITLE "Window Image")) - (TITLE-REGION (STRINGREGION IMAGE-TITLE HQFX80STREAM))) - (MOVETO (/ (- PAGE-WIDTH (fetch (REGION WIDTH) of TITLE-REGION)) - 2) - (- (- PAGE-HEIGHT 1) - (FONTPROP HQFX80STREAM 'HEIGHT)) - HQFX80STREAM) - (PRIN1 IMAGE-TITLE HQFX80STREAM)) - - (* ;; "blt the bitmap onto the page. use replace mode so it will obscure title if need be") - - [COND - (BITS-LOST - - (* ;; "apologize and blt as much as will fit") - - (PRINTOUT PROMPTWINDOW "Bitmap is larger than FX-80 page - " - "image will be clipped" T) - (BITBLT NEWBITMAP NIL NIL HQFX80STREAM 0 0 NIL NIL 'INPUT 'REPLACE)) - (T - - (* ;; "center it on the page ") - - (* ;; "if there is more overhang in portrait than in landscape - rotate it remember to swap the height and width.") - - (AND LANDSCAPE-PRINT (SETQ NEWBITMAP (ROTATE-BITMAP NEWBITMAP)) - (swap WIDTH HEIGHT)) - (BITBLT NEWBITMAP NIL NIL HQFX80STREAM (/ (- PAGE-WIDTH WIDTH) - 2) - (/ (- PAGE-HEIGHT HEIGHT) - 2) - NIL NIL 'INPUT 'REPLACE] - (CLOSEF HQFX80STREAM]) - -(\HQFX80.CONVERT-TEDIT - [LAMBDA (TEDIT-FILE IMAGESTREAM) (* ; "Edited 11-Dec-86 17:24 by hdj") - - (* ;; "Send the text to the printer.") - - (SETQ TEDIT-FILE (OPENTEXTSTREAM TEDIT-FILE)) - (TEDIT.FORMAT.HARDCOPY TEDIT-FILE IMAGESTREAM T NIL NIL NIL 'HQFX80) - (CLOSEF? IMAGESTREAM) - IMAGESTREAM]) -) - - - -(* ;; "character transmission method") - -(DEFINEQ - -(\HQFX80.BOUT - [LAMBDA (HQFX80SSTREAM BYTE) (* hdj " 7-Nov-86 17:18") - - (* ;; "send a byte to the fx80") - - (WITH-HQFX80-DATA (DATA HQFX80SSTREAM) - (BOUT (HQFX80DATA-BACKINGSTREAM DATA) - BYTE]) -) - - - -(* ;; "handling font-information caching") - -(DEFINEQ - -(\HQFX80.FIX-LINE-LENGTH - [LAMBDA (HQFX80STREAM) (* hdj "14-Nov-86 17:15") - - (* ;; "HQFX80STREAM is a stream of type hqfx80. Called by RIGHTMARGIN LEFTMARGIN and \hqfx80.fix-font to update the LINELENGTH field in the stream. Also called when the stream is created.") - - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (freplace (STREAM LINELENGTH) of HQFX80STREAM - with (MIN MAX.SMALLP (MAX 1 (IQUOTIENT (- (HQFX80DATA-RIGHTMARGIN DATA) - (HQFX80DATA-LEFTMARGIN DATA)) - (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) - of (HQFX80DATA-FONT DATA]) - -(\HQFX80.FIX-FONT - [LAMBDA (HQFX80STREAM HQFX80DATA) (* hdj "10-Nov-86 16:37") - - (* ;; "used to fix up those parts of the bitblt table which depend upon the FONT.") - - (\HQFX80.INVALIDATE-CACHE HQFX80DATA) - (\HQFX80.FIX-LINE-LENGTH HQFX80STREAM]) - -(\HQFX80.FIX-Y - [LAMBDA (HQFX80DATA CSINFO) (* ; "Edited 12-Feb-87 11:46 by jds") - - (* ;; "makes that part of the bitblt table of an HQFX80 stream which deals with the Y information consistent. This is called from \\HQFX80.change-charset whenever a character is being printed and the charset/y-position caches are invalid") - - (PROG ((PBT (HQFX80DATA-PILOTBBT HQFX80DATA)) - (Y (HQFX80DATA-YPOS HQFX80DATA)) - TOP CHARTOP BM) - [SETQ CHARTOP (FIXR (+ Y (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE HQFX80DATA) - (ffetch CHARSETASCENT of CSINFO] - [freplace PBTDEST of PBT - with (\ADDBASE (fetch BITMAPBASE of (SETQ BM (HQFX80DATA-BACKINGBITMAP HQFX80DATA))) - (TIMES (ffetch BITMAPRASTERWIDTH of BM) - (\SFInvert BM (SETQ TOP (FIXR (MAX (MIN (fetch (REGION TOP) - of ( - HQFX80DATA-CLIPPINGREGION - HQFX80DATA)) - CHARTOP) - 0] - [freplace PBTSOURCE of PBT - with (\ADDBASE (ffetch BITMAPBASE of (SETQ BM (ffetch (CHARSETINFO CHARSETBITMAP) - of CSINFO))) - (TIMES (ffetch BITMAPRASTERWIDTH of BM) - (CL:SETF (HQFX80DATA-CHARHEIGHTDELTA HQFX80DATA) - (FIXR (MIN (MAX (- CHARTOP TOP) - 0) - MAX.SMALL.INTEGER] - (freplace PBTHEIGHT of PBT - with (FIXR (MAX [- TOP (MAX (- Y (CL:SETF (HQFX80DATA-CHARSET-DESCENT-CACHE HQFX80DATA) - (ffetch CHARSETDESCENT of CSINFO))) - (fetch (REGION BOTTOM) of (HQFX80DATA-CLIPPINGREGION - HQFX80DATA] - 0]) -) - -(DEFMACRO \HQFX80.INVALIDATE-CACHE (HQFX80DATA) - - (* ;; - "marks the stream as needing to have its cached fields recomputed. used when font changes, etc.") - - `(PROGN (CL:SETF (HQFX80DATA-CHARSET-CACHE ,HQFX80DATA) - MAX.SMALLP) - (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE ,HQFX80DATA) - MAX.SMALLP))) - -(DEFMACRO \HQFX80.INVALIDATE-FONT-CACHE (HQFX80DATA) - `(PROGN (CL:SETF (HQFX80DATA-CHARSET-CACHE ,HQFX80DATA) - MAX.SMALLP) - (CL:SETF (HQFX80DATA-CHARSET-ASCENT-CACHE ,HQFX80DATA) - MAX.SMALLP))) - -(DEFMACRO \HQFX80.GET-CACHED-CHAR-WIDTH (CHARCODE HQFX80DATA) - - (* ;; "get the cached image width of CHARCODE") - - `(\FGETIMAGEWIDTH (HQFX80DATA-IMAGE-WIDTHS-CACHE ,HQFX80DATA) - ,CHARCODE)) - -(DEFMACRO \HQFX80.GET-CHARACTER-OFFSET (CHAR8CODE HQFX80DATA) - `(\GETBASE (HQFX80DATA-OFFSETS-CACHE ,HQFX80DATA) - ,CHAR8CODE)) - - - -(* ;; "auxiliary functions") - - -(CL:DEFUN \HQFX80.GRAPHICS-MODE (ROWS COMPRESSED? BACKING-STREAM) - - (* ;; "put the FX-80 in some graphics mode") - - (BOUT BACKING-STREAM (CHARCODE ESC)) - (BOUT BACKING-STREAM (CHARCODE *)) - (BOUT BACKING-STREAM (* ; - "compressed prints at 120 dpi, regular at 72") - (if COMPRESSED? - then 1 - else 5)) - (BOUT BACKING-STREAM (IREMAINDER ROWS 256)) - (BOUT BACKING-STREAM (FOLDLO ROWS 256))) -(DEFINEQ - -(\HQFX80.PRINTER-MODE - [LAMBDA (FX80-MODE STREAM N-SPACING) (* ; "Edited 23-Sep-88 10:21 by jds") - - (* ;; "put the FX80 printer in some mode") - - (CL:FLET [(SEND-PRINTER-COMMAND (COMMAND-STRING STREAM) - - (* ;; "Send an ESC, to tell the printer there is to be a mode change, and then the specific mode change byte") - - (BOUT STREAM (CHARCODE ESC)) - (for CHAR instring COMMAND-STRING do (BOUT STREAM CHAR] - (SELECTQ FX80-MODE - (:BOLD-ON (SEND-PRINTER-COMMAND "E" STREAM)) - (:BOLD-OFF (SEND-PRINTER-COMMAND "F" STREAM)) - (:COMPRESSED-ON - (SEND-PRINTER-COMMAND (CHARACTER 15) - STREAM)) - (:COMPRESSED-OFF - (BOUT STREAM 18)) - (:ELITE-ON (SEND-PRINTER-COMMAND "M" STREAM)) - (:ELITE-OFF (SEND-PRINTER-COMMAND "P" STREAM)) - (:ITALIC-ON (SEND-PRINTER-COMMAND "4" STREAM)) - (:ITALIC-OFF (SEND-PRINTER-COMMAND "5" STREAM)) - (:PICA-ON (SEND-PRINTER-COMMAND (CONCAT "P" (CHARACTER 18)) - STREAM)) - (:SUBSCRIPT-ON (SEND-PRINTER-COMMAND "S0" STREAM)) - (:SCRIPT-OFF (SEND-PRINTER-COMMAND "T" STREAM)) - (:SUPERSCRIPT-ON - (SEND-PRINTER-COMMAND "S1" STREAM)) - (:EXPAND-ON (SEND-PRINTER-COMMAND "W1" STREAM)) - (:EXPAND-OFF (SEND-PRINTER-COMMAND "W0" STREAM)) - (:PROPORTIONAL-ON - (SEND-PRINTER-COMMAND "p1" STREAM)) - (:PROPORTIONAL-OFF - (SEND-PRINTER-COMMAND "p0" STREAM)) - (:UNIDIRECTIONAL-ON - (SEND-PRINTER-COMMAND "U1" STREAM)) - (:UNIDIRECTIONAL-OFF - (SEND-PRINTER-COMMAND "U0" STREAM)) - (:N-SPACING-ON (* ; "Space n/72 of an inch on LF.") - (SEND-PRINTER-COMMAND (CONCAT "A" (CHARACTER N-SPACING)) - STREAM)) - (:SEVEN-SPACING-ON - (SEND-PRINTER-COMMAND "1" STREAM)) - (:EIGHT-SPACING-ON - (SEND-PRINTER-COMMAND (CONCAT "A" (CHARACTER 8)) - STREAM)) - (:NINE-SPACING-ON (* ; - "Space by 9 print dots per LF. Mostly for graphics mode used in HQ FX-80.") - (SEND-PRINTER-COMMAND "0" STREAM)) - (:TWELVE-SPACING-ON (* ; "Restore normal 1/6%" spacing") - (SEND-PRINTER-COMMAND "2" STREAM)) - (:NO-SKIP (SEND-PRINTER-COMMAND "O" STREAM)) - NIL]) -) - -(DEFMACRO WITH-HQFX80-DATA ((VAR-NAME STREAM) - &BODY - (BODY DECLS ENV)) - `(LET [(,VAR-NAME (FETCH (STREAM IMAGEDATA) OF ,STREAM] - ,@DECLS - ,@BODY)) - - - -(* ;; "and miscellany") - -(DECLARE%: EVAL@COMPILE - -(RPAQ \HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ") - -(RPAQQ \HQFX80.1-TO-1-MODE-DPI 72) - -(RPAQQ \HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120) - - -(CONSTANTS (\HQFX80.FILE-SIGNATURE "HQFX-80/Xerox/1.0 ") - (\HQFX80.1-TO-1-MODE-DPI 72) - (\HQFX80.LOW-SPEED-DOUBLE-MODE-DPI 120)) -) - -(RPAQ? \HQFX80.INCHES-PER-PAGE 11) - -(RPAQ? \HQFX80.INCHES-PER-LINE 8.5) - -(RPAQ? HQFX80-DEFAULT-DESTINATION "{TTY}") - -(RPAQ? HQFX80-FONT-EXTENSIONS DISPLAYFONTEXTENSIONS) - -(RPAQ? HQFX80-FONT-DIRECTORIES DISPLAYFONTDIRECTORIES) - -(RPAQ? HQFX80-FONT-COERCIONS DISPLAYFONTCOERCIONS) - -(RPAQ? HQFX80-MISSING-FONT-COERCIONS DISPLAYFONTCOERCIONS) - -(RPAQQ FX80-PRINTCOMS - ( - (* ;; "The FXPrinter emulator") - - (COMS - (* ;; "top level routine") - - (FUNCTIONS FX80-PRINT)) - (COMS - (* ;; "how to print bitmaps") - - (FUNCTIONS FX80-PRINT.BITMAP) - (FUNCTIONS FX80-PRINT.PRINT-BITMAP FX80-PRINT.PRINT-BITMAP-PORTRAIT - FX80-PRINT.PRINT-BITMAP-LANDSCAPE)) - (COMS - (* ;; "how to print files") - - (FUNCTIONS FX80-PRINT.FILE)))) - - - -(* ;; "The FXPrinter emulator") - - - - -(* ;; "top level routine") - - -(CL:DEFUN FX80-PRINT (THING-TO-PRINT &KEY LANDSCAPE? COMPRESS? HIGH-QUALITY?) - "Prints thing-to-print on the FX-80 printer" - (CL:ETYPECASE THING-TO-PRINT - ((OR WINDOW BITMAP) (FX80-PRINT.BITMAP THING-TO-PRINT LANDSCAPE? COMPRESS?)) - ((OR CL:SYMBOL STRING PATHNAME) (FX80-PRINT.FILE THING-TO-PRINT HIGH-QUALITY?))) - THING-TO-PRINT) - - - -(* ;; "how to print bitmaps") - - -(CL:DEFUN FX80-PRINT.BITMAP (BITMAP-OR-WINDOW LANDSCAPE? COMPRESS?) - "Prints a bitmap or window on the FX-80 printer" - (CL:ETYPECASE BITMAP-OR-WINDOW - (WINDOW (LET* [(WINDOW-REGION (DSPCLIPPINGREGION NIL BITMAP-OR-WINDOW)) - (BM (BITMAPCREATE (FETCH (REGION WIDTH) OF WINDOW-REGION) - (FETCH (REGION HEIGHT) OF WINDOW-REGION] - (BITBLT BITMAP-OR-WINDOW NIL NIL BM) - (FX80-PRINT.BITMAP BM LANDSCAPE? COMPRESS?))) - (BITMAP (FX80-PRINT.PRINT-BITMAP BITMAP-OR-WINDOW LANDSCAPE? COMPRESS?)))) - -(CL:DEFUN FX80-PRINT.PRINT-BITMAP (BITMAP LANDSCAPE? COMPRESS?) - "Print a bitmap on the FX-80, either landscape or portrait" - (IF LANDSCAPE? - THEN (FX80-PRINT.PRINT-BITMAP-LANDSCAPE BITMAP COMPRESS?) - ELSE (FX80-PRINT.PRINT-BITMAP-PORTRAIT BITMAP COMPRESS?))) - -(CL:DEFUN FX80-PRINT.PRINT-BITMAP-PORTRAIT (BITMAP COMPRESS?) - "Prints a bitmap on the FX-80 in portrait mode" - [LET ((HQFX80STREAM (OPENIMAGESTREAM HQFX80-DEFAULT-DESTINATION 'HQFX80 (LIST 'COMPRESSED - COMPRESS?))) - (WIDTH (BITMAPWIDTH BITMAP)) - (HEIGHT (BITMAPHEIGHT BITMAP))) - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (LET ((PAGE-WIDTH (fetch (REGION WIDTH) of (HQFX80DATA-CLIPPINGREGION DATA))) - (PAGE-HEIGHT (fetch (REGION HEIGHT) of (HQFX80DATA-CLIPPINGREGION DATA)) - (HQFX80DATA-CLIPPINGREGION DATA))) - - (* ;; "center it if possible") - - (BITBLT BITMAP NIL NIL HQFX80STREAM (MAX 0 (/ (- PAGE-WIDTH WIDTH) - 2)) - (MAX 0 (/ (- PAGE-HEIGHT HEIGHT) - 2)) - NIL NIL 'INPUT 'REPLACE) - (CLOSEF HQFX80STREAM]) - -(CL:DEFUN FX80-PRINT.PRINT-BITMAP-LANDSCAPE (BITMAP COMPRESS?) - "Prints a bitmap on the FX-80 in landscape mode" - [LET ((HQFX80STREAM (OPENIMAGESTREAM HQFX80-DEFAULT-DESTINATION 'HQFX80 (LIST 'COMPRESSED - COMPRESS?))) - (WIDTH (BITMAPHEIGHT BITMAP)) - (HEIGHT (BITMAPWIDTH BITMAP)) - (ROTATED-BITMAP (ROTATE-BITMAP BITMAP))) - (WITH-HQFX80-DATA (DATA HQFX80STREAM) - (LET ((PAGE-WIDTH (fetch (REGION WIDTH) of (HQFX80DATA-CLIPPINGREGION DATA))) - (PAGE-HEIGHT (fetch (REGION HEIGHT) of (HQFX80DATA-CLIPPINGREGION DATA)) - (HQFX80DATA-CLIPPINGREGION DATA))) - (BITBLT ROTATED-BITMAP NIL NIL HQFX80STREAM (MAX 0 (/ (- PAGE-WIDTH WIDTH) - 2)) - (MAX 0 (/ (- PAGE-HEIGHT HEIGHT) - 2)) - NIL NIL 'INPUT 'REPLACE) - (CLOSEF HQFX80STREAM]) - - - -(* ;; "how to print files") - - -(CL:DEFUN FX80-PRINT.FILE (FILE-NAME HIGH-QUALITY?) - "Prints a file on the FX-80" - (SEND.FILE.TO.PRINTER (INTERLISP-NAMESTRING FILE-NAME) - (IF HIGH-QUALITY? - THEN 'HQFX80 - ELSE 'FASTFX80))) - - - -(* ; "common routines") - - -(DEFMACRO WITH-ABORT-WINDOW ((PROCESS FILE-NAME PRINTER-NAME COPY#) - &BODY - (FORMS DECLS)) - "executes FORMS, allowing termination by menu selection" - `(LET [(WINDOW (\FX80.CREATE-SEND-ABORT-WINDOW ,PROCESS ,FILE-NAME ,PRINTER-NAME ,COPY#] - (CL:UNWIND-PROTECT - (PROGN ,@DECLS (BLOCK 3000) - ,@FORMS) - (CLOSEW WINDOW)))) - -(CL:DEFUN \FX80.CREATE-SEND-ABORT-WINDOW (SENDING-PROCESS FILE-OR-STREAM PRINTER-NAME COPY#) - (LET* [(DOCUMENT-TYPE-AND-NAME-STRING (IF (STREAMP FILE-OR-STREAM) - THEN (IF (FETCH (STREAM NAMEDP) OF FILE-OR-STREAM) - THEN (CONCAT "the file " (FULLNAME - FILE-OR-STREAM) - ) - ELSE "an unnamed document") - ELSE FILE-OR-STREAM)) - (WINDOW-WIDTH (WIDTHIFWINDOW 270)) - (WINDOW-HEIGHT (HEIGHTIFWINDOW 120)) - (ABORT-MENU-ITEM "Abort") - (ABORT-MENU-FONT (FONTCREATE 'GACHA 12 'BRR)) - (ABORT-WINDOW (CREATEW (CREATEREGION (RAND 0 (- SCREENWIDTH WINDOW-WIDTH)) - (- SCREENHEIGHT WINDOW-HEIGHT) - WINDOW-WIDTH WINDOW-HEIGHT))) - (ABORT-WINDOW-FONT (DSPFONT NIL ABORT-WINDOW)) - (BOLD-ABORT-WINDOW-FONT (FONTCOPY ABORT-WINDOW-FONT 'WEIGHT 'BOLD] - (PRINTOUT ABORT-WINDOW "Sending copy " COPY# " of " .FONT BOLD-ABORT-WINDOW-FONT - DOCUMENT-TYPE-AND-NAME-STRING .FONT ABORT-WINDOW-FONT " to " .FONT - BOLD-ABORT-WINDOW-FONT PRINTER-NAME .FONT ABORT-WINDOW-FONT "." T) - (PRINTOUT ABORT-WINDOW "Select %"Abort%" below to stop printing " - " this and all subsequent copies." T) - (ADDMENU (CREATE MENU - ITEMS _ `[(,ABORT-MENU-ITEM (PROGN (PROCESS.EVAL ,SENDING-PROCESS - '(ERROR!)) - (PRINTOUT ,ABORT-WINDOW T - "... printing aborted.") - (BLOCK 2000) - (CLOSEW ,ABORT-WINDOW)) - ,(CONCAT - "Stops printing this and all subsequent copies of " - DOCUMENT-TYPE-AND-NAME-STRING "."] - MENUFONT _ ABORT-MENU-FONT) - ABORT-WINDOW - (CREATEPOSITION (/ (- WINDOW-WIDTH (STRINGWIDTH ABORT-MENU-ITEM ABORT-MENU-FONT)) - 2) - 20)) - ABORT-WINDOW)) - -(CL:DEFUN \ADD-TO-FONTPROFILE (FONTPROFILE FONTCLASS DEVICE FONT-DESCRIPTION) - - (* ;; "sets the DEVICE component of the FONTCLASS entry of FONTPROFILE to be FONT-DESCRIPTION.") - - (LET ((BUCKET (FASSOC FONTCLASS FONTPROFILE))) - (IF (NULL BUCKET) - THEN (ERROR "No such fontclass as " FONTCLASS) - ELSE - (* ;; "the bucket looks like") - - (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont") - - (* ;; " (dev1 dev1-font) (dev2 dev2-font) ... )") - - [SELECTQ DEVICE - (DISPLAY (CL:SETF (CL:THIRD BUCKET) - FONT-DESCRIPTION)) - (PRESS (CL:SETF (CL:FOURTH BUCKET) - FONT-DESCRIPTION)) - (INTERPRESS (CL:SETF (CL:FIFTH BUCKET) - FONT-DESCRIPTION)) - (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT - INTERPRESS-FONT . A-LIST) - BUCKET - (IF (NULL A-LIST) - THEN (RPLACD (LAST BUCKET) - (LIST (LIST DEVICE FONT-DESCRIPTION))) - ELSE (PUTASSOC DEVICE (LIST FONT-DESCRIPTION) - A-LIST] - BUCKET))) - -(CL:DEFUN \GET-FROM-FONTPROFILE (FONTPROFILE FONTCLASS DEVICE) - - (* ;; "Retunrs the DEVICE component of the FONTCLASS entry of FONTPROFILE.") - - [LET ((BUCKET (FASSOC FONTCLASS FONTPROFILE))) - (IF (NULL BUCKET) - THEN (ERROR "No such fontclass as " FONTCLASS) - ELSE - (* ;; "the bucket looks like") - - (* ;; "(fontclass prettyfont# displayfont pressfont interpressfont") - - (* ;; " (dev1 dev1-font) (dev2 dev2-font) ... )") - - (SELECTQ DEVICE - (DISPLAY (CL:THIRD BUCKET)) - (PRESS (CL:FOURTH BUCKET)) - (INTERPRESS (CL:FIFTH BUCKET)) - (DESTRUCTURING-BIND (CLASS-NAME PRETTY-FONT# DISPLAY-FONT PRESS-FONT - INTERPRESS-FONT . A-LIST) - BUCKET - (IF (NULL A-LIST) - THEN NIL - ELSE (CADR (FASSOC DEVICE A-LIST]) - - - -(* ;;; "initialization") - -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(\HQFX80.INIT) - -(\FASTFX80.INIT) -) - -(PUTPROPS FX-80DRIVER FILETYPE CL:COMPILE-FILE) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (4439 8728 (\FASTFX80.INIT 4449 . 8726)) (8811 10748 (OPENFASTFX80STREAM 8821 . 10746)) -(10750 11195 (\FASTFX80.PREAMBLE 10750 . 11195)) (11197 11950 (\FASTFX80.RESET-PRINTER 11197 . 11950)) - (11952 12475 (\FASTFX80.OUTPUT-SIGNATURE 11952 . 12475)) (12476 13108 (\FASTFX80.CLOSE 12486 . 13106) -) (13150 18112 (\FASTFX80.CHANGEFONT 13160 . 16384) (\FASTFX80.FONTCREATE 16386 . 17149) ( -\FASTFX80.CREATECHARSET 17151 . 18110)) (18114 18665 (\FASTFX80.INIT-FONT-PROFILE 18114 . 18665)) ( -18705 21838 (\FASTFX80.STRINGWIDTH 18715 . 20174) (\FASTFX80.CHARWIDTH 20176 . 20813) ( -\FASTFX80.SUBCHARWIDTH 20815 . 21836)) (21840 22336 (\FASTFX80.SPACEFACTOR 21840 . 22336)) (22419 -35008 (\FASTFX80.CLIPPINGREGION 22429 . 23365) (\FASTFX80.MOVETO 23367 . 23636) (\FASTFX80.XPOSITION -23638 . 25782) (\FASTFX80.YPOSITION 25784 . 28287) (\FASTFX80.BACKUP.PAPER 28289 . 29056) ( -\FASTFX80.ADVANCE.PAPER 29058 . 29922) (\FASTFX80.NEWPAGE 29924 . 30270) (\FASTFX80.OUTCHAR 30272 . -32626) (\FASTFX80.NEWLINE 32628 . 33684) (\FASTFX80.LINEFEED 33686 . 34723) (\FASTFX80.DRAWLINE 34725 - . 35006)) (35010 36021 (\FASTFX80.STARTPAGE 35010 . 36021)) (36023 37129 (\FASTFX80.SMART-XPOSITION -36023 . 37129)) (37131 37544 (\FASTFX80.TOPMARGIN 37131 . 37544)) (37546 37968 (\FASTFX80.BOTTOMMARGIN - 37546 . 37968)) (37970 38386 (\FASTFX80.LEFTMARGIN 37970 . 38386)) (38388 38807 ( -\FASTFX80.RIGHTMARGIN 38388 . 38807)) (38809 39023 (\FASTFX80.CUR-POS-VISIBLE? 38809 . 39023)) (39025 -39482 (\FASTFX80.HORIZONTAL 39025 . 39482)) (39514 40336 (\FASTFX80.SEND 39514 . 40336)) (40338 40550 -(MAKE-FASTFX80 40338 . 40550)) (40552 42254 (FASTFX80FILEP 40552 . 42254)) (42256 42452 ( -\FASTFX80.CANNOT-PRINT-BITMAPS 42256 . 42452)) (42453 42830 (\FASTFX80.CONVERT-TEDIT 42463 . 42828)) ( -42878 43180 (\FASTFX80.BOUT 42888 . 43178)) (43210 43637 (\FASTFX80.TRANSLATE-CHAR 43210 . 43637)) ( -43639 43876 (WITH-FASTFX80-DATA 43639 . 43876)) (50288 54402 (\HQFX80.INIT 50298 . 54400)) (54485 -59838 (OPENHQFX80STREAM 54495 . 59836)) (59840 60194 (\HQFX80.PREAMBLE 59840 . 60194)) (60196 60904 ( -\HQFX80.RESET-PRINTER 60196 . 60904)) (60906 61410 (\HQFX80.OUTPUT-SIGNATURE 60906 . 61410)) (61411 -62263 (\HQFX80.CLOSE 61421 . 62261)) (62305 80084 (\HQFX80.FONTCREATE 62315 . 63055) ( -\HQFX80.CHANGEFONT 63057 . 64497) (\HQFX80.CREATECHARSET 64499 . 73421) (\HQFX80.CHANGE-CHARSET 73423 - . 75946) (\HQFX80.READ-FONT-FILE 75948 . 77717) (\HQFX80.SEARCH-FONTS 77719 . 80082)) (80086 80631 ( -\HQFX80.INIT-FONT-PROFILE 80086 . 80631)) (80671 82631 (\HQFX80.CHARWIDTH 80681 . 81267) ( -\HQFX80.STRINGWIDTH 81269 . 82629)) (82633 83113 (\HQFX80.SPACEFACTOR 82633 . 83113)) (83196 91836 ( -\HQFX80.CLIPPINGREGION 83206 . 84428) (\HQFX80.LEFTMARGIN 84430 . 85195) (\HQFX80.RIGHTMARGIN 85197 . -85926) (\HQFX80.TOPMARGIN 85928 . 86492) (\HQFX80.BOTTOMMARGIN 86494 . 87070) (\HQFX80.XPOSITION 87072 - . 87541) (\HQFX80.YPOSITION 87543 . 88238) (\HQFX80.NEWLINE 88240 . 89657) (\HQFX80.NEWPAGE 89659 . -90088) (\HQFX80.LINEFEED 90090 . 90628) (\HQFX80.RESET 90630 . 90868) (\HQFX80.STARTPAGE 90870 . 91834 -)) (91838 92026 (\HQFX80.CUR-POS-VISIBLE? 91838 . 92026)) (92158 119893 (\HQFX80.BITBLT 92168 . 99412) - (\HQFX80.BLTSHADE 99414 . 104165) (\HQFX80.DRAWELLIPSE 104167 . 118408) (\HQFX80.OPERATION 118410 . -119307) (\HQFX80.DRAWPOINT 119309 . 119891)) (119894 137294 (\HQFX80.DRAWLINE 119904 . 123122) ( -\HQFX80.CLIP-AND-DRAW-LINE 123124 . 128335) (\HQFX80.CLIP-AND-DRAW-LINE1 128337 . 137292)) (137295 -146290 (\HQFX80.DRAWCIRCLE 137305 . 143923) (\HQFX80.CREATE-BRUSH-BBT 143925 . 146288)) (146292 146817 - (\HQFX80.DRAW-4-CIRCLE-POINTS 146292 . 146817)) (146818 156989 (\HQFX80.FILLCIRCLE 146828 . 156627) ( -\HQFX80.DRAWARC 156629 . 156987)) (156991 157556 (\HQFX80.FILL-CIRCLE-BLT 156991 . 157556)) (157588 -186500 (\HQFX80.DRAWCURVE 157598 . 159491) (\HQFX80.DRAWCURVE2 159493 . 171129) (\HQFX80.DRAWCURVE3 -171131 . 176773) (\HQFX80.LINEWITHBRUSH 176775 . 186498)) (186501 189958 (\HQFX80.BBTCURVEPT 186511 . -189956)) (191660 192811 (\HQFX80.SMOOTH-CURVE 191660 . 192811)) (192813 194697 ( -.SETUP.FOR.\HQFX80.BBTCURVEPT. 192813 . 194697)) (194742 198780 (\HQFX80.OUTCHAR 194752 . 196679) ( -\HQFX80.BLT-CHAR 196681 . 198778)) (198811 203326 (\HQFX80.DUMP-PAGE-BUFFER 198821 . 202982) ( -\HQFX80.ADVANCE-8-LINES 202984 . 203324)) (203328 204752 (\HQFX80.EIGHT-LINES-BLANK? 203328 . 204752)) - (204754 205508 (\HQFX80.BITMAP-LDB 204754 . 205508)) (205510 206000 (\HQFX80.CLEAR-SCANLINE 205510 . -206000)) (206002 206079 (\HQFX80.CLEAR-WORD-BOX 206002 . 206079)) (206081 206923 (\HQFX80.SEND 206081 - . 206923)) (206925 207128 (MAKE-HQFX80 206925 . 207128)) (207130 208512 (HQFX80FILEP 207130 . 208512) -) (208546 212145 (\HQFX80.BITMAP-FILE 208556 . 211776) (\HQFX80.CONVERT-TEDIT 211778 . 212143)) ( -212193 212492 (\HQFX80.BOUT 212203 . 212490)) (212544 216169 (\HQFX80.FIX-LINE-LENGTH 212554 . 213355) - (\HQFX80.FIX-FONT 213357 . 213673) (\HQFX80.FIX-Y 213675 . 216167)) (216171 216531 ( -\HQFX80.INVALIDATE-CACHE 216171 . 216531)) (216533 216776 (\HQFX80.INVALIDATE-FONT-CACHE 216533 . -216776)) (216778 216988 (\HQFX80.GET-CACHED-CHAR-WIDTH 216778 . 216988)) (216990 217132 ( -\HQFX80.GET-CHARACTER-OFFSET 216990 . 217132)) (217171 217722 (\HQFX80.GRAPHICS-MODE 217171 . 217722)) - (217723 220609 (\HQFX80.PRINTER-MODE 217733 . 220607)) (220611 220842 (WITH-HQFX80-DATA 220611 . -220842)) (222170 222530 (FX80-PRINT 222170 . 222530)) (222570 223191 (FX80-PRINT.BITMAP 222570 . -223191)) (223193 223490 (FX80-PRINT.PRINT-BITMAP 223193 . 223490)) (223492 224601 ( -FX80-PRINT.PRINT-BITMAP-PORTRAIT 223492 . 224601)) (224603 225722 (FX80-PRINT.PRINT-BITMAP-LANDSCAPE -224603 . 225722)) (225760 226002 (FX80-PRINT.FILE 225760 . 226002)) (226036 226472 (WITH-ABORT-WINDOW -226036 . 226472)) (226474 229154 (\FX80.CREATE-SEND-ABORT-WINDOW 226474 . 229154)) (229156 230619 ( -\ADD-TO-FONTPROFILE 229156 . 230619)) (230621 231679 (\GET-FROM-FONTPROFILE 230621 . 231679))))) -STOP diff --git a/obsolete/library/FX-80DRIVER.LCOM b/obsolete/library/FX-80DRIVER.LCOM deleted file mode 100644 index b364e953..00000000 Binary files a/obsolete/library/FX-80DRIVER.LCOM and /dev/null differ diff --git a/obsolete/library/FX-80Driver.tedit b/obsolete/library/FX-80Driver.tedit deleted file mode 100644 index 6479f012..00000000 --- a/obsolete/library/FX-80Driver.tedit +++ /dev/null @@ -1,40 +0,0 @@ -1 Lisp Library Modules, Medley Release 1.0, FX-80DRIVER 1 Lisp Library Modules, Medley Release 1.0, FX-80DRIVER FX-80DRIVER 1 FX-80DRIVER 1 FX-80DRIVER 6 FX-80Driver(FX-80DRIVER NIL FX-80Driver NIL NIL 99) prints text and graphics on Epson FX-80-compatible printers. It implements a full device-independent graphics interface(GRAPHICS% INTERFACE NIL graphics% interface NIL NIL 99) for the FX-80, and can print source code, TEdit documents, bitmaps and windows at a variety of qualities and speeds. The FX-80Driver contains two printer drivers(PRINTER% DRIVERS NIL printer% drivers NIL NIL 99): a fast driver, for quick printing of draft-quality text, and a high-quality driver, for slower printing of mixed-font text and graphics. You can print early revisions of a document in fast mode, and then switch to high-quality mode for the final copy. The matrix shown in Figure 1 illustrates the capabilities of each mode: ((SKETCH "figure from {DSK}FX-80DRIVERS.TEDIT;1" VERSION 3 PRIRANGE (31 . 0) SKETCHCONTEXT ((ROUND 1 BLACK) (GACHA 10 (MEDIUM REGULAR REGULAR)) (CENTER BASELINE) (CURVE 18.0 8) NIL NIL (CENTER CENTER) (NIL NIL NIL) T NIL NIL 1 NIL)) ((0.0 116.0 (PRI 1)) (WIRE ((96 . 184) (328 . 184)) (ROUND 1 BLACK) NIL NIL 1 NIL NIL)) ((0.0 116.0 (PRI 2)) (WIRE ((96 . 152) (328 . 152)) (ROUND 1 BLACK) NIL NIL 1 NIL NIL)) ((0.0 100.0 (PRI 3)) (WIRE ((176 . 248) (176 . 48)) (ROUND 1 BLACK) NIL NIL 1 NIL NIL)) ((0.0 100.0 (PRI 5)) (WIRE ((232 . 248) (232 . 48)) (ROUND 1 BLACK) NIL NIL 1 NIL NIL)) ((0.0 116.0 (PRI 7)) (WIRE ((96 . 120) (328 . 120)) (ROUND 1 BLACK) NIL NIL 1 NIL NIL)) ((0.0 116.0 (PRI 8)) (WIRE ((96 . 88) (328 . 88)) (ROUND 1 BLACK) NIL NIL 1 NIL NIL)) ((0.0 116.0 (PRI 9)) (WIRE ((96 . 216) (328 . 216)) (ROUND 1 BLACK) NIL NIL 1 NIL NIL)) ((0.05 13.0 (PRI 10)) (TEXT (200.0 . 232.0) ("Fast") 1 (CENTER BASELINE) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((190.5 228.5 19 13)) BLACK)) ((0.05 13.0 (PRI 11)) (TEXT (280.0 . 232.0) ("High-quality") 1 (CENTER BASELINE) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((251.0 228.5 58 13)) BLACK)) ((0.05 13.0 (PRI 12)) (TEXT (96.0 . 192.0) ("TEdit") 1 (LEFT BOTTOM) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((96 192 25 13)) BLACK)) ((0.05 13.0 (PRI 13)) (TEXT (96.0 . 160.0) ("Sketch") 1 (LEFT BOTTOM) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((96 160 31 13)) BLACK)) ((0.05 13.0 (PRI 14)) (TEXT (96.0 . 128.0) ("Windows") 1 (LEFT BOTTOM) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((96 128 43 13)) BLACK)) ((0.05 13.0 (PRI 15)) (TEXT (96.0 . 92.0) ("Lisp source" "code") 1 (LEFT BOTTOM) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((96 105 50 13) (96 92 22 13)) BLACK)) ((0.05 13.0 (PRI 16)) (TEXT (96.0 . 64.0) ("Grapher") 1 (LEFT BOTTOM) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((96 64 39 13)) BLACK)) ((0.05 13.0 (PRI 25)) (TEXT (202.0 . 200.0) ("monofont" "only") 1 (CENTER BASELINE) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((178.5 203.0 47 13) (192.0 190.0 20 13)) BLACK)) ((0.05 13.0 (PRI 26)) (TEXT (202.0 . 104.0) ("monofont" "only") 1 (CENTER BASELINE) (MODERN 10 (MEDIUM REGULAR REGULAR)) ((178.5 107.0 47 13) (192.0 94.0 20 13)) BLACK)) ((0.05 12.0 (PRI 27)) (TEXT (280.0 . 168.0) ("yes") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((269.5 165.0 21 12)) BLACK)) ((0.05 12.0 (PRI 28)) (TEXT (280.0 . 200.0) ("yes") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((269.5 197.0 21 12)) BLACK)) ((0.05 12.0 (PRI 29)) (TEXT (280.0 . 136.0) ("yes") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((269.5 133.0 21 12)) BLACK)) ((0.05 12.0 (PRI 30)) (TEXT (280.0 . 104.0) ("yes") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((269.5 101.0 21 12)) BLACK)) ((0.05 12.0 (PRI 31)) (TEXT (280.0 . 72.0) ("yes") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((269.5 69.0 21 12)) BLACK))) (93.0 45.0 238.0 206.0) 1.0 8 Figure 1. FX-80 printer drivers For historical reasons, FX-80 in this document refers to any and all of the Epson FX-80 family (FX-80% FAMILY% NIL FX-80% family% NIL NIL 99)of dot-matrix graphics printers. The module supports the FX-80, FX-85, FX-86 and FX-286. The Epson printers vary in speed and carriage width, but share a common command language. Requirements 1 RS232 or TTY cable (see the wiring diagrams in the Introduction of this manual). Serial interface card(SERIAL% INTERFACE% CARD NIL Serial% interface% card NIL NIL 99) in the printer. DLRS23C or DLTTY. Installation 1 FX-80 Serial Interface(FX-80% SERIAL% INTERFACE NIL FX-80% Serial% Interface NIL NIL 99) The FX-80Driver module requires that your Epson be equipped with a suitable serial interface (such as the Hanzon Universal Card(HANZON% UNIVERSAL% CARD NIL HANZON% Universal% Card NIL NIL 99)). The interface should be set up with XOn/XOff flow control enabled, 9600 baud or slower, 1 stop bit, 8 bit characters, no parity. (See The Hanzon Universal Card booklet for instructions on the DIP switch settings.) FX-80 DIP Switch Settings(FX-80% DIP% SWITCH% SETTINGS NIL FX-80% DIP% Switch% Settings NIL NIL 100) The FX-80 should have its DIP switches set as shown in Figure 2. ((SKETCH a% figure% from% a% document VERSION 3 PRIRANGE (62 . 0) SKETCHCONTEXT ((ROUND 1 BLACK) (GACHA 10 (MEDIUM REGULAR REGULAR)) (CENTER BASELINE) (CURVE 18.0 8) NIL NIL (CENTER CENTER) (NIL NIL NIL) T NIL NIL 1 NIL)) ((0.092 64.0 (PRI 61)) (GROUP (200.0 141.0 128.0 92.0) (((0.016 12.0 (PRI 29)) (BOX (248.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 30)) (BOX (200.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 31)) (BOX (216.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 32)) (BOX (232.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 33)) (BOX (232.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 34)) (BOX (216.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 35)) (BOX (248.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 36)) (BOX (200.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 38)) (BOX (312.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 39)) (BOX (264.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 40)) (BOX (280.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 41)) (BOX (296.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 42)) (BOX (296.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 43)) (BOX (280.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 44)) (BOX (312.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 45)) (BOX (264.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.05 12.0 (PRI 46)) (TEXT (208.0 . 144.0) ("1") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((204.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 47)) (TEXT (224.0 . 144.0) ("2") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((220.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 48)) (TEXT (240.0 . 144.0) ("3") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((236.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 49)) (TEXT (256.0 . 144.0) ("4") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((252.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 54)) (TEXT (272.0 . 144.0) ("5") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((268.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 55)) (TEXT (288.0 . 144.0) ("6") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((284.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 56)) (TEXT (304.0 . 144.0) ("7") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((300.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 57)) (TEXT (320.0 . 144.0) ("8") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((316.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 58)) (TEXT (264.0 . 224.0) ("Switch 1") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((236.0 221.0 56 12)) BLACK))) (264 . 184))) ((0.092 49.25 (PRI 62)) (GROUP (61.5 141.0 98.5 92.0) (((0.05 12.0 (PRI 11)) (TEXT (104.0 . 144.0) ("1") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((100.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 12)) (TEXT (120.0 . 144.0) ("2") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((116.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 13)) (TEXT (136.0 . 144.0) ("3") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((132.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 14)) (TEXT (152.0 . 144.0) ("4") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((148.5 141.0 7 12)) BLACK)) ((0.05 12.0 (PRI 17)) (TEXT (72.0 . 192.0) ("on") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((65.0 189.0 14 12)) BLACK)) ((0.05 12.0 (PRI 18)) (TEXT (72.0 . 168.0) ("off") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((61.5 165.0 21 12)) BLACK)) ((0.016 12.0 (PRI 23)) (BOX (144.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 23)) (BOX (96.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 23)) (BOX (112.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 23)) (BOX (128.0 184.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.016 12.0 (PRI 24)) (BOX (144.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 24)) (BOX (128.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 24)) (BOX (112.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (43605 NIL NIL))) ((0.016 12.0 (PRI 24)) (BOX (96.0 160.0 16.0 24.0) (ROUND 1 BLACK) NIL 1 (NIL NIL NIL))) ((0.05 12.0 (PRI 37)) (TEXT (128.0 . 224.0) ("Switch 2") 1 (CENTER BASELINE) (GACHA 10 (MEDIUM REGULAR REGULAR)) ((100.0 221.0 56 12)) BLACK))) (112 . 184)))) (61.0 141.0 267.0 92.0) 1.0 8 Figure 2. FX-80 DIP switch settings Switch 1 says no automatic linefeed, no automatic paper feed, no buzz on paper-out, and to allow no software deactivation of the printer. Switch 2 says to use the USA character set, Pica type, allocate 2KB for user-defined characters, allow paper-out detection, and print zeros as zeros. Note: For the FX-85, -86 and -286 DIP switch settings, consult the corresponding Epson User's Manual. Software Load FX-80DRIVER.LCOM and the required .LCOM modules from the library. Store all of the font files (file names ending with .displayfont) corresponding to the fonts you wish to use on some convenient directory or directories. HQFX80-FONT-DIRECTORIES(HQFX80-FONT-DIRECTORIES (variable) NIL NIL NIL 100) should be a list that contains these directories; it should be the same as DISPLAYFONTDIRECTORIES(DISPLAYFONTDIRECTORIES (variable) NIL NIL NIL 100). Set FASTFX80-DEFAULT-DESTINATION(FASTFX80-DEFAULT-DESTINATION (variable) NIL NIL NIL 100) (determines where output to the FASTFX80 lineprinter device goes) and HQFX80-DEFAULT-DESTINATION(HQFX80-DEFAULT-DESTINATION (variable) NIL NIL NIL 100) (determines where output to the HQFX80 lineprinter device goes) to one of the following values; they need not be the same: Destination RS232 port TTY port file 1 Value {RS232} {TTY} FileName Speed 9600 max. 4800 max. n/a 1 Load the appropriate device driver for each of these destinations: DLTTY.LCOM for the TTY port, and DLRS232C.LCOM for the RS232C port. Run the function RS232C.INIT or TTY.INIT (as appropriate), and set the baud rate to match the setting on the printer. User Interface 1 You can set up the FX-80 to be your default printer, send FX-80 output to a file for later printing, or programmatically open an image stream that produces output on the FX-80. Having the FX-80 set up as your default printer means that you can print the contents of windows by selecting the HARDCOPY menu item on the window of interest. You can also use the HARDCOPY - TO A FILE submenu item to spool your output for later printing. And you can write programs that use the OPENIMAGESTREAM(OPENIMAGESTREAM (function) NIL NIL NIL 101) function to create FX-80 format graphics output. Printing in Fast Mode(PRINTING% IN% FAST% MODE NIL Printing% in% Fast% Mode NIL NIL 101) 1 You can print in fast mode by sending output to the printer FASTFX80 or by opening an image stream to a file with extension FASTFX80. This mode is called fast because it uses the printer's built-in font, which allows a tight encoding of the document to be printed. Fidelity to the original document is not as good as in high-quality mode. The following restrictions apply: ÿÿïf ÿSpecial characters (that is, most Xerox Network Systems extended characters, such as the bullet or dagger; see CharCodeTables, VirtualKeyboards in this manual) are ignored. ÿÿïf ÿOnly one font is supported (though roman, italic, and bold typefaces do work). ÿÿïf ÿGraphics (lines, underlines, bitmaps) are ignored. ÿÿïf ÿMultiple column output does work. Set FX-80 Fast Mode(ET% FX-80% FAST% MODE NIL et% FX-80% Fast% Mode NIL NIL 101) To set your default printer to be a fast mode FX-80(FAST% MODE% FX-80 NIL fast% mode% FX-80 NIL NIL 101), make the list (FASTFX80 FASTFX80) the CAR of the list DEFAULTPRINTINGHOST. Set FX-80 Destination(SET% FX-80% DESTINATION NIL Set% FX-80% Destination NIL NIL 101) To set the default destination of all output to {LPT}.fastfx80, set the variable FASTFX80-DEFAULT-DESTINATION to an appropriate file name string. See the table above; the file name could be that of a regular file like {DSK}SPOOLED-FAST-OUTPUT. Set FX-80 Page Size(SET% FX-80% PAGE% SIZE NIL Set% FX-80% Page% Size NIL NIL 101) To set the driver's page size to match the paper in the printer, set the two variables \FASTFX80.INCHES-PER-PAGE (page height in inches) and \FASTFX80.INCHES-PER-LINE (page width in inches) to appropriate values. The defaults are 11 and 8.5, respectively. These can be set in your Lisp INIT file. Print a File(PRINT% A% FILE NIL Print% a% File NIL NIL 101) Select the HARDCOPY command from the background (right-button) menu. The system first formats the file for printing. Then, when the FX-80Driver actually starts transmitting to the printer, a small abort window, bearing the name of the document and the name of the printer, will appear near the top of your screen. Abort a Print Job(ABORT% A% PRINT% JOB NIL Abort% a% Print% Job NIL NIL 101) Clicking on the item marked ABORT in the print window will cleanly terminate the printing of the document. Note: After aborting a print job, you may need to turn the printer off and back on to make sure that other files will print successfully. Printing in High-Quality Mode(PRINTING% IN% HIGH-QUALITY% MODE NIL Printing% in% High-Quality% Mode NIL NIL 102) 1 Print in high-quality mode by sending output to the printer HQFX80, or by opening an image stream on a file with type HQFX80. High-quality mode printing supports all of Xerox Lisp's device-independent graphics operations, as well as multiple font printing and the XNS extended character set. It prints at 72 dot-per-inch resolution. Fidelity to the original document is better than in fast mode, though printing speed is slower. Set HQ Mode(SET% HQ% MODE NIL Set% HQ% Mode NIL NIL 102) To set your default printer to be a high-quality FX-80, make the list (HQFX80 HQFX80) the CAR of the list DEFAULTPRINTINGHOST. You can use the PRINTERMENU module or your favorite structure editor to do this. Set Destination(SET% DESTINATION NIL Set% Destination NIL NIL 102) To set the default destination of all output to {LPT}.hqfx80, set the variable HQFX80-DEFAULT-DESTINATION to an appropriate file namestring. This could be "{TTY}", "{RS232}", or even the name of a regular file like "{DSK}spooled-hq-output". Set Page Size(SET% PAGE% SIZE NIL Set% Page% Size NIL NIL 102) To set the driver's page size to match the paper in the printer, set the two variables \HQFX80.INCHES-PER-PAGE (page height in inches) and \HQFX80.INCHES-PER-LINE (page width in inches) to appropriate values. The defaults are 11 and 8.5, respectively. These can be set in your Lisp INIT file. Print a File(PRINT% A% FILE NIL Print% a% File NIL NIL 102) Select the HARDCOPY command. The system first formats the file for printing. Then, when the FX-80Driver actually starts transmitting to the printer, a small abort window, bearing the name of the document and the name of the printer, will appear near the top of your screen. Note: After printing a document on HQFX80, you may need to turn the printer off and back on before you can print with FASTFX80 on that printer. Abort a Print Job(ABORT% A% PRINT% JOB NIL Abort% a% Print% Job NIL NIL 102) See above. FX Printer Compatibility(FX% PRINTER% COMPATIBILITY NIL FX% Printer% Compatibility NIL NIL 102) 1 (FX80-PRINT(FX80-PRINT (function) NIL NIL NIL 102) &KEY THING-TO-PRINT LANDSCAPE? COMPRESS? HIGH-QUALITY?) [Function] THING-TO-PRINT may be one of a window, bitmap, or file path name. If THING-TO-PRINT is a path name, the file will be treated as either a TEdit or Lisp source file, and printed in the appropriate style. In the window or bitmap cases, LANDSCAPE? specifies landscape printing (X-coordinates run down the left margin) when non-NIL; COMPRESS? specifies FX-80 compressed printing mode. If HIGH-QUALITY? is non-NIL and THING-TO-PRINT is a path name, output will be sent to the default high-quality FX-80 printer, otherwise to the default fast FX-80 printer. The LANDSCAPE?, COMPRESS?, and HIGH-QUALITY? arguments all default to NIL. Limitations 1 Landscape printing(LANDSCAPE% PRINTING NIL Landscape% printing NIL NIL 103) has not been implemented. Examples 1 Send text output to fast FX-80:(SEND% TEXT% OUTPUT% TO% FAST% FX-80 NIL Send% text% output% to% fast% FX-80 NIL NIL 103) (SETQ FX-80 (OPENIMAGESTREAM "{LPT}.FASTFX80")) (CL:FORMAT FX-80 "HELLO, WORLD~%%") (CL:CLOSE FX-80) Print source code on fast FX-80(PRINT% SOURCE% CODE% ON% FAST% FX-80 NIL Print% source% code% on% fast% FX-80 NIL NIL 103) (assuming the FastFX80 is not your default printer, but is on the list DEFAULTPRINTINGHOST): (LISTFILES (HOST FASTFX80) "{DSK}MYPROGRAM") Note: Source code is stored in pre-pretty-printed form on the file. The pretty-printer's default linelength (width of a line in characters) is normally 102, which is too wide for the FastFX-80s 8.5-inch wide page. To create source files which print nicely on the fast FX-80, you should set the variable FILELINELENGTH to a more appropriate value before you MAKEFILE. 70 works nicely on 8.5-inch paper with a standard font profile, though your mileage may vary. Print source code in the the fast FX-80 mode, assuming the FastFX80 is your default printer: (LISTFILES "{DSK}MYPROGRAM") Print TEdit file in fast FX-80 mode(PRINT% TEDIT% FILE% IN% FAST% FX-80% MODE NIL Print% TEdit% file% in% fast% FX-80% mode NIL NIL 103), assuming the FastFX80 is your default printer: (LISTFILES "{WAYCOOL:}GENSYM.TEDIT") Print text and graphics in high-quality mode:(PRINT% TEXT% AND% GRAPHICS% IN% % HIGH-QUALITY% MODE NIL Print% text% and% graphics% in% % high-quality% mode NIL NIL 103) (SETQ FX-80 (OPENIMAGESTREAM "{LPT}" 'HQFX80)) (MOVETO 300 300 FX-80) (CL:FORMAT FX-80 "HELLO, WORLD~%%") (DRAWCIRCLE 300 300 230 '(ROUND 8) NIL FX-80) (CL:CLOSE FX-80) Print source code in high-quality mode,(PRINT% SOURCE% CODE% IN% HIGH-QUALITY% MODE NIL Print% source% code% in% high-quality% mode NIL NIL 103) assuming the high-quality FX-80 is not your default printer, but is on the list DEFAULTPRINTINGHOST: (LISTFILES (HOST HQFX80) "{DSK}MYPROGRAM") Note: See the previous note regarding FILELINELENGTH and the fast FX-80. The same holds for high-quality FX-80 printing, and we recommend 70 as the value for FILELINELENGTH. Print source code in high-quality mode, assuming the high-quality FX-80 is your default printer: (LISTFILES "{DSK}MYPROGRAM") Print TEdit file in high-quality mode,(PRINT% % TEDIT% FILE% IN% HIGH-QUALITY% MODE NIL Print% % TEdit% file% in% high-quality% mode NIL NIL 104) assuming the high-quality FX-80 is your default printer: (LISTFILES "{WAYGNARLY:}MAGNUMOPUS.TEDIT") [This page intentionally left blank] (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 99) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD RIGHT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY HELVETICA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (270 15 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (TEXT NIL NIL (54 54 504 702) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD LEFT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY HELVETICA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (54 15 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGV) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE VERSOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD RIGHT) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY HELVETICA OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (270 15 288 36) NIL) (HEADING NIL (HEADINGTYPE FOOTINGR) (54 27 558 36) NIL) (HEADING NIL (HEADINGTYPE RECTOHEAD) (54 762 558 36) NIL) (TEXT NIL NIL (54 54 504 684) NIL))))) <``¼Ì8¤àT<``àÀ €àT,HHà 5Hlàlà2llàà2H`à -à2HHà -à,llà,llà-llàT2Hlà -l,HHà --àT2HTàT2Hlàl-$$àT-àT,HHà -2HHà È,HHà,HHà,HHà -3àÈT3ààT<lløÌ8¤øT-T-øäìT2ÌÌø ÈFøø PAGEHEADING VERSOHEADFøø PAGEHEADING RECTOHEADEøø PAGEHEADINGFOOTINGVEøø PAGEHEADINGFOOTINGR HELVETICA -CLASSIC -CLASSIC -CLASSICCLASSIC -TITAN - HELVETICA  HELVETICACLASSIC - HELVETICAMODERN -MODERN -MODERNMODERN TERMINAL -MODERN -MODERNMODERN -  HRULE.GETFNMODERN -  7 HRULE.GETFNMODERN - 7  HRULE.GETFNMODERN -   HRULE.GETFNMODERN -  - HRULE.GETFNMODERN (IM.INDEX.GETFNy 8IM.INDEX.GETFNv , 2IM.INDEX.GETFNH  0 SKIO.GETFN.2MODERN - "` 0IM.INDEX.GETFNµ     HRULE.GETFNMODERN Q  @IM.INDEX.GETFN     HRULE.GETFNMODERN BIM.INDEX.GETFN @IM.INDEX.GETFN „  7 KIM.INDEX.GETFNB \ SKIO.GETFN.2MODERN - (Š – Q     š 4IM.INDEX.GETFNCLASSIC -M 3IM.INDEX.GETFNCLASSIC -  9IM.INDEX.GETFNCLASSIC -G 7IM.INDEX.GETFNCLASSIC -|  % HRULE.GETFNMODERN    HRULE.GETFNMODERN C -    M   HRULE.GETFNMODERN ³ * ,IM.INDEX.GETFNCLASSIC -1 CIM.INDEX.GETFN  HRULE.GETFNMODERN U "  ¯  Q  5  $ =IM.INDEX.GETFN3 5IM.INDEX.GETFN(   AIM.INDEX.GETFNR o  ?IM.INDEX.GETFNX  A  /   /IM.INDEX.GETFN + ;IM.INDEX.GETFN J ‰ SIM.INDEX.GETFN  HRULE.GETFNMODERN ¯   -IM.INDEX.GETFNZ  T 3IM.INDEX.GETFNO 3  *   1IM.INDEX.GETFNX  z   /IM.INDEX.GETFN   ;IM.INDEX.GETFN GIM.INDEX.GETFN  HRULE.GETFNMODERN  'IM.INDEX.GETFNMODERN - 7 8 x  -P   +    }  -       HRULE.GETFNMODERN   9IM.INDEX.GETFN    HRULE.GETFNMODERN   YIM.INDEX.GETFN 0 $   [IM.INDEX.GETFNH  - 1 ( a ]  -# eIM.INDEX.GETFN1  --. {IM.INDEX.GETFN  -/  $ . ' iIM.INDEX.GETFNQ   -+ & k  a  -' kIM.INDEX.GETFN:  -3$   QNÆzº \ No newline at end of file diff --git a/obsolete/library/IPFONTSAMPLE b/obsolete/library/IPFONTSAMPLE deleted file mode 100644 index 24b19802..00000000 --- a/obsolete/library/IPFONTSAMPLE +++ /dev/null @@ -1,391 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "11-Jun-90 15:51:10" {DSK}local>lde>lispcore>library>FONTSAMPLE.;2 16609 - - changes to%: (VARS FONTSAMPLECOMS) - - previous date%: "10-Jan-87 15:47:00" {DSK}local>lde>lispcore>library>FONTSAMPLE.;1) - - -(* ; " -Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT FONTSAMPLECOMS) - -(RPAQQ FONTSAMPLECOMS ((MACROS IDIVUP) - (VARS FNT.PANEL FNT.FNAME FNT.INFOFONT FNT.OUTFTEXT) - (FNS FNT.MAKEBOOK FNT.LESSP FNT.SORTP FNT.DISPLOOK FNT.DISPTBLE - FNT.DISPDSCR FNT.NARRDSCR FNT.DISPINIT FNT.FACEMAP FNT.SIZEMAP - FNT.MAKENAME FNT.MAKEWIND FNT.FILEMAP FNT.FINDALL FNT.FLST))) -(DECLARE%: EVAL@COMPILE - -(PUTPROPS IDIVUP DMACRO ((INUMEXPR IDENEXPR) - (LET (INUM IDEN) - (SETQ INUM INUMEXPR) - (SETQ IDEN IDENEXPR) - (IQUOTIENT (IPLUS INUM IDEN -1) - IDEN)))) -) - -(RPAQQ FNT.PANEL - ([PROG (SETQ FNT.WIND (FNT.MAKEWIND)) - (SETQ FNT.FONTLIST '(GACHA 10 (MEDIUM REGULAR REGULAR) - 0 INTERPRESS] - (PROG (CLEARW FNT.WIND) - (FNT.DISPTBLE FNT.WIND FNT.FONTLIST)) - (PROG (SETQ FNT.FILENAME (FNT.MAKENAME FNT.FONTLIST)) - (SETQ FNT.STRM (OPENIMAGESTREAM FNT.FILENAME 'INTERPRESS)) - (TOTOPW FNT.WIND) - (BITBLT FNT.WIND 0 0 FNT.STRM 0 0 612 792 'INPUT 'REPLACE) - (CLOSEF FNT.STRM)))) - -(RPAQQ FNT.FNAME {DSK}FONTBOOK.IP) - -(RPAQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR) - 0)) - -(RPAQQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL") -(DEFINEQ - -(FNT.MAKEBOOK - [LAMBDA (OUTFROOTNAME ListOfFonts PRNTFN PERPAGE) (* FS "30-Jun-86 11:45") - - (* * takes a file name and font specification and iteratively invokes a given - print function (fnt.dispfont by default) on each font in the sorted list) - - (LET (FONTLIST OUTFTYPE OUTFDSCR OUTFOPTS ITER THISPAGE OUTFNAME) - - (* * Handle input parm defaults * *) - - (if (EQ PRNTFN NIL) - then (SETQQ PRNTFN FNT.DISPLOOK)) - (if (EQ PERPAGE NIL) - then (SETQ PERPAGE (SELECTQ PRNTFN - (FNT.DISPTBLE 1) - (FNT.DISPLOOK 18) - 1))) - (SETQQ OUTFTYPE INTERPRESS) - (SETQQ OUTFOPTS (REGION (2794 1905 25400 24765))) - (if (EQUAL ListOfFonts 'ALL) - then (SETQ FONTLIST (FNT.FINDALL OUTFTYPE)) - else (SETQ FONTLIST ListOfFonts)) - - (* * Iterate over files increment file names, iterate over fonts * *) - - (SETQ ITER 0) - (for PAGENO from 1 to (IDIVUP (LENGTH FONTLIST) - PERPAGE) - do (SETQ OUTFNAME (FNT.FILEMAP OUTFROOTNAME PAGENO)) - (if OUTFNAME - then (SETQ OUTFDSCR (OPENIMAGESTREAM OUTFNAME OUTFTYPE OUTFOPTS))) - (SETQ THISPAGE (IMIN PERPAGE (IDIFFERENCE (LENGTH FONTLIST) - ITER))) - [for I from 1 to THISPAGE do (SETQ ITER (ADD1 ITER)) - (APPLY* PRNTFN OUTFDSCR (CAR (NTH FONTLIST ITER] - (CLOSEF OUTFDSCR) - (BLOCK]) - -(FNT.LESSP - [LAMBDA (DSC1 DSC2) (* FS " 5-Jul-86 23:11") - - (* * Impose alpha order on font list) - - (PROG NIL - (if (NOT (LISTP DSC1)) - then (RETURN (ALPHORDER DSC1 DSC2))) - - (* * Switch face & size for order * *) - - [SETQ DSC1 (LIST (CAR DSC1) - (CADDR DSC1) - (CADR DSC1) - (CADDDR DSC1) - (CAR (CDDDR DSC1] - [SETQ DSC2 (LIST (CAR DSC2) - (CADDR DSC2) - (CADR DSC2) - (CADDDR DSC2) - (CAR (CDDDR DSC2] - (RETURN (FNT.SORTP DSC1 DSC2]) - -(FNT.SORTP - [LAMBDA (DSC1 DSC2) (* FS " 5-Jul-86 23:15") - - (* * Impose alpha order on font list) - - (PROG (KEY1 KEY2) - (if (NOT (LISTP DSC1)) - then (RETURN (ALPHORDER DSC1 DSC2))) - (SETQ KEY1 (CAR DSC1)) - (SETQ KEY2 (CAR DSC2)) - - (* * Reverse order of face * *) - - [if (EQUAL KEY1 KEY2) - then (RETURN (FNT.SORTP (CDR DSC1) - (CDR DSC2] - [if (LISTP KEY1) - then (RETURN (NOT (FNT.SORTP KEY1 KEY2] - (if (NUMBERP KEY1) - then (RETURN (LESSP KEY1 KEY2))) - (RETURN (ALPHORDER KEY1 KEY2]) - -(FNT.DISPLOOK - [LAMBDA (FILEDSC FONTDSC) (* FS "24-Jan-86 18:19") - - (* * uses "private" global vars fnt.infofont and fnt.outftext to generate - sample string) - - (LET NIL (DSPFONT FNT.INFOFONT FILEDSC) - (TERPRI FILEDSC) - (TERPRI FILEDSC) - (TERPRI FILEDSC) - (TERPRI FILEDSC) - (FNT.NARRDSCR FILEDSC (LIST FONTDSC)) - (DSPFONT FONTDSC FILEDSC) - (printout FILEDSC FNT.OUTFTEXT]) - -(FNT.DISPTBLE - [LAMBDA (Stream FONTDSC) (* FS "17-Mar-86 17:37") - - (* * generates a font table using prin1) - - (LET* ((TitleFont (FONTCREATE FNT.INFOFONT)) - (FontList (LIST FONTDSC)) - (InchesToPrinterUnits (FTIMES 72.0 (DSPSCALE NIL Stream))) - (DDev (IMAGESTREAMTYPE Stream))) - (for Font in FontList - do (DSPRIGHTMARGIN (TIMES 100.0 InchesToPrinterUnits) - Stream) (* Let clip on right *) - (MOVETO (FTIMES 0.75 InchesToPrinterUnits) - (FTIMES 10.0 InchesToPrinterUnits) - Stream) - (DSPFONT TitleFont Stream) - (FNT.NARRDSCR Stream FontList) - (DSPFONT FONTDSC Stream) - (printout Stream FNT.OUTFTEXT) - (DSPFONT Font Stream) - (for YPosition from (TIMES 9 InchesToPrinterUnits) to (TIMES 1.5 InchesToPrinterUnits - ) - by (TIMES -0.5 InchesToPrinterUnits) bind (CharacterCode _ 0) - do (for XPosition from (TIMES 0.75 InchesToPrinterUnits) - to (TIMES 7.5 InchesToPrinterUnits) by (TIMES 0.45 InchesToPrinterUnits) - do (MOVETO XPosition YPosition Stream) - (if (NEQ CharacterCode (CHARCODE FF)) - then (if (EQ DDev 'DISPLAY) - then (BLTCHAR CharacterCode Stream) - else (PRIN1 (CHARACTER CharacterCode) - Stream))) - (SETQ CharacterCode (ADD1 CharacterCode))) - (printout T ".")) - (printout T " done." T]) - -(FNT.DISPDSCR - [LAMBDA (OUTF FONTLIST) (* FS " 2-Jul-85 13:00") - - (* * Prints a list of fontlists with facelist formatting appropriate for 8 pt. - terminal) - - (PROG (NAME SIZE JUNK NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 T6 T7) - (if (EQ FONTLIST NIL) - then (RETURN NIL)) - (SETQ TEMP (DSPSCALE NIL OUTF)) - (SETQ UNITS (TIMES 4.25 TEMP)) - (SETQ OFFX (TIMES 42.5 TEMP)) - (SETQ T0 (PLUS OFFX (TIMES 0 UNITS))) - (SETQ T1 (PLUS OFFX (TIMES 14 UNITS))) - (SETQ T2 (PLUS OFFX (TIMES 20 UNITS))) - (SETQ T3 (PLUS OFFX (TIMES 30 UNITS))) - (SETQ T4 (PLUS OFFX (TIMES 40 UNITS))) - (SETQ T5 (PLUS OFFX (TIMES 50 UNITS))) - (SETQ T6 (PLUS OFFX (TIMES 55 UNITS))) - (SETQ T7 (PLUS OFFX (TIMES 70 UNITS))) - [MAPC FONTLIST '(LAMBDA (DESCR) - (SETQ NAME (CAR DESCR)) - (SETQ SIZE (CADR DESCR)) - (SETQ JUNK (CADDR DESCR)) - (SETQ TEMP (CDDDR DESCR)) - (SETQ NUMB (CAR TEMP)) - (SETQ STRM (CADR TEMP)) - (DSPXPOSITION T0 OUTF) - (printout OUTF NAME) - (DSPXPOSITION T1 OUTF) - (printout OUTF |.I3| SIZE) - (DSPXPOSITION T2 OUTF) - (printout OUTF "(" (CAR JUNK)) - (DSPXPOSITION T3 OUTF) - (printout OUTF (CADR JUNK)) - (DSPXPOSITION T4 OUTF) - (printout OUTF (CADDR JUNK) - ")") - (DSPXPOSITION T5 OUTF) - (printout OUTF NUMB) - (DSPXPOSITION T6 OUTF) - (printout OUTF STRM) - (DSPXPOSITION T7 OUTF] - (RETURN NIL]) - -(FNT.NARRDSCR - [LAMBDA (OUTF FONTLIST) (* ; "Edited 9-Jan-87 18:57 by FS") - - (* * Prints a list of fontlists with narrow formatting appropriate for 8 pt. - terminal) - - (PROG (NAME SIZE FACE NUMB STRM TEMP OFFX UNITS T0 T1 T2 T3 T4 T5 DESCR) - (if (EQ FONTLIST NIL) - then (RETURN NIL)) - (if (TYPENAMEP FONTLIST 'FONTDESCRIPTOR) - then (SETQ FONTLIST (FNT.FLST FONTLIST))) - (SETQ TEMP (DSPSCALE NIL OUTF)) - (SETQ UNITS (TIMES 4.25 TEMP)) - (SETQ OFFX (TIMES 42.5 TEMP)) - (SETQ T0 (PLUS OFFX (TIMES 0 UNITS))) - (SETQ T1 (PLUS OFFX (TIMES 14 UNITS))) - (SETQ T2 (PLUS OFFX (TIMES 20 UNITS))) - (SETQ T3 (PLUS OFFX (TIMES 28 UNITS))) - (SETQ T4 (PLUS OFFX (TIMES 33 UNITS))) - (SETQ T5 (PLUS OFFX (TIMES 48 UNITS))) - - (* * (MAPC FONTLIST (QUOTE (LAMBDA (DESCR) - (SETQ NAME (CAR DESCR)) (SETQ SIZE (CADR DESCR)) - (SETQ FACE (FNT.FACEMAP (CADDR DESCR))) (SETQ TEMP - (CDDDR DESCR)) (SETQ NUMB (CAR TEMP)) (SETQ STRM - (CADR TEMP)) (DSPXPOSITION T0 OUTF) (printout OUTF NAME) - (DSPXPOSITION T1 OUTF) (printout OUTF |.I3| SIZE) - (DSPXPOSITION T2 OUTF) (printout OUTF FACE) - (DSPXPOSITION T3 OUTF) (printout OUTF NUMB) - (DSPXPOSITION T4 OUTF) (printout OUTF STRM) - (DSPXPOSITION T5 OUTF))))) - - (for I in FONTLIST do (if (type? FONTDESCRIPTOR I) - then (SETQ DESCR (FNT.FLST I)) - else (SETQ DESCR I)) - (SETQ NAME (CAR DESCR)) - (SETQ SIZE (CADR DESCR)) - (SETQ FACE (FNT.FACEMAP (CADDR DESCR))) - (SETQ TEMP (CDDDR DESCR)) - (SETQ NUMB (CAR TEMP)) - (SETQ STRM (CADR TEMP)) - (DSPXPOSITION T0 OUTF) - (printout OUTF NAME) - (DSPXPOSITION T1 OUTF) - (printout OUTF |.I3| SIZE) - (DSPXPOSITION T2 OUTF) - (printout OUTF FACE) - (DSPXPOSITION T3 OUTF) - (printout OUTF NUMB) - (DSPXPOSITION T4 OUTF) - (printout OUTF STRM) - (DSPXPOSITION T5 OUTF)) - (RETURN NIL]) - -(FNT.DISPINIT - [LAMBDA (FILEDSC) (* FS " 2-Jul-85 14:14") - - (* * initialization or optimization for fnt.dispfont) - - (PROG (vars...) - (SETQ FNT.OUTFTEXT "abcdefghijkl ABCDEFGHIJKL") - (SETQQ FNT.INFOFONT (TERMINAL 8 (MEDIUM REGULAR REGULAR) - 0 INTERPRESS)) - (RETURN NIL]) - -(FNT.FACEMAP - [LAMBDA (OLDFACE) (* FS " 5-Sep-85 19:04") - - (* * make short face from facelist) - - (SETQ OLDFACE (\FONTFACE OLDFACE)) (* make list form *) - (CONCAT (GNC (MKSTRING (CAR OLDFACE))) - (GNC (MKSTRING (CADR OLDFACE))) - (GNC (MKSTRING (CADDR OLDFACE]) - -(FNT.SIZEMAP - [LAMBDA (SIZE) (* FS " 2-Jul-85 14:13") - - (* * make size into two character string) - - (PROG (STR) - (if (ILESSP SIZE 10) - then (RETURN (CONCAT "0" (MKSTRING SIZE))) - else (RETURN (MKSTRING SIZE]) - -(FNT.MAKENAME - [LAMBDA (FONTLIST) (* FS " 3-Sep-85 16:07") - - (* * make a unique interpress file name given a fontlist) - - (PROG (STR TYPE SIZE FACE DDEV) - (SETQ TYPE (MKSTRING (CAR FONTLIST))) - (SETQ SIZE (FNT.SIZEMAP (CADR FONTLIST))) - [SETQ FACE (MKSTRING (FNT.FACEMAP (CADDR FONTLIST] - (SETQ DDEV (CAR (CDDDDR FONTLIST))) - (SETQ STR (CONCAT (MKSTRING TYPE) - (MKSTRING SIZE) - (MKSTRING FACE) - (GNC (MKSTRING DDEV)) - ".IP")) - (RETURN STR]) - -(FNT.MAKEWIND - [LAMBDA NIL (* FS "21-Mar-86 18:07") - - (* * MAKE A WINDOW) - - (PROG (PPI) - (SETQ PPI (TIMES 72 (DSPSCALE NIL T))) - [SETQ FNT.WINDOW (CREATEW (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (FIX (TIMES 8.5 PPI)) - HEIGHT _ (TIMES 11 PPI] - (RETURN FNT.WINDOW]) - -(FNT.FILEMAP - [LAMBDA (OUTFNAME NUMBER) (* FS " 5-Sep-85 16:56") - - (* * Takes a file name and returns an Interpress file name with number at end * - *) - - (PROG (FNAME ROOTNAME DESTNAME) - (if (OR (EQ OUTFNAME T) - (EQ OUTFNAME NIL)) - then (RETURN OUTFNAME)) - (SETQ FNAME OUTFNAME) - (SETQ ROOTNAME (FILENAMEFIELD FNAME 'NAME)) - (SETQ ROOTNAME (MKATOM (CONCAT ROOTNAME NUMBER))) - (SETQ DESTNAME (PACKFILENAME 'NAME ROOTNAME 'BODY FNAME)) - (RETURN DESTNAME]) - -(FNT.FINDALL - [LAMBDA (DEVICE) (* FS " 5-Sep-85 19:18") - - (* * Returns list of all fonts for device * *) - - (LET (RESULT) - (SETQ RESULT (FONTSAVAILABLE '* '* ' - - (* * *) - '* DEVICE T)) - (SETQ RESULT (SORT RESULT 'FNT.LESSP]) - -(FNT.FLST - [LAMBDA (FONTOBJ) (* ; "Edited 9-Jan-87 18:56 by FS") - (COND - [(TYPENAMEP FONTOBJ 'FONTDESCRIPTOR) - (LIST (FONTPROP FONTOBJ 'FAMILY) - (FONTPROP FONTOBJ 'SIZE) - (FONTPROP FONTOBJ 'FACE) - (FONTPROP FONTOBJ 'ROTATION) - (FONTPROP FONTOBJ 'DEVICE] - ((LISTP FONTOBJ) - FONTOBJ]) -) -(PUTPROPS FONTSAMPLE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1964 16504 (FNT.MAKEBOOK 1974 . 3779) (FNT.LESSP 3781 . 4575) (FNT.SORTP 4577 . 5343) ( -FNT.DISPLOOK 5345 . 5862) (FNT.DISPTBLE 5864 . 7867) (FNT.DISPDSCR 7869 . 9976) (FNT.NARRDSCR 9978 . -12722) (FNT.DISPINIT 12724 . 13136) (FNT.FACEMAP 13138 . 13525) (FNT.SIZEMAP 13527 . 13863) ( -FNT.MAKENAME 13865 . 14549) (FNT.MAKEWIND 14551 . 15105) (FNT.FILEMAP 15107 . 15737) (FNT.FINDALL -15739 . 16082) (FNT.FLST 16084 . 16502))))) -STOP diff --git a/obsolete/library/IPFONTSAMPLE.LCOM b/obsolete/library/IPFONTSAMPLE.LCOM deleted file mode 100644 index 2301a55a..00000000 Binary files a/obsolete/library/IPFONTSAMPLE.LCOM and /dev/null differ diff --git a/obsolete/library/IPFONTSAMPLE.TEDIT b/obsolete/library/IPFONTSAMPLE.TEDIT deleted file mode 100644 index 12d3aa87..00000000 Binary files a/obsolete/library/IPFONTSAMPLE.TEDIT and /dev/null differ diff --git a/obsolete/library/PRESS b/obsolete/library/PRESS deleted file mode 100644 index 1dc8916c..00000000 --- a/obsolete/library/PRESS +++ /dev/null @@ -1,2786 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - -(FILECREATED "14-Jul-2025 22:58:49" {WMEDLEY}PRESS.;4 453237Q - - :EDIT-BY rmk - - :CHANGES-TO (FNS \DSPFONT.PRESS) - - :PREVIOUS-DATE " 5-Jul-2025 18:52:40" {WMEDLEY}PRESS.;3) - - -(PRETTYCOMPRINT PRESSCOMS) - -(RPAQQ PRESSCOMS - [ - -(* ;;; "PRESS printing support module") - - (COMS - (* ;; "Font creation functions") - - (FNS \SEARCHPRESSFONTS \GETPRESSFONTNAMES \PRESSFAMILYCODELST \DECODEPRESSFACEBYTE - \CREATEPRESSFONT \CREATECHARSET.PRESS) - (INITVARS (PRESSFONTWIDTHSFILES '{ERIS}FONTS>FONTS.WIDTHS)) - (ALISTS (SYSTEMINITVARS PRESSFONTWIDTHSFILES)) - (DECLARE%: DONTCOPY (CONSTANTS noInfoCode))) - - (* ;; "Bitmap printing support") - - (FNS PRESSBITMAP FULLPRESSBITMAP SHOWREGION SHOWPRESSBITMAPREGION PRESSWINDOW - \WRITEPRESSBITMAP) - - (* ;; "Basic PRESS data structure output functions") - - (FNS \BCPLSOUT.PRESS \PAGEPAD.PRESS \ENTITYEND.PRESS \PARTEND.PRESS \ENTITYSTART.PRESS - SETX.PRESS SETXY.PRESS SETY.PRESS SHOW.PRESS) - - (* ;; "Image stream support functions:") - - (FNS OPENPRSTREAM \BITBLT.PRESS \BLTSHADE.PRESS \SCALEDBITBLT.PRESS \BITMAPSIZE.PRESS - \CHARWIDTH.PRESS \CLOSEF.PRESS \DRAWLINE.PRESS \ENDPAGE.PRESS NEWLINE.PRESS - NEWPAGE.PRESS SETUPFONTS.PRESS \DEFINEFONT.PRESS \DSPBOTTOMMARGIN.PRESS - \DSPCLIPPINGREGION.PRESS \DSPFONT.PRESS \DSPLEFTMARGIN.PRESS \DSPLINEFEED.PRESS - \DSPRIGHTMARGIN.PRESS \DSPSPACEFACTOR.PRESS \DSPTOPMARGIN.PRESS \DSPXPOSITION.PRESS - \DSPYPOSITION.PRESS \FIXLINELENGTH.PRESS \OUTCHARFN.PRESS \SETSPACE.PRESS - \STARTPAGE.PRESS \STRINGWIDTH.PRESS SHOWRECTANGLE.PRESS \PRESS.CONVERT.NSCHARACTER) - [COMS (* ; "Drawcurve code") - (FNS \ENDVECRUN \VECENCODE \VECPUT \VECSKIP \VECFONTINIT \DRAWCIRCLE.PRESS - \DRAWARC.PRESS \DRAWCURVE.PRESS \DRAWCURVE.PRESS.LINE \DRAWELLIPSE.PRESS - \GETBRUSHFONT.PRESS \PRESSCURVE2) - (INITVARS (\VecFontDir)) - (CONSTANTS (\MicasPerInch 2540)) - (DECLARE%: DONTCOPY (CONSTANTS (ScansPerIn 384) - (PointsPerIn 72.27) - (MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn)) - (ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch)) - (ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn)) - (PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn)) - (MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn)) - (PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch)) - (SPRUCEPAPERTOPSCANS 4096) - (SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES - SPRUCEPAPERTOPSCANS - \MicasPerInch) - ScansPerIn))) - (SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch))) - (SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn))) - (SPRUCEPAPERBOTTOMSCANS 0) - (SPRUCEPAPERBOTTOMMICAS 0) - (SPRUCEPAPERLEFTSCANS 0) - (SPRUCEPAPERLEFTMICAS 0] - - (* ;; "Initialization code") - - (FNS \PRESSINIT) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\PRESSINIT))) - (DECLARE%: DONTCOPY (RECORDS PRESSDATA FONTDIRENTRY)) - (INITRECORDS PRESSDATA) - [INITVARS (DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 24765)) - (PRESSBITMAPREGION (CREATEREGION 1270 1270 (FIX (TIMES 7.5 \MicasPerInch)) - (TIMES 10 \MicasPerInch] - (GLOBALVARS DEFAULTPAGEREGION) - (DECLARE%: DONTCOPY (CONSTANTS (BYTESPERRECORD 512) - (LISPENTITYTYPE 6) - (MICASPERINCH \MicasPerInch)) - (E (RESETSAVE (RADIX 8))) - (CONSTANTS * PRESSOPS)) - - (* ;; "Hardcopy user interface connections:") - - (COMS (FNS MAKEPRESS PRESSFILEP PRESS.BITMAPSCALE) - (ALISTS (IMAGESTREAMTYPES PRESS)) - (ADDVARS [PRINTERTYPES ((PRESS SPRUCE PENGUIN DOVER) - (CANPRINT (PRESS)) - (STATUS PUP.PRINTER.STATUS) - (PROPERTIES PUP.PRINTER.PROPERTIES) - (SEND EFTP) - (BITMAPSCALE NIL) - (BITMAPFILE (PRESSBITMAP FILE BITMAP SCALEFACTOR REGION - ROTATION TITLE))) - ((FULLPRESS RAVEN) - (* ; - "same as PRESS but can scale bitmaps") - (CANPRINT (PRESS)) - (STATUS TRUE) - (PROPERTIES NILL) - (SEND EFTP) - (BITMAPSCALE PRESS.BITMAPSCALE) - (BITMAPFILE (FULLPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION - TITLE] - (PRINTFILETYPES (PRESS (TEST PRESSFILEP) - (EXTENSION (PRESS)) - (CONVERSION (TEXT MAKEPRESS TEDIT - (LAMBDA (FILE PFILE FONTS HEADING) - (SETQ FILE (OPENTEXTSTREAM - FILE)) - (TEDIT.FORMAT.HARDCOPY - FILE PFILE T NIL NIL NIL - 'PRESS) - (CLOSEF? FILE) - PFILE]) - - - -(* ;;; "PRESS printing support module") - - - - -(* ;; "Font creation functions") - -(DEFINEQ - -(\SEARCHPRESSFONTS - [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* rrb "26-Sep-84 16:35") - - (* * returns a list of the form (family size face rotation PRESS) for any font - matching the specs. * is used as wildcard.) - - (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES)) - (RESETLST (bind FONTSFOUND WSTRM for F inside PRESSFONTWIDTHSFILES when (INFILEP F) - do [COND - ((SETQ WSTRM (\GETSTREAM F 'INPUT T)) - (RESETSAVE NIL (LIST 'SETFILEPTR WSTRM (GETFILEPTR WSTRM))) - (SETFILEPTR WSTRM 0)) - (T (RESETSAVE (SETQ WSTRM (OPENSTREAM F 'INPUT 'OLD 8)) - '(PROGN (CLOSEF? OLDVALUE] - (SETQ FONTSFOUND (UNION (\GETPRESSFONTNAMES WSTRM FAMILY PSIZE FACE ROTATION) - FONTSFOUND)) finally (RETURN FONTSFOUND]) - -(\GETPRESSFONTNAMES - [LAMBDA (WSTRM FAMILY PSIZE FACE ROTATION) (* rmk%: "17-Dec-84 13:55") - - (* finds the fonts that exist that match the args. - * is used as wildcard.) - - (bind FONTSFOUND TYPE XFACE XFAMILY XSIZE XFACE XROTATION - [XFACECODE _ (COND - ((AND (LISTP FACE) - (NOT (MEMB '* FACE))) - - (* if complete face is specified, compute code so don't have to on each font.) - - (\FACECODE FACE] - (FAMILYCODELST _ (\PRESSFAMILYCODELST WSTRM)) - (NEXT _ 0) - (MICASIZE _ (AND (NEQ PSIZE '*) - (IQUOTIENT (ITIMES PSIZE 2540) - 72))) - do (SETFILEPTR WSTRM NEXT) - (SETQ TYPE (\BIN WSTRM)) - (add NEXT (LLSH (IPLUS (\BIN WSTRM) - (LLSH (LOGAND TYPE 15) - 8)) - 1)) - (SELECTQ (LRSH TYPE 4) - (4 (SETQ XFAMILY (OR (CDR (FASSOC (\BIN WSTRM) - FAMILYCODELST)) - (ERROR "unknown code number in widths file"))) - [COND - ((OR (EQ FAMILY '*) - (EQ FAMILY XFAMILY)) - (COND - ([AND (ILESSP (SETQ XFACE (\BIN WSTRM)) - 18) - (COND - (XFACECODE (AND (EQ XFACECODE XFACE) - (SETQ XFACE FACE))) - ((PROGN (SETQ XFACE (\DECODEPRESSFACEBYTE XFACE)) - (OR (EQ FACE '*) - (EQUAL FACE XFACE) - (for SPEC in FACE as XFIELD in XFACE - always (OR (EQ SPEC XFIELD) - (EQ SPEC '*] - - (* greater than 18 means either ASCII or other type of font, ignore it.) - (* skip beg and end chars) - (\BIN WSTRM) - (\BIN WSTRM) - (SETQ XSIZE (\WIN WSTRM)) - (COND - ((OR (EQ PSIZE '*) - (EQ MICASIZE XSIZE) - (AND (EQ XSIZE 0) - (SETQ XSIZE MICASIZE))) - - (* if XSIZE is 0, the font widths are relative and are to be used for all font - sizes. In this case, if the user asked about a particular size, claim that it - is there.) - - (SETQ XROTATION (\WIN WSTRM)) - (COND - ((OR (EQ ROTATION '*) - (EQ XROTATION ROTATION)) - (push FONTSFOUND (LIST XFAMILY (FIXR (FQUOTIENT (ITIMES XSIZE 72) - 2540)) - XFACE XROTATION 'PRESS]) - (0 (RETURN FONTSFOUND)) - NIL]) - -(\PRESSFAMILYCODELST - [LAMBDA (WSTRM) (* rrb "26-Sep-84 09:55") - - (* returns an ALIST of code - - family pairs from the press font widths file WSTRM.) - - (* leaving the file positioned at the beginning of the next file entry.) - - (bind PAIRS TYPE (NEXT _ 0) - do (SETFILEPTR WSTRM NEXT) - (SETQ TYPE (\BIN WSTRM)) - (add NEXT (LLSH (IPLUS (\BIN WSTRM) - (LLSH (LOGAND TYPE 15) - 8)) - 1)) - (SELECTQ (LRSH TYPE 4) - (1 (SETQ PAIRS (CONS [CONS (\WIN WSTRM) - (PACKC (for I from 1 to (\BIN WSTRM) - collect (\BIN WSTRM] - PAIRS))) - (0 (RETURN PAIRS)) - NIL]) - -(\DECODEPRESSFACEBYTE - [LAMBDA (FACECODE) (* rrb "26-Sep-84 14:28") - - (* * returns a list of (weight slope expansion) from a press widths file byte - code.) - - (COND - [(ILESSP FACECODE 18) - (PROG (EXP SLOPE WEIGHT) - [SETQ EXP (COND - ((IGEQ FACECODE 12) - (SETQ FACECODE (IDIFFERENCE FACECODE 12)) - 'EXPANDED) - ((IGEQ FACECODE 6) - (SETQ FACECODE (IDIFFERENCE FACECODE 6)) - 'COMPRESSED) - (T 'REGULAR] - [SETQ WEIGHT (COND - ((IGEQ FACECODE 4) - (SETQ FACECODE (IDIFFERENCE FACECODE 4)) - 'LIGHT) - ((IGEQ FACECODE 2) - (SETQ FACECODE (IDIFFERENCE FACECODE 2)) - 'BOLD) - (T 'MEDIUM] - [SETQ SLOPE (COND - ((EQ FACECODE 1) - 'ITALIC) - (T 'REGULAR] - (RETURN (LIST WEIGHT SLOPE EXP] - (T (* non xerox font) - NIL]) - -(\CREATEPRESSFONT - [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* jds "10-Mar-86 16:35") - - (* 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 PRESSFONTWIDTHSFILES)) - (RESETLST (* RESETLST to make sure the fontfiles - get closed) - (PROG ((FD (create FONTDESCRIPTOR - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ PSIZE - FONTFACE _ FACE - \SFFACECODE _ (\FACECODE FACE) - ROTATION _ ROTATION - FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72)) - \SFHeight _ 0 - \SFAscent _ 0 - \SFDescent _ 0))) - (\GETCHARSETINFO 0 FD T) - (RETURN FD]) - -(\CREATECHARSET.PRESS - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) - (* ; "Edited 29-Jul-87 14:15 by jds") - -(* ;;; "just a dummy definition. Press should not ever be trying to change character sets, since the fonts only contain charset 0 (roughly)") - - (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES)) - (COND - ((NEQ 0 CHARSET) - (ERROR "Press does not support NS characters."))) - (RESETLST (* ; - "RESETLST to make sure the fontfiles get closed") - - (PROG* (WSTRM STRMCACHE XLATEDFAM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY WIDTHS - (PRESSMICASIZE (IQUOTIENT (ITIMES SIZE 2540) - 72)) - (NSMICASIZE (FIXR (FQUOTIENT (ITIMES SIZE 2540) - 72))) - (FACECODE (\FACECODE FACE)) - [FD (create FONTDESCRIPTOR - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ SIZE - FONTFACE _ FACE - \SFFACECODE _ FACECODE - ROTATION _ ROTATION - FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72] - (CSINFO (create CHARSETINFO))) - -(* ;;; "Go look for the fonts.widths file that has this font's info in it.") - - (OR [for F inside PRESSFONTWIDTHSFILES when (INFILEP F) - do (* ; - "Look thru the candidate PRESSFONTWIDTHSFILES for a file that has a description for this font.") - - [COND - [(SETQ WSTRM (\GETSTREAM F 'INPUT T)) - (COND - ((RANDACCESSP WSTRM) - (RESETSAVE NIL (LIST 'SETFILEPTR WSTRM (GETFILEPTR WSTRM))) - (SETFILEPTR WSTRM 0] - (T (RESETSAVE (SETQ WSTRM (OPENSTREAM F 'INPUT 'OLD 8)) - '(PROGN (CLOSEF? OLDVALUE] - [OR (RANDACCESSP WSTRM) - (COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM '{NODIRCORE} 'BOTH - 'NEW] - (push STRMCACHE WSTRM) (* ; "Save for coercions below") - - (COND - ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NSMICASIZE FIRSTCHAR LASTCHAR - FAMILY FACECODE)) - (* ; - "OK, we found this font described in this file.") - - (RETURN T] - [AND (SETQ XLATEDFAM (SELECTQ FAMILY - (MODERN 'HELVETICA) - (CLASSIC 'TIMESROMAN) - (LOGOTYPE 'LOGO) - (TERMINAL 'GACHA) - NIL)) - (for old WSTRM in (SETQ STRMCACHE (DREVERSE STRMCACHE)) - first (replace FONTFAMILY of FD with XLATEDFAM) - do (* ; "Now try coercing the family name") - - (* ;; "We know the file was left open and is randaccessp from the previous loop, which must have run off the end of the file list") - - (SETFILEPTR WSTRM 0) - (COND - ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NSMICASIZE FIRSTCHAR - LASTCHAR XLATEDFAM FACECODE)) - (replace FONTDEVICESPEC of FD - with (LIST XLATEDFAM SIZE FACE ROTATION DEVICE)) - (replace FONTFAMILY of FD with FAMILY) - (RETURN T] - [AND (SETQ XLATEDFAM (SELECTQ FAMILY - (MODERN 'FRUTIGER) - (CLASSIC 'CENTURY) - NIL)) - (for old WSTRM in STRMCACHE first (replace FONTFAMILY of FD with XLATEDFAM - ) - do (SETFILEPTR WSTRM 0) - (COND - ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NSMICASIZE FIRSTCHAR - LASTCHAR XLATEDFAM FACECODE)) - (replace FONTDEVICESPEC of FD - with (LIST XLATEDFAM SIZE FACE ROTATION DEVICE)) - (replace FONTFAMILY of FD with FAMILY) - (RETURN T] - (RETURN NIL)) - -(* ;;; "Having found the font-widths file, now read the width info from it.") - - (SETQ RELFLAG (ZEROP RELFLAG)) (* ; - "Actually, \POSITIONFONTFILE returns zero if the font metrics are size-relative and must be scaled.") - - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (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") - - (SETQ FOO (\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) - (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) - BYTESPERWORD)) (* ; "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]) -) - -(RPAQ? PRESSFONTWIDTHSFILES '{ERIS}FONTS>FONTS.WIDTHS) - -(ADDTOVAR SYSTEMINITVARS (PRESSFONTWIDTHSFILES {DSK}FONTS.WIDTHS)) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ noInfoCode 32768) - - -(CONSTANTS noInfoCode) -) -) - - - -(* ;; "Bitmap printing support") - -(DEFINEQ - -(PRESSBITMAP - [LAMBDA (FILE BITMAP SCALEFACTOR CLIPPINGREGION) (* ; "Edited 12-Jun-90 10:39 by mitani") - - (* * This routine uses the whole page (ie PRTOP and PRRIGHT as opposed to - PRWIDTH and PRHEIGHT) to produce a SPRUCE Press file. - It will truncate if necessary since SPRUCE does not support scaling) - - (PROG ((PRSTREAM (OPENPRSTREAM FILE)) - WIDTH HEIGHT PRDATA XPOS YPOS (PRESSPAGEHEIGHT (fetch (REGION HEIGHT) of - PRESSBITMAPREGION - )) - (PRESSPAGEWIDTH (fetch (REGION WIDTH) of PRESSBITMAPREGION))) - (SETQ PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)) - (if (AND SCALEFACTOR (NOT (EQUAL SCALEFACTOR 1))) - then (ERROR "Spruce cannot scale bitmaps. Try pressing to a full press printer.")) - (* Get width and height in screen - pts) - [COND - (CLIPPINGREGION (SETQ WIDTH (fetch (REGION WIDTH) of CLIPPINGREGION)) - (SETQ HEIGHT (fetch (REGION HEIGHT) of CLIPPINGREGION))) - (T (SETQ WIDTH (BITMAPWIDTH BITMAP)) - (SETQ HEIGHT (BITMAPHEIGHT BITMAP] - (SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH))) - 2)) - (SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT))) - 2)) - [COND - ((OR (ILESSP XPOS 0) - (ILESSP YPOS 0)) - (printout T "Warning: Bitmap too large for Spruce PRESS page, will be clipped..." T) - (SETQ XPOS (IMAX 0 XPOS)) - (SETQ YPOS (IMAX 0 YPOS)) - (SETQ CLIPPINGREGION (if CLIPPINGREGION - then [CREATEREGION (fetch (REGION LEFT) of - CLIPPINGREGION - ) - (fetch (REGION BOTTOM) of - CLIPPINGREGION - ) - (FIX (MIN WIDTH (QUOTIENT PRESSPAGEWIDTH - MicasPerPoint))) - (FIX (MIN HEIGHT (QUOTIENT PRESSPAGEHEIGHT - MicasPerPoint] - else (CREATEREGION 0 0 (FIX (MIN WIDTH (QUOTIENT - PRESSPAGEWIDTH - MicasPerPoint) - )) - (FIX (MIN HEIGHT (QUOTIENT PRESSPAGEHEIGHT - MicasPerPoint] - (\WRITEPRESSBITMAP BITMAP (IPLUS (fetch (REGION LEFT) of PRESSBITMAPREGION) - XPOS) - (IPLUS (fetch (REGION BOTTOM) of PRESSBITMAPREGION) - YPOS) - SCALEFACTOR CLIPPINGREGION PRSTREAM) - (RETURN (CLOSEF PRSTREAM]) - -(FULLPRESSBITMAP - [LAMBDA (FILE BITMAP SCALEFACTOR CLIPPINGREGION) (* ; "Edited 12-Jun-90 10:39 by mitani") - - (* * This routine uses the whole page (ie PRTOP and PRRIGHT as opposed to - PRWIDTH and PRHEIGHT) to produce a full Press file. - It will scale if necessary) - - (* * When this fn is called from HARDCOPYW, the scalefactor should already be - correct. On a direct call, it will handle it itself) - - (PROG ((PRSTREAM (OPENPRSTREAM FILE)) - WIDTH HEIGHT PRDATA XPOS YPOS (PRESSPAGEHEIGHT (fetch (REGION HEIGHT) of - PRESSBITMAPREGION - )) - (PRESSPAGEWIDTH (fetch (REGION WIDTH) of PRESSBITMAPREGION))) - (SETQ PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)) - (if (NOT SCALEFACTOR) - then (SETQ SCALEFACTOR 1.0)) (* Get width and height in screen - pts) - [COND - (CLIPPINGREGION (SETQ WIDTH (fetch (REGION WIDTH) of CLIPPINGREGION)) - (SETQ HEIGHT (fetch (REGION HEIGHT) of CLIPPINGREGION))) - (T (SETQ WIDTH (BITMAPWIDTH BITMAP)) - (SETQ HEIGHT (BITMAPHEIGHT BITMAP] - (SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH - SCALEFACTOR))) - 2)) - (SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT - SCALEFACTOR))) - 2)) - [COND - ((OR (ILESSP XPOS 0) - (ILESSP YPOS 0)) - (printout T "Warning: Bitmap too large for PRESS page, will be scaled..." T) - (SETQ SCALEFACTOR (PRESS.BITMAPSCALE WIDTH HEIGHT)) - (SETQ XPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEWIDTH (FIX (TIMES MicasPerPoint WIDTH - SCALEFACTOR))) - 2)) - (SETQ YPOS (IQUOTIENT (IDIFFERENCE PRESSPAGEHEIGHT (FIX (TIMES MicasPerPoint HEIGHT - SCALEFACTOR))) - 2)) - (if (OR (ILESSP XPOS 0) - (ILESSP YPOS 0)) - then (ERROR "Internal consistency check failed in FULLPRESSBITMAP."] - (\WRITEPRESSBITMAP BITMAP (IPLUS (fetch (REGION LEFT) of PRESSBITMAPREGION) - XPOS) - (IPLUS (fetch (REGION BOTTOM) of PRESSBITMAPREGION) - YPOS) - SCALEFACTOR CLIPPINGREGION PRSTREAM) - (RETURN (CLOSEF PRSTREAM]) - -(SHOWREGION - [LAMBDA (REGION STREAM) (* ; "Edited 12-Jun-90 10:38 by mitani") - - (* * comment) - - (PROG NIL - (MOVETO (fetch (REGION LEFT) of REGION) - (fetch (REGION BOTTOM) of REGION) - STREAM) - (RELDRAWTO (fetch (REGION WIDTH) of REGION) - 0 NIL NIL STREAM) - (RELDRAWTO 0 (fetch (REGION HEIGHT) of REGION) - NIL NIL STREAM) - (RELDRAWTO (MINUS (fetch (REGION WIDTH) of REGION)) - 0 NIL NIL STREAM) - (RELDRAWTO 0 (MINUS (fetch (REGION HEIGHT) of REGION)) - NIL NIL STREAM) - (RETURN STREAM]) - -(SHOWPRESSBITMAPREGION - [LAMBDA NIL (* gbn "16-Sep-84 19:18") - - (* * comment) - - (PROG [(STR (OPENIMAGESTREAM '{LPT} 'PRESS] - (SHOWREGION PRESSBITMAPREGION STR) - (RETURN (CLOSEF STR]) - -(PRESSWINDOW - [LAMBDA (W) (* ; "Edited 12-Jun-90 10:39 by mitani") - (* First Try) - (PROG ((PRSTREAM (OPENPRSTREAM '{CORE}WINDOW.PRESS (LIST 'HEADING "Press Stream Window Image" - 'BREAKPAGEFILENAME - "Press Stream Window Image"))) - [BITMAP (WINDOW.BITMAP (OR W (WHICHW] - WIDTH HEIGHT (PTSTOMICAS 35)) - (SETQ WIDTH (BITMAPWIDTH BITMAP)) - (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) - (DSPXPOSITION (IPLUS (fetch PRLEFT of (fetch (STREAM IMAGEDATA) of PRSTREAM - )) - (IQUOTIENT (IDIFFERENCE (fetch PRWIDTH of (fetch - (STREAM IMAGEDATA) - of PRSTREAM)) - (ITIMES PTSTOMICAS WIDTH)) - 2)) - PRSTREAM) - (DSPYPOSITION (IPLUS (fetch PRBOTTOM of (fetch (STREAM IMAGEDATA) of - PRSTREAM - )) - (IQUOTIENT (IDIFFERENCE (fetch PRHEIGHT of (fetch - (STREAM IMAGEDATA) - of PRSTREAM) - ) - (ITIMES PTSTOMICAS HEIGHT)) - 2)) - PRSTREAM) - (\WRITEPRESSBITMAP BITMAP NIL NIL PRSTREAM) - (RETURN (CLOSEF PRSTREAM]) - -(\WRITEPRESSBITMAP - [LAMBDA (BITMAP XPOS YPOS SCALEFACTOR CLIPPINGREGION PRSTREAM) - (* ; "Edited 12-Jun-90 10:39 by mitani") - (* This should define the origin of - the bitmap on the page) - [COND - (CLIPPINGREGION (* UGH) - (SETQ BITMAP (PROG [(BM (BITMAPCREATE (fetch (REGION WIDTH) of CLIPPINGREGION) - (fetch (REGION HEIGHT) of CLIPPINGREGION] - (with REGION CLIPPINGREGION - (BITBLT BITMAP LEFT BOTTOM BM NIL NIL WIDTH HEIGHT)) - (RETURN BM] - (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)) - (WW (fetch BITMAPRASTERWIDTH of BITMAP)) - (HT (fetch BITMAPHEIGHT of BITMAP)) - ELSTREAM TOTCOUNT CURX CURY) - (SETQ ELSTREAM (fetch ELSTREAM of PRDATA)) - (SETQ CURX (fetch PRXPOS of PRDATA)) - (SETQ CURY (fetch PRYPOS of PRDATA)) - (SHOW.PRESS PRSTREAM) (* flush chars before ending entity) - (\ENTITYEND.PRESS PRSTREAM) - - (* Close previous entity because we used to specify a translation for the - bitmap entity. But now we are using the current x and y position. - All this stuff might therefore be unnecessary) - - (\ENTITYSTART.PRESS PRSTREAM) - (SETXY.PRESS PRSTREAM XPOS YPOS) - (COND - ((NULL SCALEFACTOR) - (SETQ SCALEFACTOR 1.0))) - (\WOUT PRSTREAM 256) (* Output <>. - (0 notates bitmap, followed by 2byte - width (in dots) and height - (in dots))) - (\WOUT PRSTREAM (UNFOLD WW BITSPERWORD)) (* Width) - (\WOUT PRSTREAM HT) (* Height) - (\WOUT PRSTREAM (IPLUS 512 3)) (* <> notates that the - Lisp bitmap is stored left-to-right - and top-to-bottom) - (\WOUT PRSTREAM 2) - - (* you might think it should be MicasPerPoint - - ha ha ha! Only the value 32 works! Oops!) - - [\WOUT PRSTREAM (FIXR (FTIMES SCALEFACTOR (TIMES 32 (UNFOLD WW BITSPERWORD] - [\WOUT PRSTREAM (FIXR (FTIMES SCALEFACTOR (TIMES 32 HT] - (\WOUT PRSTREAM 1) - - (* Set Window. 2 bytes of how many bytes to skip, 2 bytes of how many dots wide - to display followed by the same for lines) - - (\WOUT PRSTREAM 0) (* skip 0 dots) - (\WOUT PRSTREAM (UNFOLD WW BITSPERWORD)) - (\WOUT PRSTREAM 0) (* skip 0 lines) - (\WOUT PRSTREAM HT) - (\WOUT PRSTREAM 3) (* <>) - (* TOTCOUNT is a word count.) - (\BOUTS PRSTREAM (fetch BITMAPBASE of BITMAP) - 0 - (UNFOLD (SETQ TOTCOUNT (ITIMES HT WW)) - BYTESPERWORD)) - (\BOUT ELSTREAM ShowDotsCode) - (\FIXPOUT ELSTREAM (IPLUS TOTCOUNT 13)) (* Number of DL bytes) - (\ENTITYEND.PRESS PRSTREAM) - (\ENTITYSTART.PRESS PRSTREAM) (* Since START reestablishes X and - Y, following might not be necessary) - (SETXY.PRESS PRSTREAM CURX CURY]) -) - - - -(* ;; "Basic PRESS data structure output functions") - -(DEFINEQ - -(\BCPLSOUT.PRESS - [LAMBDA (STRM X N) (* rmk%: "14-Jun-84 19:36") - - (* Puts out a Bcpl string X in N bytes, filling with zeroes or truncating if - needed.) - - (PROG [(NC (IMIN (NCHARS X) - (SETQ N (SUB1 N] - (\BOUT STRM NC) - (for I from 1 to NC do (\BOUT STRM (NTHCHARCODE X I))) - (for I from (ADD1 NC) to N do (\BOUT STRM 0]) - -(\PAGEPAD.PRESS - [LAMBDA (STRM) (* rmk%: "14-Jun-84 18:30") - - (* Move the fileptr to the next record boundary, returning the number of words - skipped.) - - (PROG (PADDING (P (GETFILEPTR STRM))) - (SETQ PADDING (MODUP P BYTESPERRECORD)) - (COND - ((IGREATERP PADDING 0) - - (* SETFILEPTR for all but 1, then \BOUT to make sure the file gets extended.) - - [AND (NEQ PADDING 1) - (SETFILEPTR STRM (IPLUS P (SUB1 PADDING] - (\BOUT STRM 0))) - (RETURN (FOLDLO PADDING BYTESPERWORD]) - -(\ENTITYEND.PRESS - [LAMBDA (PRSTREAM XOFFSET YOFFSET ETYPE) (* ; "Edited 12-Jun-90 10:39 by mitani") - (PROG (ELSTREAM DLLENGTH (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (SETQ ELSTREAM (fetch ELSTREAM of PRDATA)) - (SETQ DLLENGTH (IDIFFERENCE (\GETFILEPTR PRSTREAM) - (fetch DLSTARTBYTE of PRDATA))) - (COND - ((ODDP (GETFILEPTR ELSTREAM)) - (\BOUT ELSTREAM NopCode))) - (\BOUT ELSTREAM (OR ETYPE LISPENTITYTYPE)) - (\BOUT ELSTREAM (OR (fetch FONTSET# of (fetch PRCURRFDE of PRDATA)) - 0)) (* fontset) - (\FIXPOUT ELSTREAM (IDIFFERENCE (fetch DLSTARTBYTE of PRDATA) - (UNFOLD (fetch PRPARTSTART of PRDATA) - BYTESPERRECORD))) (* (IDIFFERENCE (fetch DLSTARTBYTE - of PRDATA) (UNFOLD - (fetch PRPARTSTART of PRDATA) - BYTESPERRECORD))) - (* part relative start of data list - for this entity) - (\FIXPOUT ELSTREAM DLLENGTH) (* length of data) - (\WOUT ELSTREAM (OR XOFFSET 0)) (* Entity origin) - (\WOUT ELSTREAM (OR YOFFSET 0)) - (\WOUT ELSTREAM (fetch PRLEFT of PRDATA)) (* The bounding box for this entity - - - MAYBE LEFT AND BOTTOM ARE SIGNED?) - (\WOUT ELSTREAM (fetch PRBOTTOM of PRDATA)) - (\WOUT ELSTREAM (IDIFFERENCE (fetch PRRIGHT of PRDATA) - (fetch PRLEFT of PRDATA))) - (* width) - (\WOUT ELSTREAM (IDIFFERENCE (fetch PRTOP of PRDATA) - (fetch PRBOTTOM of PRDATA))) - (* height) - (\WOUT ELSTREAM (ADD1 (FOLDLO (IDIFFERENCE (GETFILEPTR ELSTREAM) - (fetch ELSTARTBYTE of PRDATA)) - BYTESPERWORD))) (* Length in words--ADD1 for the - length itself) - ]) - -(\PARTEND.PRESS - [LAMBDA (PRSTREAM PARTTYPE) (* ; "Edited 12-Jun-90 10:39 by mitani") - - (* Closes one part and sets up for the next, by saving the partstart and - emptying the entitylist stream) - - (PROG (START PDSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (SETQ PDSTREAM (fetch PDSTREAM of PRDATA)) - (SETQ START (fetch PRPARTSTART of PRDATA)) - (\WOUT PDSTREAM PARTTYPE) - (\WOUT PDSTREAM START) (* Starting record) - (* Update starting record for next - part, and record length in records - of this part) - (\WOUT PDSTREAM (IDIFFERENCE (replace PRPARTSTART of PRDATA - with (FOLDHI (GETFILEPTR PRSTREAM) - BYTESPERRECORD)) - START)) - (\WOUT PDSTREAM (\PAGEPAD.PRESS PRSTREAM)) - (SETFILEPTR (fetch ELSTREAM of PRDATA) - 0]) - -(\ENTITYSTART.PRESS - [LAMBDA (PRSTREAM) (* ; "Edited 12-Jun-90 10:39 by mitani") - (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (freplace PRSPACEWIDTH of PRDATA with NIL) - - (* This really should be the spacewidth of the current font. - But then, if we switch fonts to one whose space*spacefactor comes out the same, - we won't know to put out a setspace command. - So when we actually set up the first font in this entity, we will end up - putting out an explicit setspace (even if the space factor is 1)) - - (freplace PRFONT of PRDATA with NIL) - - (* We set the font to NIL, knowing that the current font can be recoverd from - the PRCURRFDE. This font will be set in the press file before the first show, - if no explicit dspfont intervenes. Note, however, that up until the first - dspfont, the widthscache still corresponds to what was the PRFONT.) - - (freplace DLSTARTBYTE of PRDATA with (\GETFILEPTR PRSTREAM)) - (freplace ELSTARTBYTE of PRDATA with (\GETFILEPTR (fetch ELSTREAM - of PRDATA))) - (freplace STARTCHARBYTE of PRDATA with (\GETFILEPTR PRSTREAM)) - (* Entity starts with position at - 0,0 so must re-establish current - position (?)) - (SETXY.PRESS PRSTREAM (fetch PRXPOS of PRDATA) - (fetch PRYPOS of PRDATA]) - -(SETX.PRESS - [LAMBDA (PRSTREAM X) (* ; "Edited 12-Jun-90 10:39 by mitani") - (PROG [(ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM] - (COND - ([AND (IGEQ X SPRUCEPAPERLEFTMICAS) - (ILEQ X SPRUCEPAPERRIGHTMICAS) - (NOT (IEQP X (fetch PRXPOS of (fetch (STREAM IMAGEDATA) of - PRSTREAM - ] - (\BOUT ELSTREAM SetXCode) (* Outcharfn ignores characters that - are not in the clipping region) - (\WOUT ELSTREAM X))) - (replace PRXPOS of (fetch (STREAM IMAGEDATA) of PRSTREAM) with X]) - -(SETXY.PRESS - [LAMBDA (PRSTREAM X Y) (* ; "Edited 12-Jun-90 10:39 by mitani") - (PROG (ELSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (SETQ ELSTREAM (fetch ELSTREAM of PRDATA)) - (COND - ((AND (IGEQ X SPRUCEPAPERLEFTMICAS) - (ILEQ X SPRUCEPAPERRIGHTMICAS)) - - (* this clause could be part of the above test to avoid putting out set x when - the position is in the right place. There is a place that Ron thinks is in - endvecrun where setxy is called to get the printer and the streams idea of - where the position is back into step. Thus if this test is included, that setxy - is not put out when it should be. rrb (NOT - (IEQP X (fetch PRXPOS of PRDATA)))) - - (\BOUT ELSTREAM SetXCode) - (\WOUT ELSTREAM X))) - (replace PRXPOS of PRDATA with X) - (COND - ((AND (IGEQ Y SPRUCEPAPERBOTTOMMICAS) - (ILEQ Y SPRUCEPAPERTOPMICAS)) - - (* see above comment (NOT (IEQP Y (fetch PRYPOS of PRDATA))) This clause should - NOT be reinserted, because functions like \ENTITYSTART.PRESS call this function - and need to really have the commands emitted, even tho the PRXPOS and PRYPOS - fields claim to be real.) - - (\BOUT ELSTREAM SetYCode) - (\WOUT ELSTREAM Y))) - (RETURN (replace PRYPOS of PRDATA with Y]) - -(SETY.PRESS - [LAMBDA (PRSTREAM Y) (* ; "Edited 12-Jun-90 10:39 by mitani") - (PROG [(ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM] - (COND - ([AND (IGEQ Y SPRUCEPAPERBOTTOMMICAS) - (ILEQ Y SPRUCEPAPERTOPMICAS) - (NOT (IEQP Y (fetch PRYPOS of (ffetch (STREAM IMAGEDATA) of - PRSTREAM - ] - (\BOUT ELSTREAM SetYCode) - (\WOUT ELSTREAM Y))) - (freplace PRYPOS of (ffetch (STREAM IMAGEDATA) of PRSTREAM) with Y]) - -(SHOW.PRESS - [LAMBDA (PRSTREAM) (* ; "Edited 12-Jun-90 10:39 by mitani") - (PROG (CNT ELSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)) - (CURBYTE (\GETFILEPTR PRSTREAM))) - (SETQ ELSTREAM (fetch ELSTREAM of PRDATA)) - (SETQ CNT (IDIFFERENCE CURBYTE (fetch STARTCHARBYTE of PRDATA))) - [COND - ((IGREATERP CNT 0) - [COND - ((NULL (fetch PRFONT of PRDATA)) - - (* This is the first run of characters in this entity, and there has been no - explicit dspfont. We therefore re-establish the current font as of the end of - the last entity) - - (replace PRFONT of PRDATA with (fetch DESCR - of (fetch PRCURRFDE - of PRDATA))) - (\BOUT (fetch ELSTREAM of PRDATA) - (LOGOR FontCode (fetch (FONTDIRENTRY FONT#) of (fetch PRCURRFDE - of PRDATA] - (COND - ((ILESSP CNT 33) (* short form) - (\BOUT ELSTREAM (IPLUS ShowCharactersShortCode CNT -1))) - (T (* Break up every 255) - (while (IGREATERP CNT 255) do (\BOUT ELSTREAM ShowCharactersCode) - (\BOUT ELSTREAM 255) - (SETQ CNT (IDIFFERENCE CNT 255)) - finally (\BOUT ELSTREAM ShowCharactersCode) - (\BOUT ELSTREAM CNT] - (replace STARTCHARBYTE of PRDATA with CURBYTE]) -) - - - -(* ;; "Image stream support functions:") - -(DEFINEQ - -(OPENPRSTREAM - [LAMBDA (PRFILE OPTIONS) (* rmk%: "17-Dec-84 10:34") - - (* Opens a Press stream, to which user can do OUTCHAR. - OPTIONS can include a REGION, HEADING, BREAKPAGEFILENAME, and FONTS. - FONTS is a list of fonts to be set up initially. - Headings will be printed in the first font in FONTS. - If FONTS is NIL, then the stream is initialized with the PRESS DEFAULTFONT) - - (DECLARE (GLOBALVARS DEFAULTPAGEREGION \PRESSIMAGEOPS)) - (PROG [OPT PRDATA (PRSTREAM (OPENSTREAM PRFILE 'OUTPUT 'NEW 8 '((TYPE BINARY] - [SETQ PRDATA (create PRESSDATA - PRPAGEREGION _ (COND - ([type? REGION (SETQ OPT (LISTGET OPTIONS - 'REGION] - OPT) - (T DEFAULTPAGEREGION)) - PDSTREAM _ (PROG1 (OPENSTREAM '{NODIRCORE} 'BOTH 'OLD/NEW) - - (* Make sure the fileptr of the following is zero - (GETRESOURCE \PRESSPDSTREAM) (and free this in \CLOSE.PRESS)) - - ) - ELSTREAM _ (PROG1 (OPENSTREAM '{NODIRCORE} 'BOTH 'OLD/NEW) - - (* Make sure the fileptr of the following is zero - (GETRESOURCE \PRESSELSTREAM) (and free this in \CLOSE.PRESS)) - - ) - PRDOCNAME _ (LISTGET OPTIONS 'DOCUMENT.NAME] - (COND - ((OR (NEQ \NOIMAGEOPS (fetch (STREAM IMAGEOPS) of PRSTREAM)) - (NEQ 0 (GETEOFPTR PRSTREAM))) - (ERROR "can't convert existing file to Press" (FULLNAME PRSTREAM)) - (* GETEOFPTR might bomb on some - streams) - )) - (replace (STREAM OUTCHARFN) of PRSTREAM with (FUNCTION \OUTCHARFN.PRESS)) - (replace (STREAM IMAGEOPS) of PRSTREAM with \PRESSIMAGEOPS) - (replace (STREAM IMAGEDATA) of PRSTREAM with PRDATA) - (COND - ((SETQ OPT (LISTGET OPTIONS 'HEADING)) - (replace PRHEADING of PRDATA with OPT))) - (SETUPFONTS.PRESS PRSTREAM (LISTGET OPTIONS 'FONTS)) - (\STARTPAGE.PRESS PRSTREAM) - (RETURN PRSTREAM]) - -(\BITBLT.PRESS - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH - HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM) (* hdj " 5-Dec-84 18:39") - (LET* ((OLDX (\DSPXPOSITION.PRESS DESTINATION)) - (OLDY (\DSPYPOSITION.PRESS DESTINATION)) - (DESTINATIONLEFT (OR DESTINATIONLEFT OLDX)) - (DESTINATIONBOTTOM (OR DESTINATIONBOTTOM OLDY))) - (\DSPXPOSITION.PRESS DESTINATION DESTINATIONLEFT) - (\DSPYPOSITION.PRESS DESTINATION DESTINATIONBOTTOM) - (\WRITEPRESSBITMAP SOURCEBITMAP DESTINATIONLEFT DESTINATIONBOTTOM 1 - (COND - (CLIPPINGREGION (INTERSECTREGIONS CLIPPINGREGION (CREATEREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM WIDTH - HEIGHT))) - (T (CREATEREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM WIDTH HEIGHT))) - DESTINATION) - (\DSPXPOSITION.PRESS DESTINATION OLDX) - (\DSPYPOSITION.PRESS DESTINATION OLDY)) - T]) - -(\BLTSHADE.PRESS - [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) - (* hdj "12-Mar-85 12:30") - (LET* ((REGION (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT)) - (DESTREGION (if CLIPPINGREGION - then (INTERSECTREGIONS REGION CLIPPINGREGION) - else REGION))) - - (* * (SHOWSHADE.IP STREAM TEXTURE DESTREGION OPERATION)) - (* Dovers print at 32 micas per point) - (\BLTSHADE.GENERICPRINTER TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT - OPERATION CLIPPINGREGION 32]) - -(\SCALEDBITBLT.PRESS - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH - HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM SCALE) (* hdj "14-Feb-85 14:33") - (LET* ((OLDX (\DSPXPOSITION.PRESS DESTINATION)) - (OLDY (\DSPYPOSITION.PRESS DESTINATION)) - (DESTINATIONLEFT (OR DESTINATIONLEFT OLDX)) - (DESTINATIONBOTTOM (OR DESTINATIONBOTTOM OLDY))) - (\DSPXPOSITION.PRESS DESTINATION DESTINATIONLEFT) - (\DSPYPOSITION.PRESS DESTINATION DESTINATIONBOTTOM) - (\WRITEPRESSBITMAP SOURCEBITMAP DESTINATIONLEFT DESTINATIONBOTTOM SCALE - (COND - (CLIPPINGREGION (INTERSECTREGIONS CLIPPINGREGION (CREATEREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM WIDTH - HEIGHT))) - (T (CREATEREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM WIDTH HEIGHT))) - DESTINATION) - (\DSPXPOSITION.PRESS DESTINATION OLDX) - (\DSPYPOSITION.PRESS DESTINATION OLDY)) - T]) - -(\BITMAPSIZE.PRESS - [LAMBDA (STREAM BITMAP DIMENSION) (* rmk%: "17-Dec-84 10:22") - (SELECTQ DIMENSION - (WIDTH (UNFOLD (BITMAPWIDTH BITMAP) - 32)) - (HEIGHT (UNFOLD (BITMAPHEIGHT BITMAP) - 32)) - (NIL (CONS (UNFOLD (BITMAPWIDTH BITMAP) - 32) - (UNFOLD (BITMAPHEIGHT BITMAP) - 32))) - (\ILLEGAL.ARG DIMENSION]) - -(\CHARWIDTH.PRESS - [LAMBDA (STREAM CHARCODE) (* ; "Edited 12-Jun-90 10:39 by mitani") - (* Gets the width of CHARCODE in an - Interpress STREAM, observing - spacefactor) - - (* * Convert from NS characters back to old PARC-internal coding for PRESS - fonts) - - (SETQ CHARCODE (\PRESS.CONVERT.NSCHARACTER CHARCODE)) - - (* * Then compute the character's width.) - - (COND - ((EQ CHARCODE (CHARCODE SPACE)) (* If it's a SPACE, use the declared - space width from the stream) - (ffetch PRSPACEWIDTH of (ffetch (STREAM IMAGEDATA) of STREAM))) - (T (\FGETCHARWIDTH (ffetch PRFONT of (ffetch (STREAM IMAGEDATA) of STREAM)) - (LOGAND CHARCODE \CHARMASK]) - -(\CLOSEF.PRESS - [LAMBDA (PRSTREAM) (* ; "Edited 12-Jun-90 10:39 by mitani") - (* FILENAME is for the printer break - page) - (\ENDPAGE.PRESS PRSTREAM) - (PROG (PDSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (SETQ PDSTREAM (fetch PDSTREAM of PRDATA)) - (COND - ((NEQ 0 (GETFILEPTR PDSTREAM)) - (for FDE DESCR in (fetch PRESSFONTDIR of PRDATA) as I from - 0 - do (SETQ DESCR (fetch DESCR of FDE)) - (\WOUT PRSTREAM 16) - (\BOUT PRSTREAM (fetch FONTSET# of FDE)) - (* Fontset) - (\BOUT PRSTREAM (fetch FONT# of FDE)) - (* font#) - (\BOUT PRSTREAM 3) (* (\BOUT PRSTREAM - (fetch FIRSTCHAR of DESCR))) - (\BOUT PRSTREAM 254) (* (\BOUT PRSTREAM - (fetch LASTCHAR of DESCR))) - (\BCPLSOUT.PRESS PRSTREAM (FONTPROP DESCR 'DEVICEFAMILY) - 20) - [\BOUT PRSTREAM (\FACECODE (FONTPROP DESCR 'DEVICEFACE] - (\BOUT PRSTREAM 3) (* (\BOUT PRSTREAM - (fetch FIRSTCHAR of DESCR))) - (\WOUT PRSTREAM (FONTPROP DESCR 'DEVICESIZE)) - (\WOUT PRSTREAM (fetch ROTATION of DESCR))) - (\WOUT PRSTREAM 0) (* Font part ends with 0 word) - (\PARTEND.PRESS PRSTREAM 1) - (COPYBYTES PDSTREAM PRSTREAM 0 (GETFILEPTR PDSTREAM)) - (\PAGEPAD.PRESS PRSTREAM) - (PROG (DDRECORD (DDFILEPTR (GETFILEPTR PRSTREAM))) - (* Write document directory) - (SETQ DDRECORD (FOLDLO DDFILEPTR BYTESPERRECORD)) - (\WOUT PRSTREAM 27183) (* password) - (\WOUT PRSTREAM (ADD1 DDRECORD)) - (\WOUT PRSTREAM (FOLDLO (GETFILEPTR PDSTREAM) - 8)) (* number of parts, since each - occupies 8 bytes in PD) - (\WOUT PRSTREAM (fetch PRPARTSTART of PRDATA)) - (* part directory) - (\WOUT PRSTREAM (IDIFFERENCE DDRECORD (fetch PRPARTSTART of PRDATA))) - (\SIGNEDWOUT PRSTREAM -1) (* obselete) - (\FIXPOUT PRSTREAM (LISP.TO.ALTO.DATE (IDATE))) - (\WOUT PRSTREAM 1) - (\WOUT PRSTREAM 1) (* copies) - (\SIGNEDWOUT PRSTREAM -1) - (\SIGNEDWOUT PRSTREAM -1) (* first and last pages) - (\SIGNEDWOUT PRSTREAM -1) (* printing mode default) - (SETFILEPTR PRSTREAM (IPLUS DDFILEPTR 256)) - (\BCPLSOUT.PRESS PRSTREAM (OR (fetch PRDOCNAME of PRDATA) - (FULLNAME PRSTREAM)) - 52) - (\BCPLSOUT.PRESS PRSTREAM USERNAME 32) - (\BCPLSOUT.PRESS PRSTREAM (GETFILEINFO PRSTREAM 'CREATIONDATE) - 40) - (\PAGEPAD.PRESS PRSTREAM]) - -(\DRAWLINE.PRESS - [LAMBDA (PRSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) - (* rrb "27-Sep-85 18:15") - (COND - (DASHING - - (* hack to handle dashing by breaking into small lines. - Should be removed if \DRAWCURVE.PRESS is ever updated to handle dashing. - rrb - - 27-sept-85) - - (DRAWDASHEDLINE X1 Y1 X2 Y2 WIDTH OPERATION PRSTREAM COLOR DASHING)) - (T (\DRAWCURVE.PRESS PRSTREAM (LIST (CREATEPOSITION X1 Y1) - (CREATEPOSITION X2 Y2)) - NIL - (LIST 'BUTT WIDTH) - DASHING))) - Y2]) - -(\ENDPAGE.PRESS - [LAMBDA (PRSTREAM) (* ; "Edited 12-Jun-90 10:39 by mitani") - (PROG [(ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM] - (SHOW.PRESS PRSTREAM) - (\ENTITYEND.PRESS PRSTREAM) - (COND - ((NEQ 0 (\GETFILEPTR ELSTREAM)) - (COND - ((ODDP (\GETFILEPTR PRSTREAM)) - (\BOUT PRSTREAM 0))) - (\WOUT PRSTREAM 0) (* 0 word to separate DL from EL) - (COPYBYTES ELSTREAM PRSTREAM 0 (\GETFILEPTR ELSTREAM)) - (\PARTEND.PRESS PRSTREAM 0]) - -(NEWLINE.PRESS - [LAMBDA (PRSTREAM) (* ; "Edited 12-Jun-90 10:39 by mitani") - (* Go to next line - (or next page)) - (PROG (NEWYPOS (PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM))) - (SETQ NEWYPOS (IPLUS (ffetch PRYPOS of PRDATA) - (ffetch PRLINEFEED of PRDATA))) - (COND - ((ILESSP NEWYPOS (ffetch PRBOTTOM of PRDATA)) - (NEWPAGE.PRESS PRSTREAM)) - (T (SHOW.PRESS PRSTREAM) - (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA) - NEWYPOS]) - -(NEWPAGE.PRESS - [LAMBDA (PRSTREAM) (* rmk%: "16-Jun-84 14:29") - (\ENDPAGE.PRESS PRSTREAM) - (\STARTPAGE.PRESS PRSTREAM]) - -(SETUPFONTS.PRESS - [LAMBDA (PRSTREAM FONTS) (* ; "Edited 12-Jun-90 10:40 by mitani") - - (* Sets up fonts in the initial fontset. - and sets heading font. Leaves PRFONT as NIL. - This means that \DSPFONT.PRESS of the heading font will establish that as the - current font when the first page opens.) - - (for F FLG inside (OR FONTS DEFAULTFONT) do (SETQ F (FONTCREATE F NIL NIL NIL - 'PRESS)) - (COND - (FLG (\DEFINEFONT.PRESS PRSTREAM F) - ) - (T (\DSPFONT.PRESS PRSTREAM F) - (* Install first font as current - font and heading font. - font.) - (\ENTITYEND.PRESS PRSTREAM) - (replace PRHEADINGFONT - of (fetch (STREAM - IMAGEDATA - ) - of PRSTREAM) - with F) - (SETQ FLG T]) - -(\DEFINEFONT.PRESS - [LAMBDA (PRSTREAM FONT) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (RETURN (OR (FASSOC FONT (fetch PRESSFONTDIR of PRDATA)) - (CAR (push (fetch PRESSFONTDIR of PRDATA) - (PROG1 (create FONTDIRENTRY - DESCR _ FONT - FONT# _ (fetch PRNEXTFONT# of PRDATA) - FONTSET# _ (fetch PRMAXFONTSET of PRDATA)) - (COND - ((EQ 16 (add (fetch PRNEXTFONT# of PRDATA) - 1)) - (add (fetch PRMAXFONTSET of PRDATA) - 1) - (replace PRNEXTFONT# of PRDATA with 0))))]) - -(\DSPBOTTOMMARGIN.PRESS - [LAMBDA (PRSTREAM YPOSITION) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG1 (fetch PRBOTTOM of (fetch (STREAM IMAGEDATA) of PRSTREAM)) - (COND - (YPOSITION (replace PRBOTTOM of (fetch (STREAM IMAGEDATA) of PRSTREAM) - with YPOSITION))))]) - -(\DSPCLIPPINGREGION.PRESS - [LAMBDA (STREAM REGION) (* ; "Edited 12-Jun-90 10:40 by mitani") - (* sets the clipping region of a - PRESS stream.) - (PROG ((PRDATA (FETCH (STREAM IMAGEDATA) OF STREAM))) - (RETURN (PROG1 (ffetch PRClippingRegion of PRDATA) - [COND - (REGION (OR (type? REGION REGION) - (ERROR REGION " is not a REGION.")) - (UNINTERRUPTABLY - (freplace PRClippingRegion of PRDATA with REGION))])]) - -(\DSPFONT.PRESS - [LAMBDA (PRSTREAM FONT) (* ; "Edited 14-Jul-2025 22:58 by rmk") - (* ; "Edited 5-Jul-2025 18:49 by rmk") - -(* ;;; "The DSPFONT method for PRESS-type image streams -- change the stream's current font to FONT") - - (* * The DSPFONT method for PRESS-type image streams -- - change the stream's current font to FONT) - - (PROG ((PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM)) - CSINFO OLDFONT FDENTRY) - (SETQ OLDFONT (ffetch PRFONT of PRDATA)) - (COND - ([OR (NULL FONT) - (EQ OLDFONT (SETQ FONT (OR (FONTCREATE FONT NIL NIL NIL 'PRESS T) - (FONTCOPY OLDFONT FONT] - (* ; - "If no new font was specified, or it's the same font, don't bother with it.") - (RETURN OLDFONT))) - (SHOW.PRESS PRSTREAM) - (SETQ CSINFO (\GETCHARSETINFO 0 FONT T)) (* ; - "Since PRESS only uses charset 0 for now....") - (SETQ FDENTRY (\DEFINEFONT.PRESS PRSTREAM FONT)) - (COND - ((NEQ (ffetch FONTSET# of FDENTRY) - (ffetch FONTSET# of (ffetch PRCURRFDE of PRDATA))) - (* ; "Swtich font sets") - (\ENTITYEND.PRESS PRSTREAM) - (\ENTITYSTART.PRESS PRSTREAM))) - (freplace PRCURRFDE of PRDATA with FDENTRY) - (freplace PRFONT of PRDATA with FONT) - (\BOUT (ffetch ELSTREAM of PRDATA) - (LOGOR FontCode (ffetch FONT# of FDENTRY))) - (freplace PRWIDTHSCACHE of PRDATA with (fetch (CHARSETINFO WIDTHS) OF CSINFO)) - [\SETSPACE.PRESS PRSTREAM (FIXR (TIMES (ffetch PRSPACEFACTOR of PRDATA) - (\FGETWIDTH (ffetch PRWIDTHSCACHE of PRDATA) - (CHARCODE SPACE] - [freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS MicasPerPoint)) - (FONTPROP FONT 'HEIGHT] - (\FIXLINELENGTH.PRESS PRSTREAM) - (RETURN OLDFONT]) - -(\DSPLEFTMARGIN.PRESS - [LAMBDA (PRSTREAM XPOSITION) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG1 (ffetch PRLEFT of (ffetch (STREAM IMAGEDATA) of PRSTREAM)) - (COND - (XPOSITION (freplace PRLEFT of (ffetch (STREAM IMAGEDATA) of PRSTREAM) - with XPOSITION) - (\FIXLINELENGTH.PRESS PRSTREAM))))]) - -(\DSPLINEFEED.PRESS - [LAMBDA (PRSTREAM DELTAY) (* ; "Edited 12-Jun-90 10:40 by mitani") - (* sets the amount that a line feed - increases the y coordinate by.) - (PROG ((PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM))) - (RETURN (PROG1 (ffetch PRLINEFEED of PRDATA) - [AND DELTAY (COND - ((NUMBERP DELTAY) - (freplace PRLINEFEED of PRDATA with DELTAY)) - (T (\ILLEGAL.ARG DELTAY])]) - -(\DSPRIGHTMARGIN.PRESS - [LAMBDA (PRSTREAM XPOSITION) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG1 (ffetch PRRIGHT of (ffetch (STREAM IMAGEDATA) of PRSTREAM)) - (COND - (XPOSITION (freplace PRRIGHT of (ffetch (STREAM IMAGEDATA) of PRSTREAM) - with XPOSITION) - (\FIXLINELENGTH.PRESS PRSTREAM))))]) - -(\DSPSPACEFACTOR.PRESS - [LAMBDA (STREAM FACTOR) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG ((PRDATA (ffetch (STREAM IMAGEDATA) of STREAM))) - (RETURN (PROG1 (ffetch PRSPACEFACTOR of PRDATA) - [COND - (FACTOR (SHOW.PRESS STREAM) - (freplace PRSPACEFACTOR of PRDATA with FACTOR) - (\SETSPACE.PRESS STREAM - (FIXR (TIMES FACTOR (\FGETWIDTH (ffetch PRWIDTHSCACHE - of PRDATA) - (CHARCODE SPACE])]) - -(\DSPTOPMARGIN.PRESS - [LAMBDA (PRSTREAM YPOSITION) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG1 (fetch PRTOP of (fetch (STREAM IMAGEDATA) of PRSTREAM)) - (COND - (YPOSITION (replace PRTOP of (fetch (STREAM IMAGEDATA) of PRSTREAM) - with YPOSITION))))]) - -(\DSPXPOSITION.PRESS - [LAMBDA (PRSTREAM XPOSITION) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG1 (fetch PRXPOS of (fetch (STREAM IMAGEDATA) of PRSTREAM)) - (COND - (XPOSITION (SHOW.PRESS PRSTREAM) - (SETX.PRESS PRSTREAM XPOSITION))))]) - -(\DSPYPOSITION.PRESS - [LAMBDA (PRSTREAM YPOSITION) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG1 (fetch PRYPOS of (fetch (STREAM IMAGEDATA) of PRSTREAM)) - (COND - (YPOSITION (SHOW.PRESS PRSTREAM) - (SETY.PRESS PRSTREAM YPOSITION))))]) - -(\FIXLINELENGTH.PRESS - [LAMBDA (PRSTREAM) (* ; "Edited 12-Jun-90 10:40 by mitani") - - (* PRSTREAM is known to be a stream of type press. - Called by RIGHTMARGIN LEFTMARGIN and \DSPFONT.PRESS to update the LINELENGTH - field in the stream. also called when the stream is created.) - - (PROG (LLEN (PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM))) - (freplace (STREAM LINELENGTH) of PRSTREAM - with (COND - ((IGREATERP [SETQ LLEN (IQUOTIENT (IDIFFERENCE (ffetch PRRIGHT - of PRDATA) - (ffetch PRLEFT of PRDATA)) - (fetch FONTAVGCHARWIDTH - of (fetch PRFONT of PRDATA] - 1) - LLEN) - (T 10]) - -(\OUTCHARFN.PRESS - [LAMBDA (PRSTREAM CHARCODE) (* ; "Edited 12-Jun-90 10:40 by mitani") - (* Handle all the special-purpose - characters going to a PRESS file) - (SELCHARQ CHARCODE - (EOL (* New Line) - (NEWLINE.PRESS PRSTREAM) - (replace (STREAM CHARPOSITION) of PRSTREAM with 0)) - (LF (* Line feed--move down, but not - over) - (\DSPXPOSITION.PRESS PRSTREAM (PROG1 (DSPXPOSITION NIL PRSTREAM) - (NEWLINE.PRESS PRSTREAM)))) - (^L (* Form Feed) - (replace (STREAM CHARPOSITION) of PRSTREAM with 0) - (NEWPAGE.PRESS PRSTREAM)) - (PROG (XPOS NEWXPOS CLIPPINGREGION (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (SETQ XPOS (fetch PRXPOS of PRDATA)) - (SETQ CHARCODE (\PRESS.CONVERT.NSCHARACTER CHARCODE)) - [SETQ NEWXPOS (IPLUS XPOS (COND - ((EQ CHARCODE (CHARCODE SPACE)) - (ffetch PRSPACEWIDTH of PRDATA)) - (T (\FGETWIDTH (ffetch PRWIDTHSCACHE of PRDATA) - CHARCODE] - (COND - ((AND [IGEQ XPOS (fetch (REGION LEFT) of (SETQ CLIPPINGREGION - (fetch PRClippingRegion - of PRDATA] - (ILEQ NEWXPOS (fetch (REGION RIGHT) of CLIPPINGREGION)) - (IGEQ (fetch PRYPOS of PRDATA) - (fetch (REGION BOTTOM) of CLIPPINGREGION))) - (* Bottom test should really - subtract off the descent, and also - should do a top-test) - (* The Y-tests can probably be done - inside SETXY, SETY, and DSPFONT.) - [COND - ((NOT (ffetch CHARWASDISPLAYING of PRDATA)) - (* Was being clipped, now not) - (freplace CHARWASDISPLAYING of PRDATA with T) - (SHOW.PRESS PRSTREAM) (* SHOW shouldn't be necessary, but - |...|) - (SETXY.PRESS PRSTREAM XPOS (fetch PRYPOS of PRDATA] - (\BOUT PRSTREAM CHARCODE)) - (T (SHOW.PRESS PRSTREAM) (* Don't put out any characters if - out of the clipping region) - (freplace CHARWASDISPLAYING of PRDATA with NIL))) - (replace PRXPOS of PRDATA with NEWXPOS]) - -(\SETSPACE.PRESS - [LAMBDA (PRSTREAM S) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG (ELSTREAM (PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (AND (EQ S (ffetch PRSPACEWIDTH of PRDATA)) - (RETURN)) - (SETQ ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (if (ILEQ S 2047) - then (\WOUT ELSTREAM (IPLUS (LLSH SetSpaceXShortCode 8) - S)) - else (\BOUT ELSTREAM SetSpaceXCode) - (\WOUT ELSTREAM S)) - (freplace PRSPACEWIDTH of PRDATA with S]) - -(\STARTPAGE.PRESS - [LAMBDA (PRSTREAM) (* ; "Edited 12-Jun-90 10:40 by mitani") - (* Should be called only when no - previous page is open) - (PROG (CFONT HFONT SPACEFACTOR (PRDATA (ffetch (STREAM IMAGEDATA) of PRSTREAM))) - (SETQ CFONT (ffetch PRFONT of PRDATA)) - - (* Save current font so that \ENTITYSTART.PRESS can make PRFONT be NIL, - indicating that there is no actual font at the beginning of a page) - - (\ENTITYSTART.PRESS PRSTREAM) - [COND - ((ffetch PRHEADING of PRDATA) - (SETQ SPACEFACTOR (ffetch PRSPACEFACTOR of PRDATA)) - (freplace PRSPACEFACTOR of PRDATA with 1) - (SETQ HFONT (ffetch PRHEADINGFONT of PRDATA)) - (\DSPFONT.PRESS PRSTREAM HFONT) (* Set up heading font) - [SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA) - (IDIFFERENCE (ffetch PRTOP of PRDATA) - (FONTPROP HFONT 'ASCENT] - (PRIN3 (ffetch PRHEADING of PRDATA) - PRSTREAM) (* Skip an inch before page number) - (SHOW.PRESS PRSTREAM) - (SETX.PRESS PRSTREAM (IPLUS MICASPERINCH (ffetch PRXPOS of PRDATA))) - (PRIN3 "Page " PRSTREAM) - (PRIN3 (add (ffetch PRPAGENUM of PRDATA) - 1) - PRSTREAM) - (NEWLINE.PRESS PRSTREAM) (* Skip 2 lines) - (NEWLINE.PRESS PRSTREAM) - (freplace PRSPACEFACTOR of PRDATA with SPACEFACTOR)) - (T (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA) - (IDIFFERENCE (ffetch PRTOP of PRDATA) - (FONTPROP CFONT 'ASCENT] (* Now we set the font to our - (previous) current font) - (\DSPFONT.PRESS PRSTREAM CFONT]) - -(\STRINGWIDTH.PRESS - [LAMBDA (STREAM STRING RDTBL) (* ; "Edited 12-Jun-90 10:40 by mitani") - - (* * Returns the width of STRING in the press STREAM, observing spacefactor) - - (* * This is based on the code in \STRINGWIDTH.GENERIC) - - (PROG [(PRFONT (ffetch PRFONT of (ffetch (STREAM IMAGEDATA) of STREAM] - [COND - [(LITATOM STRING) (* It's an atom. Loop thru its - characters.) - (if RDTBL - then (GO SLOW) - else (* Only doing pname, much simpler - task) - (RETURN (LET ((WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) - of (\GETCHARSETINFO 0 PRFONT))) - CSET) - (for C inatom STRING - sum (SETQ C (\PRESS.CONVERT.NSCHARACTER C)) - (* CONVERT from NS characters back - to old PARC-internal coding for - PRESS fonts) - (COND - ((EQ C (CHARCODE SPACE)) - (ffetch PRSPACEWIDTH of (ffetch - (STREAM IMAGEDATA) - of STREAM))) - (T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C] - ((STRINGP STRING) (* It's a string; we know how to - loop thru its chars quickly) - (RETURN - (LET ((TOTAL 0) - (WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 PRFONT))) - ESCWIDTH ESC CSET) - [COND - (RDTBL (* Count delimiting quotes and - internal escapes) - (SETQ TOTAL (UNFOLD (\FGETWIDTH WIDTHSBASE (CHARCODE %")) - 2)) - (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL)) - (SETQ ESCWIDTH (\FGETWIDTH WIDTHSBASE ESC] - [for C instring STRING - do (SETQ C (\PRESS.CONVERT.NSCHARACTER C)) - (* CONVERT from NS characters back - to old PARC-internal coding for - PRESS fonts) - (add TOTAL (COND - ((EQ C (CHARCODE SPACE)) - (ffetch PRSPACEWIDTH of (ffetch - (STREAM IMAGEDATA) - of STREAM))) - (T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C)) - (COND - ((AND RDTBL (OR (EQ C (CHARCODE %")) - (EQ C ESC))) - (* String char must be escaped) - ESCWIDTH) - (T 0] - TOTAL] - SLOW - (RETURN (LET ((TOTALWIDTH 0) - (WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 PRFONT - ))) - CSET) - - (* * Neither atom nor string; we have to use \MAPPNAME to do the job.) - - (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC) - (SETQ CC (\PRESS.CONVERT.NSCHARACTER CC)) - (* Convert from NS characters back - to old PARC-internal coding for - PRESS fonts) - (add TOTALWIDTH (COND - ((EQ CC (CHARCODE SPACE)) - (ffetch PRSPACEWIDTH - of (ffetch - (STREAM IMAGEDATA) - of STREAM))) - (T (\FGETWIDTH WIDTHSBASE - (\CHAR8CODE CC] - STRING RDTBL RDTBL) - TOTALWIDTH]) - -(SHOWRECTANGLE.PRESS - [LAMBDA (PRSTREAM WIDTH HEIGHT) (* ; "Edited 12-Jun-90 10:40 by mitani") - (PROG [(ELSTREAM (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM] - (\BOUT ELSTREAM ShowRectangleCode) - (\WOUT ELSTREAM WIDTH) - (\WOUT ELSTREAM HEIGHT]) - -(\PRESS.CONVERT.NSCHARACTER - [LAMBDA (CHARCODE) (* jds " 4-Nov-85 08:02") - - (* Provide backward compatibility for extended-language characters in the PRESS - printing environment. Converts certain of the NS characters into their - equivalent PARC-internal charcodes) - - (SELCHARQ CHARCODE - (357,55 (* em quad) - 153) - (357,54 (* en quad) - 152) - (357,57 (* Thin space) - 159) - (357,44 (* en dash / figure dash) - 155) - (357,45 (* em dash) - 156) - (357,146 (* bullet) - 183) - (0,251 (* left single quote) - 96) - (0,271 (* right single quote) - 39) - (\CHAR8CODE CHARCODE]) -) - - - -(* ; "Drawcurve code") - -(DEFINEQ - -(\ENDVECRUN - [LAMBDA (PRSTREAM HALFVECWIDTH) (* ; "Edited 12-Jun-90 10:40 by mitani") - (SHOW.PRESS PRSTREAM) - (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)) - ORIGXPOS ORIGYPOS XPOS YPOS WASDISPLAYING ORIGWASDISPLAYING) - (COND - ((NOT (fetch VECMOVINGRIGHT of PRDATA)) - - (* We've been moving to the left, so it's time to uncache those characters we - saved.) - - (SETQ XPOS (fetch VECCURX of PRDATA)) - (SETQ YPOS (fetch VECCURY of PRDATA)) - (SETQ ORIGXPOS (FIXR (FTIMES MicasPerScan XPOS))) - (* Remember where the end of the - line is, so we can come back here.) - (SETQ ORIGYPOS (FIXR (FTIMES MicasPerScan YPOS))) - [SETQ ORIGWASDISPLAYING (AND (IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH)) - (IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH)) - (ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH - )) - (ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS - HALFVECWIDTH] - (SETQ WASDISPLAYING ORIGWASDISPLAYING) (* Decide whether to start out by - displaying any characters or not.) - (COND - (WASDISPLAYING (SETXY.PRESS PRSTREAM ORIGXPOS ORIGYPOS))) - - (* We may have been adjusting the X and Y position in the PRDATA without - actually putting out the file commands) - - [for CH in (fetch VECSEGCHARS of PRDATA) - do (COND - [(AND (IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH)) - (IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH)) - (ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH)) - (ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS HALFVECWIDTH))) - (* We're on-paper. - Go ahead and display the character.) - (COND - ((NOT WASDISPLAYING) (* We haven't really been displaying - characters up to now--we need to - reposition.) - (SHOW.PRESS PRSTREAM) - (SETXY.PRESS PRSTREAM (FIXR (FTIMES MicasPerScan XPOS)) - (FIXR (FTIMES MicasPerScan YPOS))) - (SETQ WASDISPLAYING T))) - (\BOUT PRSTREAM (\VECENCODE (IMINUS (CAR CH)) - (IMINUS (CDR CH] - (T (* We are off-paper. - Stop displaying, and remember that - we took a hiatus) - (SETQ WASDISPLAYING NIL))) - (SETQ XPOS (IDIFFERENCE XPOS (CAR CH))) - (SETQ YPOS (IDIFFERENCE YPOS (CDR CH] - (SHOW.PRESS PRSTREAM) - (SETXY.PRESS PRSTREAM ORIGXPOS ORIGYPOS) - (replace VECWASDISPLAYING of PRDATA with ORIGWASDISPLAYING))) - (replace VECSEGCHARS of PRDATA with NIL]) - -(\VECENCODE - [LAMBDA (DX DY) (* jds "18-DEC-81 15:48") - - (* Given dx and dy in dover pixels, decide which Vector Font character - represents that move, and return it.) - - (if (ILESSP 0 DY) - then (IDIFFERENCE (IPLUS 160 DX (IMINUS DY)) - (ITIMES 9 (IMAX DX DY))) - else (IDIFFERENCE (IDIFFERENCE (IDIFFERENCE 160 DX) - DY) - (ITIMES 7 (IMAX DX (IMINUS DY]) - -(\VECPUT - [LAMBDA (PRSTREAM DX DY HALFVECWIDTH) (* ; "Edited 12-Jun-90 10:40 by mitani") - - (* Send this dx,dy pair to the press file; - hold and reverse any strings which run right-to-left on the page.) - - (PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM)) - XPOS YPOS) - (COND - ((OR (AND (fetch VECMOVINGRIGHT of PRDATA) - (ILESSP DX 0)) - (AND (NOT (fetch VECMOVINGRIGHT of PRDATA)) - (ILESSP 0 DX))) - - (* We switched direction (LEFT->RIGHT or RIGHT->LEFT)%. - Put out what we've got, and start the new run.) - - (\ENDVECRUN PRSTREAM HALFVECWIDTH) - (replace VECMOVINGRIGHT of PRDATA with (NOT (fetch VECMOVINGRIGHT - of PRDATA))) - (* Switch the direction we think - we're moving.) - )) - (SETQ XPOS (fetch VECCURX of PRDATA)) (* In DOVER spots) - (SETQ YPOS (fetch VECCURY of PRDATA)) - (replace VECCURX of PRDATA with (IPLUS XPOS DX)) - (replace VECCURY of PRDATA with (IPLUS YPOS DY)) - (COND - [(fetch VECMOVINGRIGHT of PRDATA) (* We're moving right, and are - really putting out characters.) - (* SPRUCEPAPERTOPSCANS is in dover - points) - (COND - ((AND (IGEQ YPOS (IPLUS SPRUCEPAPERBOTTOMSCANS HALFVECWIDTH)) - (ILESSP YPOS (IDIFFERENCE SPRUCEPAPERTOPSCANS HALFVECWIDTH)) - (IGEQ XPOS (IPLUS SPRUCEPAPERLEFTSCANS HALFVECWIDTH)) - (ILESSP XPOS (IDIFFERENCE SPRUCEPAPERRIGHTSCANS HALFVECWIDTH))) - (* We're on-paper. - Go ahead and display this character.) - (COND - ((NOT (fetch VECWASDISPLAYING of PRDATA)) - (* We haven't been displaying. - before really putting out the - character,) - (SHOW.PRESS PRSTREAM) - (SETXY.PRESS PRSTREAM (FIXR (FTIMES MicasPerScan XPOS)) - (FIXR (FTIMES MicasPerScan YPOS))) - (* So move to where we're emerging - onto the paper.) - (replace VECWASDISPLAYING of PRDATA with T))) - (\BOUT PRSTREAM (\VECENCODE DX DY))) - (T (* We're off-page. - Remember to do a SETXY when we get - back on.) - (replace VECWASDISPLAYING of PRDATA with NIL] - (T - - (* We're moving left--and so caching characters for later. - Don't bother making any checks going this way.) - - (push (fetch VECSEGCHARS of PRDATA) - (CONS DX DY)) (* Just cache the DX,DY pair) - ]) - -(\VECSKIP - [LAMBDA (PRSTREAM DX DY) (* rmk%: "17-Dec-84 10:10") - (* Put out blank space for DX, DY) - (\ENDVECRUN PRSTREAM) - (SETQ VecCurX (IPLUS VecCurX DX)) - (SETQ VecCurY (IPLUS VecCurY DY)) - (\ENDVECRUN PRSTREAM]) - -(\VECFONTINIT - [LAMBDA NIL (* jds " 2-Jan-86 14:24") - - (* Initialize \VecFontDir, a list of lists of dummy font descriptors for the - ReDraw vector fonts. The structure is ((round brushes) - (square brushes) (horizontal brushes) (vertical brushes))) - - (DECLARE (GLOBALVARS \VecFontDir)) - - (* WIDTHS is a dummy array descriptor so that \DSPFONT.PRESS doesn't get - confused. If any real character output were done with this descriptor in force, - the results would be disastrous. But the RESETSAVE in \PRESSCURVE2 should - prevent this.) - - (* NOTE%: Perhaps we should just use the unit widths vector for this) - - (OR \VecFontDir (SETQ \VecFontDir - (BIND FD CSINFO for FMLY (WIDTHS _ (ARRAY 256 'SMALLP 1 0)) - in '(NEWVEC SNEWVEC HNEWVEC VNEWVEC) - collect (for BRUSH in '(4 8 16 32 64) - collect (SETQ FD (create FONTDESCRIPTOR - FONTDEVICE _ 'PRESS - FONTFAMILY _ FMLY - FONTSIZE _ BRUSH - FONTFACE _ '(MEDIUM REGULAR REGULAR) - ROTATION _ 0 - FONTAVGCHARWIDTH _ 1)) - (* Create a dummy font descriptor for - this dummy font) - (SETQ CSINFO (CREATE CHARSETINFO - WIDTHS _ (FETCH (ARRAYP BASE) - OF WIDTHS))) - - (* And a CHARSETINFO that claims the characters are all 0 wide) - - (\RPLPTR (FETCH (FONTDESCRIPTOR FONTCHARSETVECTOR) - OF FD) - 0 CSINFO) (* And Smash it into the charset - vector.) - - (* * Now collect the font descriptors for the directory) - - FD]) - -(\DRAWCIRCLE.PRESS - [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* rmk%: "27-Sep-84 17:23") - (PROG [(R2RAD (FIXR (FTIMES RADIUS (CONSTANT (FQUOTIENT (SQRT 2) - 2] - (DRAWCURVE (LIST (CREATEPOSITION (IPLUS CENTERX RADIUS) - CENTERY) - (CREATEPOSITION (IPLUS CENTERX R2RAD) - (IPLUS CENTERY R2RAD)) - (CREATEPOSITION CENTERX (IPLUS CENTERY RADIUS)) - (CREATEPOSITION (IDIFFERENCE CENTERX R2RAD) - (IPLUS CENTERY R2RAD)) - (CREATEPOSITION (IDIFFERENCE CENTERX RADIUS) - CENTERY) - (CREATEPOSITION (IDIFFERENCE CENTERX R2RAD) - (IDIFFERENCE CENTERY R2RAD)) - (CREATEPOSITION CENTERX (IDIFFERENCE CENTERY RADIUS)) - (CREATEPOSITION (IPLUS CENTERX R2RAD) - (IDIFFERENCE CENTERY R2RAD))) - T BRUSH DASHING STREAM)) - (MOVETO CENTERX CENTERY STREAM]) - -(\DRAWARC.PRESS - [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) - (* rrb " 4-Oct-85 17:27") - (* draws an arc on an press file) - (\DRAWARC.GENERIC STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING]) - -(\DRAWCURVE.PRESS - [LAMBDA (PRSTREAM KNOTS CLOSED BRUSH DASHING) (* rmk%: "20-Nov-84 13:59") - - (* draws a spline curve with a given brush brush. - Knots and brushwidth assumed to be in micas) - - [COND - ((LISTP KNOTS) - (SHOW.PRESS PRSTREAM) - (PROG [LASTKNOT (DASHLST (AND DASHING (OR (AND (LISTP DASHING) - (EVERY DASHING (FUNCTION FIXP)) - DASHING) - (\ILLEGAL.ARG DASHING] - - (* The above makes sure that DASHING is a list of numbers.) - - [OR (CDR KNOTS) - (SETQ KNOTS (LIST (CAR KNOTS) - (CAR KNOTS] (* Handle the trival one-knot case.) - (COND - ((AND (NULL DASHING) - (EQ 2 (LENGTH KNOTS)) - (\DRAWCURVE.PRESS.LINE PRSTREAM (fetch XCOORD of (CAR KNOTS)) - (fetch YCOORD of (CAR KNOTS)) - (fetch XCOORD of (CADR KNOTS)) - (fetch YCOORD of (CADR KNOTS)) - BRUSH DASHING)) - - (* There were only two knots, and no dashing. - \DRAWCURVE.PRESS.LINE returned T if it managed to draw the line the fast way.) - (* Have to move to the endpoint of the - line.) - ) - (T (* Otherwise, use the full-strength - curve drawer.) - (\PRESSCURVE2 PRSTREAM - (PARAMETRICSPLINE [for KNOT in KNOTS - collect (CREATEPOSITION (FIXR (FTIMES (fetch XCOORD - of KNOT) - ScansPerMica)) - (FIXR (FTIMES (fetch YCOORD - of KNOT) - ScansPerMica] - CLOSED) - DASHING - (\GETBRUSHFONT.PRESS BRUSH)) - - (* This already leaves the current position at the endpoint of the curve.) - - )) - (SETQ LASTKNOT (CAR (LAST KNOTS))) - (SETXY.PRESS PRSTREAM (fetch XCOORD of LASTKNOT) - (fetch YCOORD of LASTKNOT] - PRSTREAM]) - -(\DRAWCURVE.PRESS.LINE - [LAMBDA (PRSTREAM X1 Y1 X2 Y2 BRUSH DASHING) (* rmk%: "17-Dec-84 10:05") - - (* Returns T if this is a horizontal or vertical line, hence can be drawn as a - rectangle.) - - (PROG (WIDTH BACKOFF LEFT BOTTOM DIST LB TR (SHAPE 'ROUND)) - (SETQ WIDTH (OR (COND - ((LISTP BRUSH) - (SETQ SHAPE (CAR BRUSH)) - (CADR BRUSH)) - (T BRUSH)) - 1)) - [SELECTQ SHAPE - (BUTT (SETQ BACKOFF 0)) - (ROUND (RETURN NIL)) - (PROGN (SETQ BACKOFF (IQUOTIENT WIDTH 2] - - (* For butt ends, we want the line to end at the given coordinate position) - - (* LB is left or bottom, TR is top or right, depending on orientation) - - (COND - ((EQP X1 X2) (* Vertical line) - (SETQ LEFT (IDIFFERENCE X1 (IQUOTIENT WIDTH 2))) - (* Off to the left or right?) - (AND (OR (ILESSP LEFT SPRUCEPAPERLEFTMICAS) - (IGREATERP (IPLUS LEFT WIDTH) - SPRUCEPAPERRIGHTMICAS)) - (RETURN T)) - (COND - ((IGREATERP Y1 Y2) - (SETQ LB Y2) - (SETQ TR Y1)) - (T (SETQ LB Y1) - (SETQ TR Y2))) - (SETQ LB (IMAX SPRUCEPAPERBOTTOMMICAS (IDIFFERENCE LB BACKOFF))) - (* Clip to page) - (SETQ TR (IMIN SPRUCEPAPERTOPMICAS (IPLUS TR BACKOFF))) - (SETQ DIST (IDIFFERENCE TR LB)) - (OR (IGREATERP DIST 0) - (RETURN T)) - (SETXY.PRESS PRSTREAM LEFT LB) (* Move to where the line starts) - (SHOWRECTANGLE.PRESS PRSTREAM WIDTH DIST) (* Draw the rectangle that will do the - job.) - (RETURN T)) - ((EQP Y1 Y2) (* Horizontal line) - (SETQ BOTTOM (IDIFFERENCE Y1 (IQUOTIENT WIDTH 2))) - (* Off to the bottom or top?) - (AND (OR (ILESSP BOTTOM SPRUCEPAPERBOTTOMMICAS) - (IGREATERP (IPLUS BOTTOM WIDTH) - SPRUCEPAPERTOPMICAS)) - (RETURN T)) - (COND - ((IGREATERP X1 X2) - (SETQ LB X2) - (SETQ TR X1)) - (T (SETQ LB X1) - (SETQ TR X2))) - (SETQ LB (IMAX SPRUCEPAPERLEFTMICAS (IDIFFERENCE LB BACKOFF))) - (* Clip to page) - (SETQ TR (IMIN SPRUCEPAPERRIGHTMICAS (IPLUS TR BACKOFF))) - (SETQ DIST (IDIFFERENCE TR LB)) - (OR (IGREATERP DIST 0) - (RETURN T)) - (SETXY.PRESS PRSTREAM LB BOTTOM) (* Move to where the line starts) - (SHOWRECTANGLE.PRESS PRSTREAM DIST WIDTH) (* Draw the rectangle that will do the - job.) - (RETURN T]) - -(\DRAWELLIPSE.PRESS - [LAMBDA (PRSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) - (* rmk%: "23-Aug-84 10:51") - (PROG [(SINOR (COND - (ORIENTATION (SIN ORIENTATION)) - (T 0.0))) - (COSOR (COND - (ORIENTATION (COS ORIENTATION)) - (T 1.0] - (\DRAWCURVE.PRESS PRSTREAM [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 BRUSH DASHING) - (MOVETO CENTERX CENTERY PRSTREAM]) - -(\GETBRUSHFONT.PRESS - [LAMBDA (BRUSH) (* rmk%: "17-Dec-84 10:13") - (\VECFONTINIT) - (PROG [(LIST1 (SELECTQ (CAR (LISTP BRUSH)) - (ROUND (CAR \VecFontDir)) - (SQUARE (CADR \VecFontDir)) - (HORIZONTAL (CADDR \VecFontDir)) - (VERTICAL (CADDDR \VecFontDir)) - (BUTT (CAR \VecFontDir)) - (CAR \VecFontDir] - (AND (LISTP BRUSH) - (SETQ BRUSH (CADR BRUSH))) - (RETURN (SELECTQ (FIXR (FTIMES (OR BRUSH 1) - PointsPerMica)) - ((0 1) - (CAR LIST1)) - (2 (CADR LIST1)) - ((3 4 5) - (CADDR LIST1)) - ((6 7 8) - (CADDDR LIST1)) - (CADDDR LIST1]) - -(\PRESSCURVE2 - [LAMBDA (PRSTREAM SPLINE DASHING BRUSHFONT) (* ; "Edited 12-Jun-90 10:40 by mitani") - (* Given a spline curve and a font, - draw the lines to PRSTREAM) - (RESETLST - (RESETSAVE NIL (LIST 'DSPFONT (DSPFONT BRUSHFONT PRSTREAM) - PRSTREAM)) - [PROG ((PRDATA (fetch (STREAM IMAGEDATA) of PRSTREAM))) - (COND - ((IGREATERP (IDIFFERENCE (GETFILEPTR (fetch ELSTREAM of PRDATA)) - (fetch ELSTARTBYTE of PRDATA)) - 25000) - (\ENTITYEND.PRESS PRSTREAM) (* Hack to prevent mysterious - overflow in length of entities) - (\ENTITYSTART.PRESS PRSTREAM] - (\BOUT (fetch ELSTREAM of (fetch (STREAM IMAGEDATA) of PRSTREAM)) - ResetSpaceCode) - - (* because the space code shouldn't be interpreted specially when we are - drawing in the vector font) - - (PROG ((XPOLY (create POLYNOMIAL)) - (X'POLY (create POLYNOMIAL)) - (YPOLY (create POLYNOMIAL)) - (Y'POLY (create POLYNOMIAL)) - (X (fetch (SPLINE SPLINEX) of SPLINE)) - (Y (fetch (SPLINE SPLINEY) of SPLINE)) - (X' (fetch (SPLINE SPLINEDX) of SPLINE)) - (Y' (fetch (SPLINE SPLINEDY) of SPLINE)) - (X'' (fetch (SPLINE SPLINEDDX) of SPLINE)) - (Y'' (fetch (SPLINE SPLINEDDY) of SPLINE)) - (X''' (fetch (SPLINE SPLINEDDDX) of SPLINE)) - (Y''' (fetch (SPLINE SPLINEDDDY) of SPLINE)) - (%#KNOTS (fetch %#KNOTS of SPLINE)) - (X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) - 1)) - (Y0 (ELT (fetch (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 HALFVECWIDTH PUTDX EXTRADX PUTDY - EXTRADY) - (SETQ HALFVECWIDTH (FONTPROP BRUSHFONT 'SIZE)) - - (* Half the width of the brush, in dots. - Used to help decide when the line we're drawing goes off-paper.) - - (SETQ DASHON T) - - (* These are initialized outside the prog-bindings cause the compiler can't - hack so many initialized variables) - - (SETQ DASHLST DASHING) - (SETQ DASHCNT (CAR DASHING)) - (SETXY.PRESS PRSTREAM (FIXR (FTIMES X0 MicasPerScan)) - (FIXR (FTIMES Y0 MicasPerScan))) (* Move to the first knot on the - curve) - (replace VECMOVINGRIGHT of (fetch (STREAM IMAGEDATA) of PRSTREAM) - with T) (* Start by assuming we're moving in - increasing X (since the vector fonts - only have strokes that work in that - direction)) - (replace VECWASDISPLAYING of (fetch (STREAM IMAGEDATA) of PRSTREAM) - with (AND (GEQ X0 0) - (GEQ Y0 0))) - (replace VECSEGCHARS of (fetch (STREAM IMAGEDATA) of PRSTREAM) - with NIL) - (replace VECCURX of (fetch (STREAM IMAGEDATA) of PRSTREAM) with - X0) - (* And set the current X and Y - positions, denominated in dover - spots) - (replace VECCURY of (fetch (STREAM IMAGEDATA) of PRSTREAM) with - Y0) - (* Set up initial values in vec - variables, perform SetX/SetY.) - (SETQ TT 0.0) - (SETQ DELTA 16) - (SETQ IX (FIXR X0)) - (SETQ IY (FIXR Y0)) - [for KNOT# from 1 to (SUB1 %#KNOTS) - do (LOADPOLY XPOLY X'POLY (ELT X''' KNOT#) - (ELT X'' KNOT#) - (ELT X' KNOT#) - (ELT X KNOT#)) (* Set up the polynomials that - describe X and X' over this segment) - (LOADPOLY YPOLY Y'POLY (ELT Y''' KNOT#) - (ELT Y'' KNOT#) - (ELT Y' KNOT#) - (ELT Y KNOT#)) (* Set up the polynomials that - describe Y and Y' over this segment) - (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.0 up to |1.0.| - That moves the X and Y locations smoothly from this knot to the next one.) - - (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) (* Never let X' really get to 0.0 -- - things become ill-conditioned there.) - (SETQ X'T 5.0E-4))) - (COND - ((EQP Y'T 0.0) (* Likewise Y'.) - (SETQ Y'T 5.0E-4))) - [COND - ((FGTP X'T 0.0) (* If X' is positive, we'll try - moving in the +X direction) - (SETQ DX DELTA)) - (T (* If not, we'll try the -X - direction.) - (SETQ DX (IMINUS DELTA] - [COND - ((FGTP Y'T 0.0) (* Likewise, if Y' is positive, try - moving by DELTA in the +Y direction) - (SETQ DY DELTA)) - (T (SETQ DY (IMINUS DELTA] - (SETQ XWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IX DX) - XT) - X'T)) (* Compute a dT, based on moving by - DELTA in X.) - (SETQ YWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IY DY) - YT) - Y'T)) (* And a dT based on moving by DELTA - in Y.) - [COND - ((FLESSP XWALLDT YWALLDT) - - (* Use the smaller of the two dT's. In this case, dT for X was smaller, so - compute a new DY as depending on DX.) - - (SETQ NEWT (FPLUS TT XWALLDT)) - (SETQ DY (IDIFFERENCE (FIXR (FPLUS YT (FTIMES XWALLDT Y'T))) - IY))) - (T - - (* Changing Y gave the smaller dT. Compute a new DX, as though it depended on - DY.) - - (SETQ NEWT (FPLUS TT YWALLDT)) - (SETQ DX (IDIFFERENCE (FIXR (FPLUS XT (FTIMES YWALLDT X'T))) - IX] - (SETQ PUTDX DX) - (SETQ EXTRADX 0) - (SETQ PUTDY DY) - (SETQ EXTRADY 0) - [COND - ((IGREATERP DX 16) - (SETQ PUTDX 16) - (SETQ EXTRADX (IDIFFERENCE DX 16] - [COND - ((IGREATERP -16 DX) - (SETQ PUTDX -16) - (SETQ EXTRADX (IPLUS DX 16] - [COND - ((IGREATERP DY 16) - (SETQ PUTDY 16) - (SETQ EXTRADY (IDIFFERENCE DY 16] - [COND - ((IGREATERP -16 DY) - (SETQ PUTDY -16) - (SETQ EXTRADY (IPLUS DY 16] - (COND - ([AND (FGTP NEWT 1.0) - (OR DUPLICATEKNOT (EQ KNOT# (SUB1 %#KNOTS] - (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))) - (SETQ YDIFF (ABS (FDIFFERENCE (IPLUS IY DY) - NEWYT))) - (COND - ((AND (IGREATERP DELTA 1) - (OR (FGTP XDIFF 1.0) - (FGTP YDIFF 1.0))) - - (* If we're more than a dover spot off where we'd expect to be because of the - size of DELTA--and if there's room to make DELTA smaller--then try - DELTA_DELTA/2) - - (SETQ DELTA (LRSH DELTA 1))) - (T - - (* No, this estimate is close enough. Put out a vector segment based on it, and - move to the new TT.) - - (\VECPUT PRSTREAM PUTDX PUTDY HALFVECWIDTH) - (* Print out a stroke using the - vector font.) - (COND - ((OR (NEQ EXTRADX 0) - (NEQ EXTRADY 0)) - (* If, actually, it was too big for - one stroke, use another.) - (\VECPUT PRSTREAM EXTRADX EXTRADY HALFVECWIDTH))) - (SETQ IX (IPLUS IX DX))(* Our new current location, in - Dover spots) - (SETQ IY (IPLUS IY DY)) - (SETQ TT NEWT) (* Set TT to its new value) - (SETQ XT NEWXT) (* And set the new floating-point - values for X (t) and Y - (t)%.) - (SETQ YT NEWYT) - (COND - ((AND (ILESSP DELTA 16) - (OR (FLESSP XDIFF 0.5) - (FLESSP YDIFF 0.5))) - (* If we were especially close, try - making DELTA larger for the next go - round.) - (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] - (\ENDVECRUN PRSTREAM HALFVECWIDTH)))]) -) - -(RPAQ? \VecFontDir ) -(DECLARE%: EVAL@COMPILE - -(RPAQQ \MicasPerInch 2540) - - -(CONSTANTS (\MicasPerInch 2540)) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ ScansPerIn 384) - -(RPAQQ PointsPerIn 72.27) - -(RPAQ MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn)) - -(RPAQ ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch)) - -(RPAQ ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn)) - -(RPAQ PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn)) - -(RPAQ MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn)) - -(RPAQ PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch)) - -(RPAQQ SPRUCEPAPERTOPSCANS 4096) - -(RPAQ SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES SPRUCEPAPERTOPSCANS \MicasPerInch) - ScansPerIn))) - -(RPAQ SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch))) - -(RPAQ SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn))) - -(RPAQQ SPRUCEPAPERBOTTOMSCANS 0) - -(RPAQQ SPRUCEPAPERBOTTOMMICAS 0) - -(RPAQQ SPRUCEPAPERLEFTSCANS 0) - -(RPAQQ SPRUCEPAPERLEFTMICAS 0) - - -(CONSTANTS (ScansPerIn 384) - (PointsPerIn 72.27) - (MicasPerScan (FQUOTIENT \MicasPerInch ScansPerIn)) - (ScansPerMica (FQUOTIENT ScansPerIn \MicasPerInch)) - (ScansPerPoint (FQUOTIENT ScansPerIn PointsPerIn)) - (PointsPerScan (FQUOTIENT PointsPerIn ScansPerIn)) - (MicasPerPoint (FQUOTIENT \MicasPerInch PointsPerIn)) - (PointsPerMica (FQUOTIENT PointsPerIn \MicasPerInch)) - (SPRUCEPAPERTOPSCANS 4096) - (SPRUCEPAPERTOPMICAS (FIX (FQUOTIENT (FTIMES SPRUCEPAPERTOPSCANS \MicasPerInch) - ScansPerIn))) - (SPRUCEPAPERRIGHTMICAS (FIX (FTIMES 8.5 \MicasPerInch))) - (SPRUCEPAPERRIGHTSCANS (FIX (FTIMES 8.5 ScansPerIn))) - (SPRUCEPAPERBOTTOMSCANS 0) - (SPRUCEPAPERBOTTOMMICAS 0) - (SPRUCEPAPERLEFTSCANS 0) - (SPRUCEPAPERLEFTMICAS 0)) -) -) - - - -(* ;; "Initialization code") - -(DEFINEQ - -(\PRESSINIT - [LAMBDA NIL (* rrb " 4-Oct-85 17:27") - (DECLARE (GLOBALVARS \PRESSIMAGEOPS)) - (SETQ \PRESSIMAGEOPS (create IMAGEOPS - IMAGETYPE _ 'PRESS - IMCLOSEFN _ (FUNCTION \CLOSEF.PRESS) - IMXPOSITION _ (FUNCTION \DSPXPOSITION.PRESS) - IMYPOSITION _ (FUNCTION \DSPYPOSITION.PRESS) - IMFONT _ (FUNCTION \DSPFONT.PRESS) - IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.PRESS) - IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.PRESS) - IMLINEFEED _ (FUNCTION \DSPLINEFEED.PRESS) - IMDRAWLINE _ (FUNCTION \DRAWLINE.PRESS) - IMDRAWCURVE _ (FUNCTION \DRAWCURVE.PRESS) - IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.PRESS) - IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.PRESS) - IMFILLCIRCLE _ [FUNCTION (LAMBDA (STREAM) - (\UNIMPIMAGEOP STREAM 'FILLCIRCLE] - IMBLTSHADE _ (FUNCTION \BLTSHADE.PRESS) - IMBITBLT _ (FUNCTION \BITBLT.PRESS) - IMSCALE _ [FUNCTION (LAMBDA NIL - (CONSTANT (FQUOTIENT MICASPERINCH 72] - IMTERPRI _ (FUNCTION NEWLINE.PRESS) - IMBOTTOMMARGIN _ (FUNCTION \DSPBOTTOMMARGIN.PRESS) - IMTOPMARGIN _ (FUNCTION \DSPTOPMARGIN.PRESS) - IMFONTCREATE _ 'PRESS - IMNEWPAGE _ (FUNCTION NEWPAGE.PRESS) - IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.PRESS) - IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.PRESS) - IMCHARWIDTH _ (FUNCTION \CHARWIDTH.PRESS) - IMBITMAPSIZE _ (FUNCTION \BITMAPSIZE.PRESS) - IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.PRESS) - IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.PRESS) - IMDRAWARC _ (FUNCTION \DRAWARC.PRESS]) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(\PRESSINIT) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(DATATYPE PRESSDATA (PRHEADING (* ; - "The string to be printed atop each page.") - PRHEADINGFONT (* ; "Font to print the heading in") - PRXPOS (* ; "Current X position") - PRYPOS (* ; "Current Y position") - PRFONT (* ; "Current font") - PRCURRFDE PRESSFONTDIR (PRWIDTHSCACHE POINTER - (* ; - "Widths table for the current logical character set") - ) - PRCOLOR PRLINEFEED PRPAGESTATE PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME - (PRLEFT WORD) (* ; "Page left margin") - (PRBOTTOM WORD) (* ; "Page bottom margin") - (PRRIGHT WORD) (* ; "Page right margin") - (PRTOP WORD) (* ; "Page top margin") - (PRPAGENUM WORD) (* ; "Current Page number") - (PRNEXTFONT# BYTE) - (PRMAXFONTSET BYTE) - (PRPARTSTART INTEGER) - (DLSTARTBYTE INTEGER) - (ELSTARTBYTE INTEGER) - (STARTCHARBYTE INTEGER) - (VECMOVINGRIGHT FLAG) (* ; - "If we're drawing a curve with vector fonts, are we moving to the right?") - (VECWASDISPLAYING FLAG) - - (* ;; "Used during curve/line clipping to remember whether we were on-screen or not, so we know when to force a SETXY.") - - VECSEGCHARS (* ; - "Cache for vector characters while we're moving to the left.") - VECCURX (* ; - "Current X position within vector code, in Dover spots") - VECCURY (* ; - "Current Y position with vector code, in Dover spots") - PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG) - (* ; - "Says whether we have been printing characters inside the clipping region") - PRClippingRegion - - (* ;; "The edges of the paper, as far as PRESS is concerned. Used to protect SPRUCE users who get killed when the image goes off-paper") - - PRLOGICALFONT (* ; "Current logical font") - PRLOGICALCHARSET (* ; - "Current logical character set, whose info is cached. NIL if cache is invalid") - (PRTRANSLATIONCACHE POINTER (* ; - "Translation table for the current logical character set") - )) - PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0 (* ; - "We assume that the origin is translated to the bottom-left of the page region") - PRClippingRegion _ (create REGION - LEFT _ SPRUCEPAPERLEFTMICAS - BOTTOM _ SPRUCEPAPERBOTTOMMICAS - WIDTH _ (DIFFERENCE SPRUCEPAPERRIGHTMICAS - SPRUCEPAPERLEFTMICAS) - HEIGHT _ 29210) - [ACCESSFNS ((PRWIDTH (IDIFFERENCE (fetch (PRESSDATA PRRIGHT) of DATUM) - (fetch (PRESSDATA PRLEFT) of DATUM))) - (PRHEIGHT (IDIFFERENCE (fetch (PRESSDATA PRTOP) of DATUM) - (fetch (PRESSDATA PRBOTTOM) of DATUM))) - (PRPAGEREGION (fetch (PRESSDATA XPRPAGEREGION) of DATUM) - (PROGN (replace (PRESSDATA XPRPAGEREGION) of DATUM - with NEWVALUE) - (replace (PRESSDATA PRLEFT) of DATUM - with (fetch (REGION LEFT) of NEWVALUE)) - (replace (PRESSDATA PRBOTTOM) of DATUM - with (fetch (REGION BOTTOM) of NEWVALUE)) - (replace (PRESSDATA PRRIGHT) of DATUM - with (IPLUS (fetch (REGION LEFT) of NEWVALUE) - (fetch (REGION WIDTH) of NEWVALUE))) - (replace (PRESSDATA PRTOP) of DATUM - with (IPLUS (fetch (REGION BOTTOM) of NEWVALUE) - (fetch (REGION HEIGHT) of NEWVALUE]) - -(RECORD FONTDIRENTRY (DESCR FONT# FONTSET#)) -) - -(/DECLAREDATATYPE 'PRESSDATA - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP - FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER - ) - '((PRESSDATA 0 POINTER) - (PRESSDATA 2 POINTER) - (PRESSDATA 4 POINTER) - (PRESSDATA 6 POINTER) - (PRESSDATA 8 POINTER) - (PRESSDATA 10 POINTER) - (PRESSDATA 12 POINTER) - (PRESSDATA 14 POINTER) - (PRESSDATA 16 POINTER) - (PRESSDATA 18 POINTER) - (PRESSDATA 20 POINTER) - (PRESSDATA 22 POINTER) - (PRESSDATA 24 POINTER) - (PRESSDATA 26 POINTER) - (PRESSDATA 28 POINTER) - (PRESSDATA 30 (BITS . 15)) - (PRESSDATA 31 (BITS . 15)) - (PRESSDATA 32 (BITS . 15)) - (PRESSDATA 33 (BITS . 15)) - (PRESSDATA 34 (BITS . 15)) - (PRESSDATA 35 (BITS . 7)) - (PRESSDATA 35 (BITS . 135)) - (PRESSDATA 36 FIXP) - (PRESSDATA 38 FIXP) - (PRESSDATA 40 FIXP) - (PRESSDATA 42 FIXP) - (PRESSDATA 28 (FLAGBITS . 0)) - (PRESSDATA 28 (FLAGBITS . 16)) - (PRESSDATA 44 POINTER) - (PRESSDATA 46 POINTER) - (PRESSDATA 48 POINTER) - (PRESSDATA 50 POINTER) - (PRESSDATA 52 POINTER) - (PRESSDATA 52 (FLAGBITS . 0)) - (PRESSDATA 54 POINTER) - (PRESSDATA 56 POINTER) - (PRESSDATA 58 POINTER) - (PRESSDATA 60 POINTER)) - '62) -) - -(/DECLAREDATATYPE 'PRESSDATA - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP - FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER - ) - '((PRESSDATA 0 POINTER) - (PRESSDATA 2 POINTER) - (PRESSDATA 4 POINTER) - (PRESSDATA 6 POINTER) - (PRESSDATA 8 POINTER) - (PRESSDATA 10 POINTER) - (PRESSDATA 12 POINTER) - (PRESSDATA 14 POINTER) - (PRESSDATA 16 POINTER) - (PRESSDATA 18 POINTER) - (PRESSDATA 20 POINTER) - (PRESSDATA 22 POINTER) - (PRESSDATA 24 POINTER) - (PRESSDATA 26 POINTER) - (PRESSDATA 28 POINTER) - (PRESSDATA 30 (BITS . 15)) - (PRESSDATA 31 (BITS . 15)) - (PRESSDATA 32 (BITS . 15)) - (PRESSDATA 33 (BITS . 15)) - (PRESSDATA 34 (BITS . 15)) - (PRESSDATA 35 (BITS . 7)) - (PRESSDATA 35 (BITS . 135)) - (PRESSDATA 36 FIXP) - (PRESSDATA 38 FIXP) - (PRESSDATA 40 FIXP) - (PRESSDATA 42 FIXP) - (PRESSDATA 28 (FLAGBITS . 0)) - (PRESSDATA 28 (FLAGBITS . 16)) - (PRESSDATA 44 POINTER) - (PRESSDATA 46 POINTER) - (PRESSDATA 48 POINTER) - (PRESSDATA 50 POINTER) - (PRESSDATA 52 POINTER) - (PRESSDATA 52 (FLAGBITS . 0)) - (PRESSDATA 54 POINTER) - (PRESSDATA 56 POINTER) - (PRESSDATA 58 POINTER) - (PRESSDATA 60 POINTER)) - '62) - -(RPAQ? DEFAULTPAGEREGION (CREATEREGION 2794 1905 16256 24765)) - -(RPAQ? PRESSBITMAPREGION (CREATEREGION 1270 1270 (FIX (TIMES 7.5 \MicasPerInch)) - (TIMES 10 \MicasPerInch))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS DEFAULTPAGEREGION) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ BYTESPERRECORD 512) - -(RPAQQ LISPENTITYTYPE 6) - -(RPAQ MICASPERINCH \MicasPerInch) - - -(CONSTANTS (BYTESPERRECORD 512) - (LISPENTITYTYPE 6) - (MICASPERINCH \MicasPerInch)) -) - - - -(RPAQQ PRESSOPS - (SetX SetY ShowCharacters ShowCharactersShortCode SkipCharactersShortCode - ShowCharactersAndSkipCode SetSpaceXShortCode SetSpaceYShortCode FontCode - SkipControlBytesImmediateCode AlternativeCode OnlyOnCopyCode SetXCode SetYCode - ShowCharactersCode SkipCharactersCode SkipControlBytesCode ShowCharacterImmediateCode - SetSpaceXCode SetSpaceYCode ResetSpaceCode SpaceCode SetBrightnessCode SetHueCode - SetSaturationCode ShowObjectCode ShowDotsCode ShowDotsOpaqueCode ShowRectangleCode - NopCode)) -(DECLARE%: EVAL@COMPILE - -(RPAQQ SetX 0) - -(RPAQQ SetY 1) - -(RPAQQ ShowCharacters 2) - -(RPAQQ ShowCharactersShortCode 0) - -(RPAQQ SkipCharactersShortCode 40Q) - -(RPAQQ ShowCharactersAndSkipCode 100Q) - -(RPAQQ SetSpaceXShortCode 140Q) - -(RPAQQ SetSpaceYShortCode 150Q) - -(RPAQQ FontCode 160Q) - -(RPAQQ SkipControlBytesImmediateCode 353Q) - -(RPAQQ AlternativeCode 354Q) - -(RPAQQ OnlyOnCopyCode 355Q) - -(RPAQQ SetXCode 356Q) - -(RPAQQ SetYCode 357Q) - -(RPAQQ ShowCharactersCode 360Q) - -(RPAQQ SkipCharactersCode 361Q) - -(RPAQQ SkipControlBytesCode 362Q) - -(RPAQQ ShowCharacterImmediateCode 363Q) - -(RPAQQ SetSpaceXCode 364Q) - -(RPAQQ SetSpaceYCode 365Q) - -(RPAQQ ResetSpaceCode 366Q) - -(RPAQQ SpaceCode 367Q) - -(RPAQQ SetBrightnessCode 370Q) - -(RPAQQ SetHueCode 371Q) - -(RPAQQ SetSaturationCode 372Q) - -(RPAQQ ShowObjectCode 373Q) - -(RPAQQ ShowDotsCode 374Q) - -(RPAQQ ShowDotsOpaqueCode 375Q) - -(RPAQQ ShowRectangleCode 376Q) - -(RPAQQ NopCode 377Q) - - -(CONSTANTS SetX SetY ShowCharacters ShowCharactersShortCode SkipCharactersShortCode - ShowCharactersAndSkipCode SetSpaceXShortCode SetSpaceYShortCode FontCode - SkipControlBytesImmediateCode AlternativeCode OnlyOnCopyCode SetXCode SetYCode - ShowCharactersCode SkipCharactersCode SkipControlBytesCode ShowCharacterImmediateCode - SetSpaceXCode SetSpaceYCode ResetSpaceCode SpaceCode SetBrightnessCode SetHueCode - SetSaturationCode ShowObjectCode ShowDotsCode ShowDotsOpaqueCode ShowRectangleCode NopCode) -) -) - - - -(* ;; "Hardcopy user interface connections:") - -(DEFINEQ - -(MAKEPRESS - [LAMBDA (FILE PFILE FONTS HEADING TABS PRINTOPTIONS) (* ; "Edited 26-Aug-87 13:57 by Snow") - - (TEXTTOIMAGEFILE FILE PFILE 'PRESS FONTS HEADING TABS PRINTOPTIONS]) - -(PRESSFILEP - [LAMBDA (FILE) (* ; "Edited 20-Feb-87 18:41 by jds") - - (* ;; "Returns FILE if it looks like a Press file") - - (AND (SETQ FILE (OR (STREAMP FILE) - (FINDFILE FILE))) - (PROG [(LEN (GETFILEINFO FILE 'LENGTH] - (AND (NOT (ZEROP LEN)) - (EVENP LEN BYTESPERRECORD) - (RESETLST [COND - (T (RESETSAVE (SETQ PRESS-STREAM (OPENSTREAM FILE 'INPUT - 'OLD 10Q)) - '(PROGN (CLOSEF? OLDVALUE] - (SETFILEPTR PRESS-STREAM (IDIFFERENCE LEN BYTESPERRECORD)) - (IEQP 65057Q (\WIN PRESS-STREAM))) - (RETURN FILE]) - -(PRESS.BITMAPSCALE - [LAMBDA (WIDTH HEIGHT) (* ; "Edited 12-Jun-90 10:38 by mitani") - (MIN (FQUOTIENT (TIMES (fetch (REGION HEIGHT) of PRESSBITMAPREGION) - PointsPerMica) - HEIGHT) - (FQUOTIENT (TIMES (fetch (REGION WIDTH) of PRESSBITMAPREGION) - PointsPerMica) - WIDTH) - (PROG1 2 (* MAXPRESSRATIO)]) -) - -(ADDTOVAR IMAGESTREAMTYPES (PRESS (OPENSTREAM OPENPRSTREAM) - (FONTCREATE \CREATEPRESSFONT) - (CREATECHARSET \CREATECHARSET.PRESS) - (FONTSAVAILABLE \SEARCHPRESSFONTS))) - -(ADDTOVAR PRINTERTYPES - ((PRESS SPRUCE PENGUIN DOVER) - (CANPRINT (PRESS)) - (STATUS PUP.PRINTER.STATUS) - (PROPERTIES PUP.PRINTER.PROPERTIES) - (SEND EFTP) - (BITMAPSCALE NIL) - (BITMAPFILE (PRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE))) - ((FULLPRESS RAVEN) - (* ; - "same as PRESS but can scale bitmaps") - (CANPRINT (PRESS)) - (STATUS TRUE) - (PROPERTIES NILL) - (SEND EFTP) - (BITMAPSCALE PRESS.BITMAPSCALE) - (BITMAPFILE (FULLPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) - -(ADDTOVAR PRINTFILETYPES - [PRESS (TEST PRESSFILEP) - (EXTENSION (PRESS)) - (CONVERSION (TEXT MAKEPRESS TEDIT (LAMBDA (FILE PFILE FONTS HEADING) - (SETQ FILE (OPENTEXTSTREAM FILE)) - (TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL NIL - NIL 'PRESS) - (CLOSEF? FILE) - PFILE]) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (15566Q 72545Q (\SEARCHPRESSFONTS 15600Q . 17535Q) (\GETPRESSFONTNAMES 17537Q . 26375Q) -(\PRESSFAMILYCODELST 26377Q . 30321Q) (\DECODEPRESSFACEBYTE 30323Q . 33112Q) (\CREATEPRESSFONT 33114Q - . 35361Q) (\CREATECHARSET.PRESS 35363Q . 72543Q)) (73202Q 127005Q (PRESSBITMAP 73214Q . 102616Q) ( -FULLPRESSBITMAP 102620Q . 110632Q) (SHOWREGION 110634Q . 112176Q) (SHOWPRESSBITMAPREGION 112200Q . -112642Q) (PRESSWINDOW 112644Q . 117003Q) (\WRITEPRESSBITMAP 117005Q . 127003Q)) (127103Q 156756Q ( -\BCPLSOUT.PRESS 127115Q . 130072Q) (\PAGEPAD.PRESS 130074Q . 131331Q) (\ENTITYEND.PRESS 131333Q . -136627Q) (\PARTEND.PRESS 136631Q . 141216Q) (\ENTITYSTART.PRESS 141220Q . 144631Q) (SETX.PRESS 144633Q - . 146466Q) (SETXY.PRESS 146470Q . 151472Q) (SETY.PRESS 151474Q . 153074Q) (SHOW.PRESS 153076Q . -156754Q)) (157040Q 273644Q (OPENPRSTREAM 157052Q . 164201Q) (\BITBLT.PRESS 164203Q . 166615Q) ( -\BLTSHADE.PRESS 166617Q . 170252Q) (\SCALEDBITBLT.PRESS 170254Q . 172700Q) (\BITMAPSIZE.PRESS 172702Q - . 173642Q) (\CHARWIDTH.PRESS 173644Q . 175713Q) (\CLOSEF.PRESS 175715Q . 205704Q) (\DRAWLINE.PRESS -205706Q . 207244Q) (\ENDPAGE.PRESS 207246Q . 210516Q) (NEWLINE.PRESS 210520Q . 212131Q) (NEWPAGE.PRESS - 212133Q . 212425Q) (SETUPFONTS.PRESS 212427Q . 216160Q) (\DEFINEFONT.PRESS 216162Q . 220304Q) ( -\DSPBOTTOMMARGIN.PRESS 220306Q . 221102Q) (\DSPCLIPPINGREGION.PRESS 221104Q . 222476Q) (\DSPFONT.PRESS - 222500Q . 227461Q) (\DSPLEFTMARGIN.PRESS 227463Q . 230343Q) (\DSPLINEFEED.PRESS 230345Q . 231655Q) ( -\DSPRIGHTMARGIN.PRESS 231657Q . 232542Q) (\DSPSPACEFACTOR.PRESS 232544Q . 234150Q) ( -\DSPTOPMARGIN.PRESS 234152Q . 234735Q) (\DSPXPOSITION.PRESS 234737Q . 235455Q) (\DSPYPOSITION.PRESS -235457Q . 236175Q) (\FIXLINELENGTH.PRESS 236177Q . 240274Q) (\OUTCHARFN.PRESS 240276Q . 247332Q) ( -\SETSPACE.PRESS 247334Q . 250630Q) (\STARTPAGE.PRESS 250632Q . 255173Q) (\STRINGWIDTH.PRESS 255175Q . -270553Q) (SHOWRECTANGLE.PRESS 270555Q . 271276Q) (\PRESS.CONVERT.NSCHARACTER 271300Q . 273642Q)) ( -273704Q 404746Q (\ENDVECRUN 273716Q . 303534Q) (\VECENCODE 303536Q . 304565Q) (\VECPUT 304567Q . -314215Q) (\VECSKIP 314217Q . 314752Q) (\VECFONTINIT 314754Q . 322077Q) (\DRAWCIRCLE.PRESS 322101Q . -324404Q) (\DRAWARC.PRESS 324406Q . 325177Q) (\DRAWCURVE.PRESS 325201Q . 333137Q) ( -\DRAWCURVE.PRESS.LINE 333141Q . 342006Q) (\DRAWELLIPSE.PRESS 342010Q . 345567Q) (\GETBRUSHFONT.PRESS -345571Q . 347473Q) (\PRESSCURVE2 347475Q . 404744Q)) (410600Q 415424Q (\PRESSINIT 410612Q . 415422Q)) -(444757Q 450046Q (MAKEPRESS 444771Q . 445275Q) (PRESSFILEP 445277Q . 447054Q) (PRESS.BITMAPSCALE -447056Q . 450044Q))))) -STOP diff --git a/obsolete/library/PRESS.LCOM b/obsolete/library/PRESS.LCOM deleted file mode 100644 index 5887ff08..00000000 Binary files a/obsolete/library/PRESS.LCOM and /dev/null differ diff --git a/obsolete/library/Press.tedit b/obsolete/library/Press.tedit deleted file mode 100644 index 93ad4833..00000000 Binary files a/obsolete/library/Press.tedit and /dev/null differ diff --git a/obsolete/library/TABLEBROWSERDECLS b/obsolete/library/TABLEBROWSERDECLS deleted file mode 100644 index 752883ae..00000000 --- a/obsolete/library/TABLEBROWSERDECLS +++ /dev/null @@ -1,137 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "26-Jun-99 00:30:01" {DSK}medley3.5>library>TABLEBROWSERDECLS.;2 7377 - - changes to%: (RECORDS TABLEBROWSER TABLEITEM) - - previous date%: "20-Jan-93 14:52:38" {DSK}medley3.5>library>TABLEBROWSERDECLS.;1) - - -(* ; " -Copyright (c) 1985, 1988, 1990, 1993, 1999 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TABLEBROWSERDECLSCOMS) - -(RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) - (CONSTANTS TB.LEFT.MARGIN))) -(DECLARE%: EVAL@COMPILE - -(DATATYPE TABLEBROWSER ((TBREADY FLAG) - (TBHEIGHTEXPLICIT FLAG) (* ; - "True if creator set explicit item height or baseline") - (TBITEMS POINTER) (* ; "List of items in this browser") - (TB#ITEMS WORD) (* ; "Number of items") - (TB#DELETED WORD) (* ; "Number of items marked deleted") - (TB#LINESPERITEM WORD) (* ; - "Number of lines occupied by each item, normally 1 (dunno if any other values work)") - (TBFIRSTSELECTEDITEM WORD) (* ; - "Number of first selected item. If none selected, is > TB#ITEMS") - (TBLASTSELECTEDITEM WORD) (* ; - "Number of last selected item. If none selected, is 0") - (TBITEMHEIGHT WORD) (* ; - "Height of an item, i.e., fontheight*linesperitem") - (TBMAXXPOS WORD) (* ; - "The largest x-position a user printfn has printed to") - (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") - (TBFONTASCENT WORD) - (TBBASELINE WORD) - (TBWINDOW POINTER) (* ; - "Pointer to the display window. Need to snap this link when browser is closed") - (TBLOCK POINTER) (* ; - "Monitor lock guarding some browser operations") - (TBUSERDATA POINTER) (* ; "Arbitrary user storage") - (TBFONT POINTER) (* ; "Pointer to font used by display") - (TBEXTENT POINTER) (* ; - "Window's extent, updated as items are added, deleted, or printfn prints farther to right") - (TBUPDATEFROMHERE POINTER) (* ; - "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") - (TBCOLUMNS POINTER) (* ; - "Number of columns--not yet implemented") - (TBPRINTFN POINTER) (* ; - "(Browser Item Window) -- displays Item at current line position in window") - (TBCOPYFN POINTER) (* ; - "(Browser Item) -- copy selects Item") - (TBFONTCHANGEFN POINTER) (* ; - "(Browser Window) -- called when tb.set.font changes the font") - (TBCLOSEFN POINTER) (* ; - "(Browser Window Close/Shrink) -- called when you try to close or shrink window") - (TBAFTERCLOSEFN POINTER) (* ; - "(Browser Window) -- called to cleanup AFTER a closew") - (TBTITLEEVENTFN POINTER) (* ; - "(Window Browser) -- handles button event in browser's title") - (TBLINETHICKNESS POINTER) (* ; - "Thickness of line for deletions (normally 1)") - (TBORIGIN POINTER) (* ; - "Y position of the top of the first item") - (TBTAILHINT POINTER) (* ; - "A tail of TBITEMS, used to speed up TB.NTH.ITEM") - (TBHEADINGWINDOW POINTER) (* ; - "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") - (NIL POINTER))) - -(DATATYPE TABLEITEM ((TISELECTED FLAG) - (TIDELETED FLAG) - (TIUNDELETABLE FLAG) - (TIUNSELECTABLE FLAG) - (TIUNCOPYSELECTABLE FLAG) - (TIDATA POINTER) - (TI# WORD))) -) - -(/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) -(DECLARE%: EVAL@COMPILE - -(RPAQQ TB.LEFT.MARGIN 8) - - -(CONSTANTS TB.LEFT.MARGIN) -) -(PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Venue & Xerox Corporation" 1985 1988 1990 1993 1999)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/library/TABLEBROWSERDECLS.LCOM b/obsolete/library/TABLEBROWSERDECLS.LCOM deleted file mode 100644 index fa540277..00000000 --- a/obsolete/library/TABLEBROWSERDECLS.LCOM +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "26-Jun-99 00:30:15" ("compiled on " {DSK}medley3.5>library>TABLEBROWSERDECLS.;2 ) "29-Jan-99 11:25:20" tcompl'd in "LFG 21-Jun-99 ..." dated "21-Jun-99 23:39:34") (FILECREATED "26-Jun-99 00:30:01" {DSK}medley3.5>library>TABLEBROWSERDECLS.;2 7377 changes to%: (RECORDS TABLEBROWSER TABLEITEM) previous date%: "20-Jan-93 14:52:38" {DSK}medley3.5>library>TABLEBROWSERDECLS.;1) (PRETTYCOMPRINT TABLEBROWSERDECLSCOMS) (RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN))) (DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ; "True if creator set explicit item height or baseline") (TBITEMS POINTER) (* ; "List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; "Number of items marked deleted") (TB#LINESPERITEM WORD) (* ; "Number of lines occupied by each item, normally 1 (dunno if any other values work)") ( TBFIRSTSELECTEDITEM WORD) (* ; "Number of first selected item. If none selected, is > TB#ITEMS") ( TBLASTSELECTEDITEM WORD) (* ; "Number of last selected item. If none selected, is 0") (TBITEMHEIGHT WORD) (* ; "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ; "The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ; "Pointer to the display window. Need to snap this link when browser is closed") (TBLOCK POINTER) (* ; "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") (TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ; "Window's extent, updated as items are added, deleted, or printfn prints farther to right") ( TBUPDATEFROMHERE POINTER) (* ; "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") ( TBCOLUMNS POINTER) (* ; "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ; "(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ; "(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ; "(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ; "(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN POINTER) (* ; "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ; "(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ; "Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ; "Y position of the top of the first item") (TBTAILHINT POINTER) (* ; "A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ; "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL POINTER))) (DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) ( TIUNCOPYSELECTABLE FLAG) (TIDATA POINTER) (TI# WORD))) (/DECLAREDATATYPE (QUOTE TABLEBROWSER) (QUOTE (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)) (QUOTE ((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))) (QUOTE 48)) (/DECLAREDATATYPE (QUOTE TABLEITEM) (QUOTE (FLAG FLAG FLAG FLAG FLAG POINTER WORD)) (QUOTE ((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)))) (QUOTE 4)) (RPAQQ TB.LEFT.MARGIN 8) (CONSTANTS TB.LEFT.MARGIN) (PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Venue & Xerox Corporation" 1985 1988 1990 1993 1999)) NIL \ No newline at end of file diff --git a/obsolete/library/TBDECLS b/obsolete/library/TBDECLS deleted file mode 100644 index d9b78084..00000000 --- a/obsolete/library/TBDECLS +++ /dev/null @@ -1,150 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "27-Sep-94 15:03:22" {DSK}library>TBDECLS.;3 7831 - - changes to%: (RECORDS TABLEBROWSER TABLEITEM) - - previous date%: "20-Jan-93 14:52:38" {DSK}library>TBDECLS.;2) - - -(* ; " -Copyright (c) 1985, 1988, 1990, 1993, 1994 by Venue. All rights reserved. -") - -(PRETTYCOMPRINT TBDECLSCOMS) - -(RPAQQ TBDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) - (CONSTANTS TB.LEFT.MARGIN))) -(DECLARE%: EVAL@COMPILE - -(DATATYPE TABLEBROWSER ((TBREADY FLAG) - (TBHEIGHTEXPLICIT FLAG) (* ; - "True if creator set explicit item height or baseline") - (NIL 6 FLAG) - (TBITEMS POINTER) (* ; "List of items in this browser") - (TB#ITEMS WORD) (* ; "Number of items") - (TB#DELETED WORD) (* ; "Number of items marked deleted") - (TB#LINESPERITEM WORD) (* ; - "Number of lines occupied by each item, normally 1 (dunno if any other values work)") - (TBFIRSTSELECTEDITEM WORD) (* ; - "Number of first selected item. If none selected, is > TB#ITEMS") - (TBLASTSELECTEDITEM WORD) (* ; - "Number of last selected item. If none selected, is 0") - (TBITEMHEIGHT WORD) (* ; - "Height of an item, i.e., fontheight*linesperitem") - (TBMAXXPOS WORD) (* ; - "The largest x-position a user printfn has printed to") - (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") - (TBFONTASCENT WORD) - (TBBASELINE WORD) - (TBWINDOW POINTER) (* ; - "Pointer to the display window. Need to snap this link when browser is closed") - (TBLOCK POINTER) (* ; - "Monitor lock guarding some browser operations") - (TBUSERDATA POINTER) (* ; "Arbitrary user storage") - (TBFONT POINTER) (* ; "Pointer to font used by display") - (TBEXTENT POINTER) (* ; - "Window's extent, updated as items are added, deleted, or printfn prints farther to right") - (TBUPDATEFROMHERE POINTER) (* ; - "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") - (TBCOLUMNS POINTER) (* ; - "Number of columns--not yet implemented") - (TBPRINTFN POINTER) (* ; - "(Browser Item Window) -- displays Item at current line position in window") - (TBCOPYFN POINTER) (* ; - "(Browser Item) -- copy selects Item") - (TBFONTCHANGEFN POINTER) (* ; - "(Browser Window) -- called when tb.set.font changes the font") - (TBCLOSEFN POINTER) (* ; - "(Browser Window Close/Shrink) -- called when you try to close or shrink window") - (TBAFTERCLOSEFN POINTER) (* ; - "(Browser Window) -- called to cleanup AFTER a closew") - (TBTITLEEVENTFN POINTER) (* ; - "(Window Browser) -- handles button event in browser's title") - (TBLINETHICKNESS POINTER) (* ; - "Thickness of line for deletions (normally 1)") - (TBORIGIN POINTER) (* ; - "Y position of the top of the first item") - (TBTAILHINT POINTER) (* ; - "A tail of TBITEMS, used to speed up TB.NTH.ITEM") - (TBHEADINGWINDOW POINTER) (* ; - "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") - (NIL POINTER))) - -(DATATYPE TABLEITEM ((TISELECTED FLAG) - (TIDELETED FLAG) - (TIUNDELETABLE FLAG) - (TIUNSELECTABLE FLAG) - (TIUNCOPYSELECTABLE FLAG) - (NIL 3 FLAG) - (TIDATA POINTER) - (TI# WORD) - (NIL WORD))) -) - -(/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) -(DECLARE%: EVAL@COMPILE - -(RPAQQ TB.LEFT.MARGIN 8) - - -(CONSTANTS TB.LEFT.MARGIN) -) -(PUTPROPS TBDECLS COPYRIGHT ("Venue" 1985 1988 1990 1993 1994)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/library/TBDECLS.LCOM b/obsolete/library/TBDECLS.LCOM deleted file mode 100644 index 76e1a674..00000000 --- a/obsolete/library/TBDECLS.LCOM +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-Aug-95 17:08:48" ("compiled on " {DSK}library>TBDECLS.;3) "30-Mar-95 20:33:04" bcompl'd in "Medley 14-Aug-95 ..." dated "14-Aug-95 15:27:48") (FILECREATED "27-Sep-94 15:03:22" {DSK}library>TBDECLS.;3 7831 changes to%: (RECORDS TABLEBROWSER TABLEITEM) previous date%: "20-Jan-93 14:52:38" {DSK}library>TBDECLS.;2) (PRETTYCOMPRINT TBDECLSCOMS) (RPAQQ TBDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN))) (DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ; "True if creator set explicit item height or baseline") (NIL 6 FLAG) (TBITEMS POINTER) (* ; "List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; "Number of items marked deleted") (TB#LINESPERITEM WORD) (* ; "Number of lines occupied by each item, normally 1 (dunno if any other values work)") ( TBFIRSTSELECTEDITEM WORD) (* ; "Number of first selected item. If none selected, is > TB#ITEMS") ( TBLASTSELECTEDITEM WORD) (* ; "Number of last selected item. If none selected, is 0") (TBITEMHEIGHT WORD) (* ; "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ; "The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ; "Pointer to the display window. Need to snap this link when browser is closed") (TBLOCK POINTER) (* ; "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") (TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ; "Window's extent, updated as items are added, deleted, or printfn prints farther to right") ( TBUPDATEFROMHERE POINTER) (* ; "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") ( TBCOLUMNS POINTER) (* ; "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ; "(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ; "(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ; "(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ; "(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN POINTER) (* ; "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ; "(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ; "Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ; "Y position of the top of the first item") (TBTAILHINT POINTER) (* ; "A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ; "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL POINTER))) (DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) ( TIUNCOPYSELECTABLE FLAG) (NIL 3 FLAG) (TIDATA POINTER) (TI# WORD) (NIL WORD))) (/DECLAREDATATYPE (QUOTE TABLEBROWSER) (QUOTE (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)) (QUOTE (( 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))) (QUOTE 48)) (/DECLAREDATATYPE (QUOTE TABLEITEM) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD) ) (QUOTE ((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)))) (QUOTE 4)) (RPAQQ TB.LEFT.MARGIN 8) (CONSTANTS TB.LEFT.MARGIN) (PUTPROPS TBDECLS COPYRIGHT ("Venue" 1985 1988 1990 1993 1994)) NIL \ No newline at end of file diff --git a/obsolete/library/UNIXPRINTCOMMAND b/obsolete/library/UNIXPRINTCOMMAND deleted file mode 100644 index 24fd2e1e..00000000 --- a/obsolete/library/UNIXPRINTCOMMAND +++ /dev/null @@ -1,78 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "20-May-92 15:34:18" |{DSK}nilsson>UNIXPRINTCOMMAND.;1| 3317 - - |changes| |to:| (VARS UNIXPRINTCOMMANDCOMS) - (FUNCTIONS FOOT) - (FNS |UnixPrintCommandForHP|)) - - -; Copyright (c) 1992 by Venue. All rights reserved. - -(PRETTYCOMPRINT UNIXPRINTCOMMANDCOMS) - -(RPAQQ UNIXPRINTCOMMANDCOMS ((FNS |UnixPrintCommand| |UnixPrintCommandForHP|))) -(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))) - -(|UnixPrintCommandForHP| - (LAMBDA (PRINTER COPIES NAME TMPNAME) (* \; "Edited 20-May-92 15:33 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/lp " (* \; "HPUX uses lp instead.") - (COND - (PRINTER (CONCAT "-P" (|UnixShellQuote| PRINTER) - " ")) - (T "")) - (COND - ((AND (FIXP COPIES) - (NEQ COPIES 1)) - (CONCAT "-#" COPIES " ")) - (T "")) - " -J" - (|UnixShellQuote| NAME) - " -r -s " TMPNAME))) -) -(PUTPROPS UNIXPRINTCOMMAND COPYRIGHT ("Venue" 1992)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (472 3241 (|UnixPrintCommand| 482 . 1843) (|UnixPrintCommandForHP| 1845 . 3239))))) -STOP diff --git a/obsolete/library/UNIXPRINTCOMMAND.LCOM b/obsolete/library/UNIXPRINTCOMMAND.LCOM deleted file mode 100644 index e5fd1c62..00000000 Binary files a/obsolete/library/UNIXPRINTCOMMAND.LCOM and /dev/null differ diff --git a/obsolete/library/new/PCTREE b/obsolete/library/new/PCTREE deleted file mode 100644 index b6020cf4..00000000 --- a/obsolete/library/new/PCTREE +++ /dev/null @@ -1,572 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "22-Mar-95 18:19:18" {DSK}library>new>PCTREE.;1 28446 - - changes to%: (FNS \INSERTTREE \DELETETREE \SPLITTREE \TEDIT.UPDATETREE) - - previous date%: " 7-Oct-94 17:44:31" {DSK}library>PCTREE.;5) - - -(* ; " -Copyright (c) 1990, 1991, 1993, 1994, 1995 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 22-Mar-95 15:37 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 (COND - (OLD (HELP "Old piece not in this PCNODE.")) - (T (* ; "INSERTING FIRST PIECE") - (SETQ ITEM# 0] - (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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3019 23506 (UPDATEPCNODES 3029 . 4116) (FINDPCNODE 4118 . 4350) (\FIRSTNODE 4352 . 4709 -) (\DELETETREE 4711 . 7192) (\INSERTTREE 7194 . 11815) (\LASTNODE 11817 . 12460) (\MATCHPCS 12462 . -13586) (\SPLITTREE 13588 . 20764) (\TEDIT.UPDATETREE 20766 . 22243) (\TEDIT.PIECE-CHNO 22245 . 22824) -(\TEDIT.SET-TOTLEN 22826 . 23504)) (23507 25947 (DISPTREE 23517 . 23973) (TREEGRAPHNODE 23975 . 25945) -)))) -STOP diff --git a/obsolete/library/new/TEDIT b/obsolete/library/new/TEDIT deleted file mode 100644 index f05ba869..00000000 --- a/obsolete/library/new/TEDIT +++ /dev/null @@ -1,2226 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 4-May-95 10:37:05" {DSK}library>new>TEDIT.;5 139939 - - changes to%: (FNS \TEDIT.INSERT.PIECES TEDIT.COPY TEDIT.MOVE) - (FILES TEDITCOMMAND TEDITFILE TEDITFNKEYS TEDITHISTORY TEDITLOOKS TEDITPAGE - TEDITWINDOW) - - previous date%: "22-Mar-95 18:17:12" {DSK}library>new>TEDIT.;1) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1995 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 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) - (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 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) (* ; - "Inlcude 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] - (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))) - (WINDOWPROP WINDOW 'TEXTOBJ T) (* ; - "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.") - )) - [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 2-May-95 12:23 by sybalsky:mv:envos") - (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 _ (LIST 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 2-May-95 12:24 by sybalsky:mv:envos") - - (* ;; - "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 _ (LIST 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 4-May-95 08:16 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) - (DECLARE (SPECVARS START-OF-PIECE)) (* ; - "Get a handle on the piece we're to insert within or in front of") - (* 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] - (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 " 4-May-95 10:37:23") - -(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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (4494 115122 (\TEDIT2 4504 . 7255) (COERCETEXTOBJ 7257 . 15584) (TEDIT 15586 . 20255) ( -TEDIT.CHARWIDTH 20257 . 22281) (TEDIT.COPY 22283 . 30881) (TEDIT.DELETE 30883 . 31573) ( -TEDIT.DO.BLUEPENDINGDELETE 31575 . 34642) (TEDIT.INSERT 34644 . 40174) (TEDIT.KILL 40176 . 41733) ( -TEDIT.MAPLINES 41735 . 43134) (TEDIT.MAPPIECES 43136 . 44092) (TEDIT.MOVE 44094 . 54143) (TEDIT.QUIT -54145 . 56145) (TEDIT.STRINGWIDTH 56147 . 56818) (TEDIT.\INSERT 56820 . 58845) (TEXTOBJ 58847 . 59972) - (TEXTSTREAM 59974 . 61589) (\TEDIT.INCLUDE 61591 . 65491) (\TEDIT.INSERT.PIECES 65493 . 75524) ( -\TEDIT.MOVE.PIECEMAPFN 75526 . 77605) (\TEDIT.OBJECT.SHOWSEL 77607 . 81236) (\TEDIT.RESTARTFN 81238 . -83233) (\TEDIT.CHARDELETE 83235 . 87197) (\TEDIT.COPY.PIECEMAPFN 87199 . 90424) (\TEDIT.DELETE 90426 - . 97944) (\TEDIT.DIFFUSE.PARALOOKS 97946 . 100710) (\TEDIT.FOREIGN.COPY? 100712 . 104439) ( -\TEDIT.QUIT 104441 . 107587) (\TEDIT.WORDDELETE 107589 . 112422) (\TEDIT1 112424 . 115120)) (115236 -115352 (\CREATE.TEDIT.RESTART.MENU 115246 . 115350)) (115451 119140 (PLCHAIN 115461 . 115735) ( -PRINTLINE 115737 . 118501) (SEEFILE 118503 . 119138)) (119181 138824 (TEDIT.INSERT.OBJECT 119191 . -128268) (TEDIT.EDIT.OBJECT 128270 . 130526) (TEDIT.FIND.OBJECT 130528 . 131421) ( -TEDIT.FIND.OBJECT.SUBTREE 131423 . 132229) (TEDIT.PUT.OBJECT 132231 . 133890) (TEDIT.GET.OBJECT 133892 - . 137091) (TEDIT.OBJECT.CHANGED 137093 . 138822)) (139100 139463 (MAKETEDITFORM 139110 . 139461))))) -STOP diff --git a/obsolete/library/new/TEDIT.LCOM b/obsolete/library/new/TEDIT.LCOM deleted file mode 100644 index 4a95300d..00000000 Binary files a/obsolete/library/new/TEDIT.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITABBREV.LCOM b/obsolete/library/new/TEDITABBREV.LCOM deleted file mode 100644 index 82262191..00000000 Binary files a/obsolete/library/new/TEDITABBREV.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITCOMMAND.LCOM b/obsolete/library/new/TEDITCOMMAND.LCOM deleted file mode 100644 index 386f05df..00000000 Binary files a/obsolete/library/new/TEDITCOMMAND.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITDCL b/obsolete/library/new/TEDITDCL deleted file mode 100644 index f2d63f6f..00000000 --- a/obsolete/library/new/TEDITDCL +++ /dev/null @@ -1,1654 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "22-Mar-95 18:05:53" {DSK}library>new>TEDITDCL.;1 86457 - - changes to%: (RECORDS PIECE) - - previous date%: "25-Aug-94 10:53:00" {DSK}library>TEDITDCL.;2) - - -(* ; " -Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1995 by Venue. All rights reserved. -") - -(PRETTYCOMPRINT TEDITDCLCOMS) - -(RPAQQ TEDITDCLCOMS - [ - -(* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.") - - - (* ;; "FROM TEDIT") - - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))) - - (* ;; "FROM TEDITSELECTION") - - (RECORDS SELECTION) - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (COPYSELSHADE 30583) - (COPYLOOKSSELSHADE 30583) - (EDITMOVESHADE -1) - (EDITGRAY 32800))) - (VARS TEDITFILES) - - (* ;; "FROM TEDITSCREEN") - - (RECORDS THISLINE LINEDESCRIPTOR LINECACHE) - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (LMInvisibleRun 401) - (LMLooksChange 400))) - - (* ;; "FROM TEXTOFD") - - (RECORDS EDITMARK) - (RECORDS PIECE TEXTOBJ TEXTIMAGEDATA TEXTSTREAM) - (OPTIMIZERS TEXTPROP) - (COMS - (* ;; "Private data structures and constants FROM TEXTOFD") - - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PCTBFreePieces 0) - (\PCTBLastPieceOffset 1) - (\FirstPieceOffset 2) - (\SecondPieceOffset 4) - (\EltsPerPiece 2)) - (MACROS \EDITELT \GETCH \GETCHB \EDITSETA \WORDSETA) - (GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV))) - - -(* ;;; "FROM TEDITPAGE") - - (RECORDS PAGEFORMATTINGSTATE PAGEREGION) - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITPAPERSIZE) - (FUNCTIONS \NEW-COLUMN-START \FIRST-COLUMN-START)) - - (* ;; "FROM TEDITFIND") - - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\AlphaNumericFlag 256) - (\AlphaFlag 512) - (\OneCharPattern 1024) - (\AnyStringPattern 1025) - (\OneAlphaPattern 1026) - (\AnyAlphaPattern 1027) - (\OneNonAlphaPattern 1028) - (\AnyNonAlphaPattern 1029) - (\LeftBracketPattern 1030) - (\RightBracketPattern 1031) - (\SpecialPattern 1024))) - - (* ;; " FROM TEDITLOOKS") - - (RECORDS CHARLOOKS FMTSPEC PENDINGTAB) - (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \SMALLPIN \SMALLPOUT ONOFF)) - - (* ;; "FROM TEDITMENU") - - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MBUTTON)) - (INITRECORDS MBUTTON) - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS NWAYBUTTON)) - (INITRECORDS NWAYBUTTON) - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MARGINBAR)) - (INITRECORDS MARGINBAR) - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TAB)) - (RECORDS MB.3STATE MB.BUTTON MB.INSERT MB.MARGINBAR MB.NWAY MB.TEXT MB.TOGGLE) - (FUNCTIONS WITHOUT-UPDATES) - - (* ;; "FROM TEDITHISTORY") - - (RECORDS TEDITHISTORYEVENT) - - (* ;; "FROM TEDITFILE") - - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PieceDescriptorLOOKS 0) - (\PieceDescriptorOBJECT 1) - (\PieceDescriptorPARA 2) - (\PieceDescriptorPAGEFRAME 3) - (\PieceDescriptorCHARLOOKSLIST 4) - (\PieceDescriptorPARALOOKSLIST 5) - (\PieceDescriptorSAFEOBJECT 6))) - - (* ;; "FROM TEDITCOMMAND") - - (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \INSERT\TTY\BUFFER \TEDIT.MOUSESTATE \TEDIT.CHECK)) - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITTERMCODE)) - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NONE.TTC 0) - (CHARDELETE.TTC 1) - (WORDDELETE.TTC 2) - (DELETE.TTC 3) - (FUNCTIONCALL.TTC 4) - (REDO.TTC 5) - (UNDO.TTC 6) - (CMD.TTC 7) - (NEXT.TTC 8) - (EXPAND.TTC 9) - (PUNCT.TTC 20) - (TEXT.TTC 21) - (WHITESPACE.TTC 22))) - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MSPACE 153) - (NSPACE 152) - (THINSPACE 159) - (FIGSPACE 154))) - - (* ;; "FROM TEDITWINDOW") - - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITCARET)) - (INITRECORDS TEDITCARET) - - (* ;; "FROM PCTREE added by Nakamura") - - (RECORDS PCTNODE) - - -(* ;;; "THE END") - - (COMS - (* ;; "Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character ") - - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NOTBEFORE.LB 1) - (* ; - "Must not break before this character (e.g. Japanese right-paren)") - (NOTAFTER.LB 2) - (* ; - "Must not break after this character (e.g. Japanese open-quote)") - (BEFORE.LB 4) - (* ; "OK to break before this character, provided it's OK to break after the prior char (true of most non-white-space)") - (AFTER.LB 8) - (* ; - "OK to break after this char, if it's OK to break before the next one (true of most white space)") - (DISAPPEAR-IF-NOT-SPLIT.LB 16) - (* ; "This character shouldn't be rendered if it isn't the last char on the line (non-breaking hyphen has this)") - (NEWCHAR-IF-SPLIT.LB 32) - (* ; "Look this char up in *TEDIT-SPLITCHAR-HASH* if this IS the last character on a line, and render it as the char we found.") - ]) - - - -(* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.") - - - - -(* ;; "FROM TEDIT") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \SCRATCHLEN 64) - - -(CONSTANTS (\SCRATCHLEN 64)) -) -) - - - -(* ;; "FROM TEDITSELECTION") - -(DECLARE%: EVAL@COMPILE - -(DATATYPE SELECTION - ( - (* ;; "Description of a piece of selected text for TEdit. Text has to be selected before it can be operated on by the user.") - - Y0 (* ; - "Y value of topmost line of selection") - X0 (* ; - "X value of left edge of selection") - DX (* ; - "Width of the selection, if it's on one line.") - CH# (* ; - "CH# of the first selected character") - XLIM (* ; - "X value of right edge of last selected character") - CHLIM (* ; - "CH# of the last character in the selection") - DCH (* ; - "# of characters selected (can be zero, for point selection.)") - L1 (* ; - "-> line descriptor for the line where the first selected character is") - LN (* ; - "-> line descriptor for the line which contains the end of the selection") - YLIM (* ; - "Y value of the bottom of the line that ends the selection") - POINT (* ; - "Which end should the caret appear at? (LEFT or RIGHT)") - (SET FLAG) (* ; - "T if this selection is real; NIL if not") - (\TEXTOBJ FULLXPOINTER) (* ; - "TEXTOBJ that describes the selected text") - SELKIND (* ; - "What kind of selection? CHAR or WORD or LINE or PARA") - HOW (* ; - "SHADE used to highlight this selection") - HOWHEIGHT (* ; - "Height of the highlight (1 usually, full line for delete selection...)") - (HASCARET FLAG) (* ; - "T if there should be a caret for this selection") - SELOBJ (* ; - "If this selection is inside an object, which object?") - (ONFLG FLAG) (* ; - "T if the selection is highlighted on the screen, else NIL") - SELOBJINFO (* ; - "A Place for the selected object to put info about selection inside itself.") - ) - SET _ NIL HOW _ BLACKSHADE HOWHEIGHT _ 1 HASCARET _ T Y0 _ 0 X0 _ 0 POINT _ 'LEFT L1 _ - (LIST NIL) - LN _ (LIST NIL)) -) - -(/DECLAREDATATYPE 'SELECTION - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG - FULLXPOINTER POINTER POINTER POINTER FLAG POINTER FLAG POINTER) - '((SELECTION 0 POINTER) - (SELECTION 2 POINTER) - (SELECTION 4 POINTER) - (SELECTION 6 POINTER) - (SELECTION 8 POINTER) - (SELECTION 10 POINTER) - (SELECTION 12 POINTER) - (SELECTION 14 POINTER) - (SELECTION 16 POINTER) - (SELECTION 18 POINTER) - (SELECTION 20 POINTER) - (SELECTION 20 (FLAGBITS . 0)) - (SELECTION 22 FULLXPOINTER) - (SELECTION 24 POINTER) - (SELECTION 26 POINTER) - (SELECTION 28 POINTER) - (SELECTION 28 (FLAGBITS . 0)) - (SELECTION 30 POINTER) - (SELECTION 30 (FLAGBITS . 0)) - (SELECTION 32 POINTER)) - '34) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ COPYSELSHADE 30583) - -(RPAQQ COPYLOOKSSELSHADE 30583) - -(RPAQQ EDITMOVESHADE -1) - -(RPAQQ EDITGRAY 32800) - - -(CONSTANTS (COPYSELSHADE 30583) - (COPYLOOKSSELSHADE 30583) - (EDITMOVESHADE -1) - (EDITGRAY 32800)) -) -) - -(RPAQQ TEDITFILES (PCTREE TEXTOFD TEDIT TEDITABBREV TEDITCOMMAND TEDITDCL TEDITFILE TEDITFIND - TEDITFNKEYS TEDITHCPY TEDITHISTORY TEDITLOOKS TEDITMENU TEDITPAGE - TEDITSCREEN TEDITSELECTION TEDITWINDOW)) - - - -(* ;; "FROM TEDITSCREEN") - -(DECLARE%: EVAL@COMPILE - -(DATATYPE THISLINE ( - (* ;; - "Cache for line-related character location info, for selection and line-display code to use.") - - (DESC FULLXPOINTER) (* ; - "Line descriptor for the line this describes now") - LEN (* ; - "Length of the line in characters") - CHARS - - (* ;; "Array of character codes (or objects) on the line (charcode of 400 => dummy entry for looks change--go get next entry in LOOKS)") - - WIDTHS (* ; - "Array of each character's width in points") - LOOKS (* ; - "Array of any looks changes within the line. LOOKS (0) = starting character looks for the line") - TLSPACEFACTOR (* ; - "The SPACEFACTOR to be used in printing this line") - TLFIRSTSPACE (* ; "The first space to which SPACEFACTOR is to apply. This is used so that spaces to the left of a TAB have their default width.") - ) - LEN _ 0 CHARS _ (ARRAY 512 'POINTER 0 0) - WIDTHS _ (ARRAY 512 'POINTER 0 0) - LOOKS _ (ARRAY 512 'POINTER NIL 0) - TLFIRSTSPACE _ 0) - -(DATATYPE LINEDESCRIPTOR - ( - (* ;; - "Description of a single line of formatted text, either on the display or for a printed page.") - - YBOT (* ; - "Y value for the bottom of the line (below the descent)") - YBASE (* ; - "Yvalue for the base line the characters sit on") - LEFTMARGIN (* ; "Left margin, in screen points") - RIGHTMARGIN (* ; "Right margin, in screen points") - LXLIM (* ; "X value of right edge of rightmost character on the line (may exceed right margin, if char is a space.)") - SPACELEFT (* ; - "Space left on the line, ignoring trailing blanks & CRs.") - LHEIGHT (* ; - "Total height of hte line, Ascent+Descent.") - ASCENT (* ; "Ascent of the line above YBASE") - DESCENT (* ; - "How far line descends below YBASE") - LTRUEDESCENT (* ; - "The TRUE DESCENT for this line, unadjusted for line leading.") - LTRUEASCENT (* ; - "The TRUE ASCENT for this line, unadjusted for pre-paragraph leading.") - CHAR1 (* ; - "CH# of the first character on the line.") - CHARLIM (* ; - "CH# of the last character on the line") - CHARTOP (* ; - "CH# of the character which forced the line break (may exceed CHARLIM)") - NEXTLINE (* ; "Next line chain pointer") - (PREVLINE FULLXPOINTER) (* ; "Previous line chain pointer") - LMARK (* ; "One of SOLID, GREY, NIL. Tells what kind of special-line marker should be put in the left margin for this paragraph. (For hardcopy, can also be an indicator for special processing?)") - LTEXTOBJ (* ; "A cached TEXTOBJ that this line took its text from. Used in hardcopy to disambiguate when chno's should be updated...") - CACHE (* ; "A cached THISLINE, for keeping hardcopy info around while we crunch with the line descriptors to make things fit.") - LDOBJ (* ; - "The object which lies behind this line of text, for updating, etc.") - LFMTSPEC (* ; - "The format spec for this line's paragraph (eventually)") - (DIRTY FLAG) (* ; - "T if this line has changed since it was last formatted.") - (CR\END FLAG) (* ; "T if this line ends with a CR.") - (DELETED FLAG) (* ; "T if this line has been completely deleted since it was last formatted or displayed. (Used by deletion routines to detect garbage lines)") - (LHASPROT FLAG) (* ; - "This line contains protected text.") - (LHASTABS FLAG) (* ; "If this line has a tab in it, this is the line-relative ch# of the final tab. This is to let us punt properly with tabs in a line.") - (1STLN FLAG) (* ; - "This line is the first line in a paragraph") - (LSTLN FLAG) (* ; - "This is the last line in a paragraph") - ) - CHARLIM _ 1000000 NEXTLINE _ NIL PREVLINE _ NIL DIRTY _ NIL YBOT _ 0 YBASE _ 0 LEFTMARGIN _ - 0 DELETED _ NIL) - -(DATATYPE LINECACHE ( - (* ;; "Image cache for display lines.") - - LCBITMAP (* ; - "The bitmap that will be used by this instance of the cache") - (LCNEXTCACHE FULLXPOINTER) (* ; - "The next cache in the chain, for screen updates.") - )) -) - -(/DECLAREDATATYPE 'THISLINE '(FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER) - '((THISLINE 0 FULLXPOINTER) - (THISLINE 2 POINTER) - (THISLINE 4 POINTER) - (THISLINE 6 POINTER) - (THISLINE 8 POINTER) - (THISLINE 10 POINTER) - (THISLINE 12 POINTER)) - '14) - -(/DECLAREDATATYPE 'LINEDESCRIPTOR - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER - FLAG FLAG FLAG FLAG FLAG FLAG FLAG) - '((LINEDESCRIPTOR 0 POINTER) - (LINEDESCRIPTOR 2 POINTER) - (LINEDESCRIPTOR 4 POINTER) - (LINEDESCRIPTOR 6 POINTER) - (LINEDESCRIPTOR 8 POINTER) - (LINEDESCRIPTOR 10 POINTER) - (LINEDESCRIPTOR 12 POINTER) - (LINEDESCRIPTOR 14 POINTER) - (LINEDESCRIPTOR 16 POINTER) - (LINEDESCRIPTOR 18 POINTER) - (LINEDESCRIPTOR 20 POINTER) - (LINEDESCRIPTOR 22 POINTER) - (LINEDESCRIPTOR 24 POINTER) - (LINEDESCRIPTOR 26 POINTER) - (LINEDESCRIPTOR 28 POINTER) - (LINEDESCRIPTOR 30 FULLXPOINTER) - (LINEDESCRIPTOR 32 POINTER) - (LINEDESCRIPTOR 34 POINTER) - (LINEDESCRIPTOR 36 POINTER) - (LINEDESCRIPTOR 38 POINTER) - (LINEDESCRIPTOR 40 POINTER) - (LINEDESCRIPTOR 40 (FLAGBITS . 0)) - (LINEDESCRIPTOR 40 (FLAGBITS . 16)) - (LINEDESCRIPTOR 40 (FLAGBITS . 32)) - (LINEDESCRIPTOR 40 (FLAGBITS . 48)) - (LINEDESCRIPTOR 38 (FLAGBITS . 0)) - (LINEDESCRIPTOR 38 (FLAGBITS . 16)) - (LINEDESCRIPTOR 38 (FLAGBITS . 32))) - '42) - -(/DECLAREDATATYPE 'LINECACHE '(POINTER FULLXPOINTER) - '((LINECACHE 0 POINTER) - (LINECACHE 2 FULLXPOINTER)) - '4) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ LMInvisibleRun 401) - -(RPAQQ LMLooksChange 400) - - -(CONSTANTS (LMInvisibleRun 401) - (LMLooksChange 400)) -) -) - - - -(* ;; "FROM TEXTOFD") - -(DECLARE%: EVAL@COMPILE - -(RECORD EDITMARK ( - (* ;; "Used for fast access to a given place in the text--a %"Marker%". It consists of the piece, and the offset within the piece, and the piece number within the piece table. That's everything that's needed to set a text stream up quickly to start reading from a given place.") - - PC PCOFF . PCNO)) -) -(DECLARE%: EVAL@COMPILE - -(DATATYPE PIECE - ( (* ; - "The piece describes either a string or part of a file. , or a generalized OBJECT.") - PSTR (* ; - "The string where this piece's text resides, or NIL") - PFILE (* ; - "The file which contains this piece's text, or NIL") - (PFPOS FIXP) (* ; - "The FILEPTR of the start of the piece in the file") - (PLEN FIXP) (* ; - "Length of the piece, in characters.") - (NEXTPIECE FULLXPOINTER) (* ; "-> Next piece in this textobj.") - (PREVPIECE FULLXPOINTER) (* ; - "-> Prior piece in this text object.") - PLOOKS (* ; - "Formatting info and formatting events in this piece") - POBJ (* ; "The OBJECT this piece describes") - (PPARALAST FLAG) (* ; - "This piece contains a paragraph break") - PPARALOOKS (* ; "Paragraph looks for this piece") - (PNEW FLAG) (* ; - "This text is new here; used by the tentative edit system, and anyone else interested.") - (PFATP FLAG) (* ; - "T if the characters in this piece are FAT -- i.e., are 16 bits each.") - (PTREENODE XPOINTER) (* ; - "Points to the PCTB tree-node that contains this piece.") - ) - PSTR _ NIL PFILE _ NIL PFPOS _ 0 PLEN _ 0 PPARALOOKS _ TEDIT.DEFAULT.FMTSPEC PTREENODE _ - NIL) - -(DATATYPE TEXTOBJ - ( - (* ;; - "This is where TEdit stores its state information, and internal data about the text being edited.") - - PCTB (* ; "The piece table") - TEXTLEN (* ; "# of chars in the text") - \INSERTPC (* ; "Piece to hold type-in") - \INSERTPCNO (* ; "Piece # of the input piece") - \INSERTNEXTCH (* ; - "CH# of next char which is typed into that piece.") - \INSERTLEFT (* ; "Space left in the type-in piece") - \INSERTLEN (* ; - "# of characters already in the piece.") - \INSERTSTRING (* ; - "The string which the piece describes.") - \INSERTFIRSTCH (* ; "CH# of first char in the piece.") - (\INSERTPCVALID FLAG) (* ; "T if it's OK to use the cached piece. Set to NIL by people who require that the next insertion/deletion use a different piece.") - \WINDOW (* ; - "The window where this textobj is displayed") - MOUSEREGION (* ; - "Section of the window the mouse is in.") - LINES (* ; - "-> to top of chain of line descriptors for displayed text") - DS (* ; - "Display stream where this textobj is displayed") - SEL (* ; - "The current selection within the text") - SCRATCHSEL (* ; - "Scratch space for the selection code") - MOVESEL (* ; - "Source for the next MOVE of text") - SHIFTEDSEL (* ; "Source for the next COPY") - DELETESEL (* ; "Text to be deleted imminently") - WRIGHT (* ; - "Right edge of the window (or subregion) where this is displayed") - WTOP (* ; "Top of the window/region") - WBOTTOM (* ; "Bottom of the window/region") - WLEFT (* ; "Left edge of the window/region") - TXTFILE (* ; - "The original text file we're editing") - (\XDIRTY FLAG) (* ; "T => changed since last saved.") - (STREAMHINT FULLXPOINTER) (* ; - "-> the TEXTOFD stream which gives access to this textobj") - EDITFINISHEDFLG (* ; - "T => The guy has asked the editor to go way") - CARET (* ; - "Describes the flashing caret for the editing window") - CARETLOOKS (* ; - "Font to be used for inserted text.") - WINDOWTITLE (* ; - "Original title for this window, of there was one.") - THISLINE (* ; - "Cache of line-related info, to speed up selection &c") - (MENUFLG FLAG) (* ; - "T if this TEXTOBJ is a tedit-style menu") - FMTSPEC (* ; - "Default Formatting Spec to be used when formatting paragraphs") - (FORMATTEDP FLAG) (* ; -"Flag for paragraph formatting. T if this document is to contain paragraph formatting information.") - (TXTREADONLY FLAG) (* ; - "This is only available for shift selection.") - (TXTEDITING FLAG) (* ; "T => This document is in a window and there is an edit process behind it. For example, it only makes sense to have a caret show up if you are editing.") - (TXTNONSCHARS FLAG) (* ; "T => If TEdit rns into a 255, it won't attempt to convert to NS characters. Used for REALLY plain-text manipulation.") - TXTTERMSA (* ; - "Special instructions for displaying characters on the screen") - EDITOPACTIVE (* ; - "T if there is an editing operation in progress. Used to interlock the TEdit menu") - DEFAULTCHARLOOKS (* ; "The default character looks -- if any -- to be applied to characters coming into the file from outside.") - TXTRTBL (* ; - "The READTABLE to be used by the command loop for command dispatch") - TXTWTBL (* ; - "The READTABLE to be used to decide on word breaks") - EDITPROPS (* ; - "The PROPS that were passed into this edit session") - (BLUEPENDINGDELETE FLAG) (* ; "T if the next insertion in this document is to be preceded by a deletion of the then-current selection") - TXTHISTORY (* ; - "The history list for this edit session.") - (SELWINDOW FULLXPOINTER) (* ; "The window in which the last 'real' selection got made for this edit; used to control caret placement") - PROMPTWINDOW (* ; - "A window to be used for unscheduled interactions; normally a small window above the edit window") - DISPLAYCACHE (* ; - "The bitmap to be used when building the image of a line for display") - DISPLAYCACHEDS (* ; - "The DISPLAYSTREAM that is used to build line images") - DISPLAYHCPYDS (* ; "The DISPLAYSTREAM used to build line images of lines that are displayed in 'hardcopy' simulation mode") - TXTPAGEFRAMES (* ; - "A tree of page frames, specifying how the document is to be laid out.") - TXTCHARLOOKSLIST (* ; - "List of all the CHARLOOKSs in the document, so they can be kept unique") - TXTPARALOOKSLIST (* ; - "List of all the FMTSPECs in the document, so they can be kept unique") - (TXTNEEDSUPDATE FLAG) (* ; - "T => Screen invalid, need to run updater") - (TXTDON'TUPDATE FLAG) (* ; "T if we're holding off on screen updates until later. Used, e.g., by the menu-SHOW code so that you don't get piecemeal updates, but only one at the end of the SHOW.") - TXTRAWINCLUDESTREAM (* ; - "NODIRCORE stream used to cache RAW includes (and maybe later, all includes?)") - DOCPROPS (* ; - "Document properties that are stored with the document (not used yet)") - TXTSTYLESHEET (* ; - "Style sheet local to this document. Not currently saved as part of the file.") - ) - [ACCESSFNS TEXTOBJ ((\DIRTY (ffetch (TEXTOBJ \XDIRTY) of DATUM) - (PROGN (IF (NEQ (FETCH (TEXTOBJ \XDIRTY) OF DATUM) - NEWVALUE) - THEN (* ; - "update the title to reflect the change") - (\TEDIT.WINDOW.TITLE DATUM - (\TEDIT.ORIGINAL.WINDOW.TITLE - (ffetch (TEXTOBJ TXTFILE) - of DATUM) - NEWVALUE))) - (freplace \XDIRTY OF DATUM WITH NEWVALUE] - SEL _ (create SELECTION) - SCRATCHSEL _ (create SELECTION) - MOVESEL _ (create SELECTION - HOWHEIGHT _ 32767 - HASCARET _ NIL) - SHIFTEDSEL _ (create SELECTION - HASCARET _ NIL) - DELETESEL _ (create SELECTION - HOWHEIGHT _ 32767 - HASCARET _ NIL) - \INSERTNEXTCH _ -1 \INSERTPC _ NIL \INSERTLEFT _ 0 \INSERTLEN _ 0 \INSERTSTRING _ NIL - \INSERTFIRSTCH _ 1000000 TEXTLEN _ 0 WRIGHT _ 0 WTOP _ 0 WLEFT _ 0 WBOTTOM _ 0 TXTFILE _ - NIL \XDIRTY _ NIL MOUSEREGION _ 'TEXT THISLINE _ (create THISLINE) - MENUFLG _ NIL FMTSPEC _ TEDIT.DEFAULT.FMTSPEC FORMATTEDP _ NIL) - -(DATATYPE TEXTIMAGEDATA ( - (* ;; "Fills the IMAGEDATA field of text streams.") - - TICURPARALOOKS (* ; "The current paragraph looks") - TICURIMAGESTREAM (* ; - "The image stream for this hardcopy transduction") - TILOOKSUPDATEFN (* ; - "The function to call to update looks for this stream") - TIPCOFFSET (* ; - "The offset into the current piece, as of the last page cross.") - )) - -(ACCESSFNS TEXTSTREAM ( - (* ;; - "Overlay for the STREAM record to allow mnemonic access to stream fields for Text streams.") - - (REALFILE (fetch F1 of DATUM) - (REPLACE F1 OF DATUM WITH NEWVALUE)) - (* ; - "The real, underlying file behind the current piece") - (CHARSLEFT (fetch F2 of DATUM) - (REPLACE F2 OF DATUM WITH NEWVALUE)) - - (* ;; "The # of characters that will be left in the current piece the next time its file crosses a page boundary") - - (TEXTOBJ (fetch F3 of DATUM) - (REPLACE F3 OF DATUM WITH NEWVALUE)) - (* ; - "The TEXTOBJ that is editing this text") - (PIECE (fetch F5 of DATUM) - (REPLACE F5 OF DATUM WITH NEWVALUE)) - (* ; - "The PIECE we're currently fetching chars from/putting chars into") - (PCNO (fetch FW8 of DATUM) - (REPLACE FW8 OF DATUM WITH NEWVALUE)) - (* ; - "The position of that piece in the piece table") - (PCSTARTPG (fetch FW6 of DATUM) - (REPLACE FW6 OF DATUM WITH NEWVALUE)) - (* ; - "The underlying file page# that this piece starts on") - (PCSTARTCH (fetch FW7 of DATUM) - (REPLACE FW7 OF DATUM WITH NEWVALUE)) - (* ; - "The char within page of the underlying file that this piece starts on -- for backbin & co") - (PCOFFSET (fetch TIPCOFFSET of (fetch IMAGEDATA of DATUM)) - (REPLACE TIPCOFFSET OF (fetch IMAGEDATA of DATUM) - with NEWVALUE)) (* ; - "The offset into the current piece, as of the last page cross.") - (CURRENTLOOKS (fetch F10 of DATUM) - (replace F10 of DATUM with NEWVALUE)) - (* ; - "The CHARLOOKS that are currently applicable to characters being taken from the stream.") - (CURRENTPARALOOKS (fetch TICURPARALOOKS of (fetch IMAGEDATA - of DATUM)) - (REPLACE TICURPARALOOKS OF (fetch IMAGEDATA - of DATUM) with - NEWVALUE) - ) (* ; - "The FMTSPEC that is currently applicable to characters being taken from the stream.") - (CURRENTIMAGESTREAM (fetch TICURIMAGESTREAM - of (fetch IMAGEDATA of DATUM)) - (REPLACE TICURIMAGESTREAM OF (fetch IMAGEDATA - of DATUM) with - NEWVALUE) - (* ; - "The image stream that this text is being put onto; used for scaling decisions") - ) - (LOOKSUPDATEFN (fetch TILOOKSUPDATEFN of (fetch IMAGEDATA - of DATUM)) - (REPLACE TILOOKSUPDATEFN OF (fetch IMAGEDATA - of DATUM) with - NEWVALUE)) - (* ; - "Function to be called each time character looks change.") - (FATSTREAMP (fetch F4 of DATUM) - (REPLACE F4 OF DATUM WITH NEWVALUE)) - (* ; - "T if the current piece is 16 bit characters.") - ) - (CREATE (create STREAM using \TEXTOFD IMAGEDATA _ (create - - TEXTIMAGEDATA - )))) -) - -(/DECLAREDATATYPE 'PIECE '(POINTER POINTER FIXP FIXP FULLXPOINTER FULLXPOINTER POINTER POINTER FLAG - POINTER FLAG FLAG XPOINTER) - '((PIECE 0 POINTER) - (PIECE 2 POINTER) - (PIECE 4 FIXP) - (PIECE 6 FIXP) - (PIECE 8 FULLXPOINTER) - (PIECE 10 FULLXPOINTER) - (PIECE 12 POINTER) - (PIECE 14 POINTER) - (PIECE 14 (FLAGBITS . 0)) - (PIECE 16 POINTER) - (PIECE 16 (FLAGBITS . 0)) - (PIECE 16 (FLAGBITS . 16)) - (PIECE 18 XPOINTER)) - '20) - -(/DECLAREDATATYPE 'TEXTOBJ - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER - POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER - FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER - FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER - POINTER POINTER) - '((TEXTOBJ 0 POINTER) - (TEXTOBJ 2 POINTER) - (TEXTOBJ 4 POINTER) - (TEXTOBJ 6 POINTER) - (TEXTOBJ 8 POINTER) - (TEXTOBJ 10 POINTER) - (TEXTOBJ 12 POINTER) - (TEXTOBJ 14 POINTER) - (TEXTOBJ 16 POINTER) - (TEXTOBJ 16 (FLAGBITS . 0)) - (TEXTOBJ 18 POINTER) - (TEXTOBJ 20 POINTER) - (TEXTOBJ 22 POINTER) - (TEXTOBJ 24 POINTER) - (TEXTOBJ 26 POINTER) - (TEXTOBJ 28 POINTER) - (TEXTOBJ 30 POINTER) - (TEXTOBJ 32 POINTER) - (TEXTOBJ 34 POINTER) - (TEXTOBJ 36 POINTER) - (TEXTOBJ 38 POINTER) - (TEXTOBJ 40 POINTER) - (TEXTOBJ 42 POINTER) - (TEXTOBJ 44 POINTER) - (TEXTOBJ 44 (FLAGBITS . 0)) - (TEXTOBJ 46 FULLXPOINTER) - (TEXTOBJ 48 POINTER) - (TEXTOBJ 50 POINTER) - (TEXTOBJ 52 POINTER) - (TEXTOBJ 54 POINTER) - (TEXTOBJ 56 POINTER) - (TEXTOBJ 56 (FLAGBITS . 0)) - (TEXTOBJ 58 POINTER) - (TEXTOBJ 58 (FLAGBITS . 0)) - (TEXTOBJ 58 (FLAGBITS . 16)) - (TEXTOBJ 58 (FLAGBITS . 32)) - (TEXTOBJ 58 (FLAGBITS . 48)) - (TEXTOBJ 60 POINTER) - (TEXTOBJ 62 POINTER) - (TEXTOBJ 64 POINTER) - (TEXTOBJ 66 POINTER) - (TEXTOBJ 68 POINTER) - (TEXTOBJ 70 POINTER) - (TEXTOBJ 70 (FLAGBITS . 0)) - (TEXTOBJ 72 POINTER) - (TEXTOBJ 74 FULLXPOINTER) - (TEXTOBJ 76 POINTER) - (TEXTOBJ 78 POINTER) - (TEXTOBJ 80 POINTER) - (TEXTOBJ 82 POINTER) - (TEXTOBJ 84 POINTER) - (TEXTOBJ 86 POINTER) - (TEXTOBJ 88 POINTER) - (TEXTOBJ 88 (FLAGBITS . 0)) - (TEXTOBJ 88 (FLAGBITS . 16)) - (TEXTOBJ 90 POINTER) - (TEXTOBJ 92 POINTER) - (TEXTOBJ 94 POINTER)) - '96) - -(/DECLAREDATATYPE 'TEXTIMAGEDATA '(POINTER POINTER POINTER POINTER) - '((TEXTIMAGEDATA 0 POINTER) - (TEXTIMAGEDATA 2 POINTER) - (TEXTIMAGEDATA 4 POINTER) - (TEXTIMAGEDATA 6 POINTER)) - '8) - -(DEFOPTIMIZER TEXTPROP (TEXTOBJ PROP &OPTIONAL (VAL NIL WRITING)) - - (* ;; "compiles calls to TEXTPROP") - - [COND - ((NOT (LISTP PROP)) (* ; "property is not quoted.") - 'IGNOREMACRO) - ((NOT (EQ (CAR PROP) - 'QUOTE)) (* ; "property is not quoted.") - 'IGNOREMACRO) - [(NOT WRITING) (* ; "fetching a TEXTPROP property.") - (SELECTQ (CADR PROP) - ((READONLY READ-ONLY) - `(fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ - ,TEXTOBJ))) - ((BEING-EDITED ACTIVE) - `(fetch (TEXTOBJ TXTEDITING) of (TEXTOBJ ,TEXTOBJ))) - ((NO-NS-CHARS NONSCHARS NO-NSCHARS) - `(fetch (TEXTOBJ TXTNONSCHARS) of (TEXTOBJ - ,TEXTOBJ))) - `(LISTGET (fetch (TEXTOBJ EDITPROPS) - of (TEXTOBJ ,TEXTOBJ)) - ,PROP] - (T (* ; "storing a window property") - (SELECTQ (CADR PROP) - ((READONLY READ-ONLY) - `(REPLACE (TEXTOBJ TXTREADONLY) - OF (TEXTOBJ ,TEXTOBJ) WITH ,VAL)) - ((BEING-EDITED ACTIVE) - `(REPLACE (TEXTOBJ TXTEDITING) - OF (TEXTOBJ ,TEXTOBJ) WITH ,VAL)) - ((NO-NS-CHARS NONSCHARS NO-NSCHARS) - `(REPLACE (TEXTOBJ TXTNONSCHARS) - OF (TEXTOBJ ,TEXTOBJ) WITH ,VAL)) - `(LET* (($$TEXTOBJ$$ (TEXTOBJ ,TEXTOBJ)) - ($$PROPLST$$ (FETCH EDITPROPS OF $$TEXTOBJ$$))) - (COND - ($$PROPLST$$ (LISTPUT $$PROPLST$$ ,PROP ,VAL)) - (T (REPLACE EDITPROPS OF $$TEXTOBJ$$ - WITH (LIST ,PROP ,VAL]) - - - -(* ;; "Private data structures and constants FROM TEXTOFD") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \PCTBFreePieces 0) - -(RPAQQ \PCTBLastPieceOffset 1) - -(RPAQQ \FirstPieceOffset 2) - -(RPAQQ \SecondPieceOffset 4) - -(RPAQQ \EltsPerPiece 2) - - -(CONSTANTS (\PCTBFreePieces 0) - (\PCTBLastPieceOffset 1) - (\FirstPieceOffset 2) - (\SecondPieceOffset 4) - (\EltsPerPiece 2)) -) - -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \EDITELT DMACRO (OPENLAMBDA (ARR NO) - - (* This is equivalent to ELT, but bypasses the checking, since we "know" that - ARR is an array. Hence, much faster.) - - (GETBASEPTR (\ADDBASE2 (fetch (ARRAYP BASE) of - ARR) - NO) - 0))) - -(PUTPROPS \GETCH MACRO ((TEXTOBJ) (* jds "23-FEB-82 08:56") - (* Get the next available character - from the text being edited.) - (\BIN (fetch STREAMHINT of TEXTOBJ)))) - -(PUTPROPS \GETCHB MACRO ((TEXTOBJ) (* Get the next prior character in - the text being edited.) - (\BACKBIN (fetch STREAMHINT of TEXTOBJ)))) - -(PUTPROPS \EDITSETA DMACRO (OPENLAMBDA (ARR N VAL) - - (* Equivalent to SETA (for pointer-type arrays)%, but bypasses the bounds and - type checking. Hence MUCH faster.) - - (\RPLPTR (\ADDBASE2 (fetch (ARRAYP BASE) of ARR) - N) - 0 VAL))) - -(PUTPROPS \WORDSETA DMACRO (OPENLAMBDA (A J V) - [CHECK (AND (ARRAYP A) - (ZEROP (fetch (ARRAYP ORIG) of A)) - (EQ \ST.POS16 (fetch (ARRAYP TYP) - of A] - (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A) - J)) - (\PUTBASE (fetch (ARRAYP BASE) of A) - (IPLUS (fetch (ARRAYP OFFST) of A) - J) - V))) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV) -) -) - - - -(* ;;; "FROM TEDITPAGE") - -(DECLARE%: EVAL@COMPILE - -(RECORD PAGEFORMATTINGSTATE ( - (* ;; "Contains the state for a TEdit page-formatting job.") - - PAGE# (* ; - "The current page number. Counted from 1") - FIRSTPAGE - - (* ;; "T if the current page is the 'first page' . Is set initially, and can be set again by the user at will. Gets reset after each page image is printed.") - - MINPAGE# (* ; - "The page # of the first page to be printed, or NIL") - MAXPAGE# (* ; - "The page # of the last page to be printed, or NIL") - STATE (* ; "One of FORMATTING or SEARCHING.") - REQUIREDREGIONTYPE (* ; "If STATE is SEARCHING, the kind of box we're looking for. If STATE is :SEARCHING-FOR-EQUIVALENT-PAGE, this is the page count for the matching page.") - MAINSTREAM (* ; - "The principal textobj/stream source") - CHNO (* ; "Our position in that stream") - PRESSREGION (* ; "The press code's REGION info.") - PAGEHEADINGS (* ; - "The list of current values to be printed, indexed by heading type") - PAGE#GENERATOR (* ; "List of page numbers; later, maybe, a function to generate page numbers. Used to fill in PAGE#TEXT, below") - PAGE#TEXT (* ; "If special page numbers are in use, this is the place to take them from. PAGE# is still used for recto/verso decisions &c") - PAGEISRECTO (* ; - "T if this is a recto page, NIL if it's a VERSO page.") - PAGEFOOTNOTELINES (* ; - "A list of extant footnote lines that should appear at the next opportunity") - PAGEFLOATINGTOPLINES (* ; - "A list of lines that should float to the top of the next available place") - PAGECOUNT (* ; - "The number of pages we've formatted so far.") - PAGELINECACHE (* ; "A cache for pre-created LINEDESCRIPTOR/THISLINE sets, to avoid the overhead of re-allocating them all the time") - NEWPAGELAYOUT (* ; "If we switch page layouts in mid-document, this is where the new layout gets cached until we get started again.") - ) - PAGECOUNT _ 0) - -(DATATYPE PAGEREGION ( - (* ;; - "Describe a part of a page for page formatting. Can be made into compound descriptions.") - - REGIONFILLMETHOD (* ; - "What kind of a region this is -- TEXT, FOLIO, PAGEHEADING, etc.") - REGIONSPEC (* ; - "The page-relative region this occupies") - REGIONLOCALINFO (* ; "A PLIST for local information") - (REGIONPARENT FULLXPOINTER) (* ; - "The parent node for this box, for sub-boxes") - REGIONSUBBOXES (* ; "The sub-regions of this region") - REGIONTYPE (* ; "A user-settable region type") - )) -) - -(/DECLAREDATATYPE 'PAGEREGION '(POINTER POINTER POINTER FULLXPOINTER POINTER POINTER) - '((PAGEREGION 0 POINTER) - (PAGEREGION 2 POINTER) - (PAGEREGION 4 POINTER) - (PAGEREGION 6 FULLXPOINTER) - (PAGEREGION 8 POINTER) - (PAGEREGION 10 POINTER)) - '12) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD TEDITPAPERSIZE ( - (* ;; - "Describe the size of a sheet of paper (in points), given a paper size-name.") - - TPSNAME (* ; "The name, as a litatom") - TPSWIDTH (* ; "Paper width, in points") - TPSHEIGHT (* ; "Paper Height, in points") - TPSLANDSCAPE? (* ; - "T if we have to rotate things to print them on this paper.") - )) -) - - -(DEFMACRO \NEW-COLUMN-START (LINE FMTSPEC) - `(AND (FFETCH (LINEDESCRIPTOR 1STLN) OF ,LINE) - (EQ (FFETCH (FMTSPEC FMTCOLUMN) OF ,FMTSPEC) - 'NEXT))) - -(DEFMACRO \FIRST-COLUMN-START (LINE FMTSPEC) - `(AND (FFETCH (LINEDESCRIPTOR 1STLN) OF ,LINE) - (EQ (FFETCH (FMTSPEC FMTCOLUMN) OF ,FMTSPEC) - 'FIRST))) -) - - - -(* ;; "FROM TEDITFIND") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \AlphaNumericFlag 256) - -(RPAQQ \AlphaFlag 512) - -(RPAQQ \OneCharPattern 1024) - -(RPAQQ \AnyStringPattern 1025) - -(RPAQQ \OneAlphaPattern 1026) - -(RPAQQ \AnyAlphaPattern 1027) - -(RPAQQ \OneNonAlphaPattern 1028) - -(RPAQQ \AnyNonAlphaPattern 1029) - -(RPAQQ \LeftBracketPattern 1030) - -(RPAQQ \RightBracketPattern 1031) - -(RPAQQ \SpecialPattern 1024) - - -(CONSTANTS (\AlphaNumericFlag 256) - (\AlphaFlag 512) - (\OneCharPattern 1024) - (\AnyStringPattern 1025) - (\OneAlphaPattern 1026) - (\AnyAlphaPattern 1027) - (\OneNonAlphaPattern 1028) - (\AnyNonAlphaPattern 1029) - (\LeftBracketPattern 1030) - (\RightBracketPattern 1031) - (\SpecialPattern 1024)) -) -) - - - -(* ;; " FROM TEDITLOOKS") - -(DECLARE%: EVAL@COMPILE - -(DATATYPE CHARLOOKS ( - (* ;; - "Describes the appearance (%"Looks%") of characters in a TEdit document.") - - CLFONT (* ; - "The font descriptor for these characters") - CLNAME - - (* ;; "Name of the font (e.g., HELVETICA) THIS FIELD IS A HINT, OR FOR USE IN CHARLOOKS-BUILDING CODE. USE FONTPROP TO GET THE RIGHT VALUE FROM CLFONT.") - - CLSIZE (* ; "Font size, in points") - (CLITAL FLAG) (* ; - "T if the characters are italic, else NIL") - (CLBOLD FLAG) (* ; - "T if the characters are bold, else NIL") - (CLULINE FLAG) (* ; - "T if the characters are to be underscored, else NIL") - (CLOLINE FLAG) (* ; - "T if the characters are to be overscored, else NIL") - (CLSTRIKE FLAG) (* ; - "T if the characters are to be struck thru, else nil.") - CLOFFSET (* ; - "A superscripting offset in points (?) else NIL (SUBSCRIPTING IF NEGATIVE.)") - (CLSMALLCAP FLAG) (* ; "T if small caps, else NIL") - (CLINVERTED FLAG) (* ; - "T if the characters are to be shown white-on-black") - (CLPROTECTED FLAG) (* ; - "T if chars can't be selected, else NIL") - (CLINVISIBLE FLAG) (* ; - "T if TEDIT is to ignore these chars; else NIL") - (CLSELHERE FLAG) - - (* ;; "T if TEDIT can put selection after this char (for menu blanks) else NIL; anything typed after this char will NOT BE PROTECTED.") - - (CLCANCOPY FLAG) - - (* ;; "T if this text can be selected for copying, even tho protected (it will become unprotected after the copy; for Dribble/TTY interface)") - - CLSTYLE (* ; - "The style to be used in marking these characters; overridden by the other fields") - CLUSERINFO (* ; - "Any information that an outsider wants to include") - CLLEADER (* ; - "For creating dotted and other kinds of leader") - CLRULES - - (* ;; "For arbitrarily-places horizontal rules. List of pairs, of (widthinpts . offsetfrombaselineinpts). Should be taken account of in ascent/descent calcs.") - - (CLMARK FLAG) - - (* ;; "Used for a mark-&-sweep of looks at PUT time -- T means this set of looks really IS in use in the document") - - ) - CLOFFSET _ 0) - -(DATATYPE FMTSPEC ( - (* ;; - "Describe the paragraph formatting for a paragraph in a TEdit document.") - - 1STLEFTMAR (* ; - "Left margin of the first line of the paragraph") - LEFTMAR (* ; - "Left margin of the rest of the lines in the paragraph") - RIGHTMAR (* ; "Right margin for the paragraph") - LEADBEFORE (* ; - "Leading above the paragraph's first line, in points") - LEADAFTER (* ; - "Leading below the paragraph's bottom line, in points. NOT IMPLEMENTED.") - LINELEAD (* ; - "Leading between lines, in points. Actually, this space is added BELOW each line in the para.") - FMTBASETOBASE (* ; -"The baseline-to-baseline spacing between lines in this paragraph. THIS OVERRIDES THE LINE LEADING") - TABSPEC (* ; - "The list of tabs for this paragraph, including CAR for a default tab width") - QUAD (* ; - "How the para is formatted: one of LEFT, RIGHT, CENTERED, JUSTIFIED") - FMTSTYLE (* ; - "The STYLE that controls this paragraph's appearance") - FMTCHARSTYLES (* ; "The characterstyles that control the appearance of characters in this para (maybe? may be part of the fmtstyle.)") - FMTUSERINFO (* ; "Space for a PLIST of user info") - FMTSPECIALX (* ; - "A special horizontal location on the printed page for this para.") - FMTSPECIALY (* ; - "A special vertical location on the page for this para") - (FMTHEADINGKEEP FLAG) (* ; - "This para should be kept with the top line or so of the next para..") - FMTPARATYPE (* ; - "What kind of para this is: TEXT, PAGEHEADING, whatever") - FMTPARASUBTYPE (* ; - "Sub type of the type, e.g., what KIND of page heading this is.") - FMTNEWPAGEBEFORE (* ; "Start a new box (if T) or back up the page formatting tree to make a new box of the type named in the value -- by going the least distance back up the tree, then back down until you find that kind of box.") - FMTNEWPAGEAFTER (* ; "Similarly") - FMTKEEP (* ; - "For information about how this paragraph is to be kept with other paragraphs.") - FMTCOLUMN (* ; - "For setting up side-by-side paragraphs easily ala BravoX") - FMTVERTRULES (* ; - "For Keeping track of vertical rules in force") - (FMTMARK FLAG) (* ; "Used to keep track of which PARALOOKSs are really being used -- a mark & collect is done just before a PUT, so that only 'real' PARALOOKSs make it into the file") - (* ; "Used for a mark&sweep of para looks at PUT time -- T means this looks really IS in use in the document, so it makes sense to save it on the file.") - (FMTHARDCOPY FLAG) (* ; - "T if this paragraph is to be displayed in hardcopy-format.") - FMTREVISED (* ; "T (or perhaps a revision level or revision-mark spec??) if this paragraph is to be marked as changed on output.") - ) - TABSPEC _ (CONS NIL NIL)) - -(DATATYPE PENDINGTAB ( - (* ;; "The data structure for a tab, within the line formatter, that we haven't finished dealing with yet, e.g. a centered tab where you need to wait for AFTER the centered text to do the formatting.") - - PTNEWTX - - (* ;; "An updated TX, being passed back to the line formatter. This results from the resolution of an old RIGHT, CENTERED, or DECIMAL tab, which changed the width of a prior tab.") - - PTOLDTAB (* ; "The pending tab") - PTTYPE (* ; "Its tab type") - PTTABX (* ; "Its nominal X position") - (PTWBASE FULLXPOINTER) (* ; - "The WBASE for its width, for updating when we've figured out how wide the tab really is") - PTOLDTX (* ; - "The TX as of when the tab was encountered.") - )) -) - -(/DECLAREDATATYPE 'CHARLOOKS - '(POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG FLAG FLAG - POINTER POINTER POINTER POINTER FLAG) - '((CHARLOOKS 0 POINTER) - (CHARLOOKS 2 POINTER) - (CHARLOOKS 4 POINTER) - (CHARLOOKS 4 (FLAGBITS . 0)) - (CHARLOOKS 4 (FLAGBITS . 16)) - (CHARLOOKS 4 (FLAGBITS . 32)) - (CHARLOOKS 4 (FLAGBITS . 48)) - (CHARLOOKS 2 (FLAGBITS . 0)) - (CHARLOOKS 6 POINTER) - (CHARLOOKS 6 (FLAGBITS . 0)) - (CHARLOOKS 6 (FLAGBITS . 16)) - (CHARLOOKS 6 (FLAGBITS . 32)) - (CHARLOOKS 6 (FLAGBITS . 48)) - (CHARLOOKS 2 (FLAGBITS . 16)) - (CHARLOOKS 2 (FLAGBITS . 32)) - (CHARLOOKS 8 POINTER) - (CHARLOOKS 10 POINTER) - (CHARLOOKS 12 POINTER) - (CHARLOOKS 14 POINTER) - (CHARLOOKS 14 (FLAGBITS . 0))) - '16) - -(/DECLAREDATATYPE 'FMTSPEC - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER - FLAG FLAG POINTER) - '((FMTSPEC 0 POINTER) - (FMTSPEC 2 POINTER) - (FMTSPEC 4 POINTER) - (FMTSPEC 6 POINTER) - (FMTSPEC 8 POINTER) - (FMTSPEC 10 POINTER) - (FMTSPEC 12 POINTER) - (FMTSPEC 14 POINTER) - (FMTSPEC 16 POINTER) - (FMTSPEC 18 POINTER) - (FMTSPEC 20 POINTER) - (FMTSPEC 22 POINTER) - (FMTSPEC 24 POINTER) - (FMTSPEC 26 POINTER) - (FMTSPEC 26 (FLAGBITS . 0)) - (FMTSPEC 28 POINTER) - (FMTSPEC 30 POINTER) - (FMTSPEC 32 POINTER) - (FMTSPEC 34 POINTER) - (FMTSPEC 36 POINTER) - (FMTSPEC 38 POINTER) - (FMTSPEC 40 POINTER) - (FMTSPEC 40 (FLAGBITS . 0)) - (FMTSPEC 40 (FLAGBITS . 16)) - (FMTSPEC 42 POINTER)) - '44) - -(/DECLAREDATATYPE 'PENDINGTAB '(POINTER POINTER POINTER POINTER FULLXPOINTER POINTER) - '((PENDINGTAB 0 POINTER) - (PENDINGTAB 2 POINTER) - (PENDINGTAB 4 POINTER) - (PENDINGTAB 6 POINTER) - (PENDINGTAB 8 FULLXPOINTER) - (PENDINGTAB 10 POINTER)) - '12) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \SMALLPIN MACRO (OPENLAMBDA (STREAM) - (SIGNED (create WORD - HIBYTE _ (\BIN STREAM) - LOBYTE _ (\BIN STREAM)) - BITSPERWORD))) - -(PUTPROPS \SMALLPOUT MACRO (OPENLAMBDA (STREAM W) - (\BOUT STREAM (LOGAND 255 (LRSH W 8))) - (\BOUT STREAM (LOGAND W 255)))) - -(PUTPROPS ONOFF MACRO [OPENLAMBDA (VAL) - (COND - (VAL 'ON) - (T 'OFF]) -) -) - - - -(* ;; "FROM TEDITMENU") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD MBUTTON NIL [TYPE? (AND (IMAGEOBJP DATUM) - (OR (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN) - 'MB.DISPLAY) - (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN) - 'MB.THREESTATE.DISPLAY) - (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN) - '\TEXTMENU.TOGGLE.DISPLAY]) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD NWAYBUTTON NIL [TYPE? (AND (IMAGEOBJP DATUM) - (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN) - 'MB.NB.DISPLAYFN]) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD MARGINBAR (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE) - [TYPE? (AND (IMAGEOBJP DATUM) - (EQ (IMAGEOBJPROP DATUM 'DISPLAYFN) - 'MB.MARGINBAR.DISPLAYFN]) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD TAB (TABX . TABKIND)) -) -) -(DECLARE%: EVAL@COMPILE - -(TYPERECORD MB.3STATE ( - (* ;; "Describes a 3-state menu button.") - - MBLABEL (* ; - "Label for the button on the screen") - MBFONT (* ; - "Font the label text should appear in") - MBCHANGESTATEFN (* ; - "Function to call when the button's state changes") - MBINITSTATE (* ; "Button's initial state.") - ) - MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD)) - -(TYPERECORD MB.BUTTON (MBLABEL MBBUTTONEVENTFN MBFONT) - MBBUTTONEVENTFN _ 'MB.DEFAULTBUTTON.FN MBFONT _ (FONTCREATE 'HELVETICA 8 - 'BOLD)) - -(TYPERECORD MB.INSERT (MBINITENTRY)) - -(TYPERECORD MB.MARGINBAR (ignoredfield)) - -(TYPERECORD MB.NWAY (MBBUTTONS MBFONT MBCHANGESTATEFN MBINITSTATE MBMAXITEMSPERLINE) - MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD)) - -(TYPERECORD MB.TEXT (MBSTRING MBFONT)) - -(TYPERECORD MB.TOGGLE (MBTEXT MBFONT MBCHANGESTATEFN MBINITSTATE) - MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD)) -) - -(DEFMACRO WITHOUT-UPDATES (TEXTOBJ SCRATCHSEL &BODY BODY) - - (* ;; "For TEdit windows, run BODY without updating the edit window for TEXTOBJ. This is useful if you're making a log of changes to a document at one time, where the changes are in essence atomic, and you don't need to see intermediate results. It's also a good bit faster than constant updating.") - - (* ;; "TEXTOBJ is the TEXTOBJ for the document you'll be modifying.") - - (* ;; "SCRATCHSEL should be the scratch selection (often used in this work)") - - `[LET [(OLD-UNWIND-FLAG (FETCH (TEXTOBJ TXTDON'TUPDATE) OF ,TEXTOBJ] - (CL:UNWIND-PROTECT - (PROGN (replace (TEXTOBJ TXTDON'TUPDATE) of ,TEXTOBJ with T) - ,@BODY) - (\SHOWSEL ,SCRATCHSEL NIL NIL) - (replace SET of ,SCRATCHSEL with NIL) - (\TEDIT.MARK.LINES.DIRTY ,TEXTOBJ 1 (fetch (TEXTOBJ TEXTLEN) of ,TEXTOBJ)) - (replace (TEXTOBJ TXTDON'TUPDATE) of ,TEXTOBJ with OLD-UNWIND-FLAG) - (TEDIT.UPDATE.SCREEN ,TEXTOBJ))]) - - - -(* ;; "FROM TEDITHISTORY") - -(DECLARE%: EVAL@COMPILE - -(RECORD TEDITHISTORYEVENT ( - (* ;; "Describes one event on the TEdit edit history list.") - - THACTION (* ; - "A LITATOM, specifying what the event was") - THPOINT (* ; - "Was the selection to the left or right?") - THLEN (* ; "The # of chars involved") - THCH# (* ; "The starting ch#") - THFIRSTPIECE (* ; "First piece involved") - THOLDINFO (* ; "Old info, for undo") - THAUXINFO (* ; - "Auxiliary info about the event, primarily for redo") - THTEXTOBJ - - (* ;; "Place to remember a second textobj, for those like MOVE who need to remember both a source and a destination.") - - ) - THPOINT _ 'LEFT) -) - - - -(* ;; "FROM TEDITFILE") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \PieceDescriptorLOOKS 0) - -(RPAQQ \PieceDescriptorOBJECT 1) - -(RPAQQ \PieceDescriptorPARA 2) - -(RPAQQ \PieceDescriptorPAGEFRAME 3) - -(RPAQQ \PieceDescriptorCHARLOOKSLIST 4) - -(RPAQQ \PieceDescriptorPARALOOKSLIST 5) - -(RPAQQ \PieceDescriptorSAFEOBJECT 6) - - -(CONSTANTS (\PieceDescriptorLOOKS 0) - (\PieceDescriptorOBJECT 1) - (\PieceDescriptorPARA 2) - (\PieceDescriptorPAGEFRAME 3) - (\PieceDescriptorCHARLOOKSLIST 4) - (\PieceDescriptorPARALOOKSLIST 5) - (\PieceDescriptorSAFEOBJECT 6)) -) -) - - - -(* ;; "FROM TEDITCOMMAND") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(PUTPROPS \INSERT\TTY\BUFFER MACRO (NIL (\TEDIT.INSERT.TTY.BUFFER ISCRSTRING IPASSSTRING - TEXTOBJ SEL))) - -(PUTPROPS \TEDIT.MOUSESTATE MACRO (BUTTON - - (* Test to see if only the specified mouse button is down. - DOES NOT call GETMOUSESTATE, so the mouse-button info is the same as the last - time it WAS called.) - - (SELECTQ (CAR BUTTON) - (LEFT '(IEQP LASTMOUSEBUTTONS 4)) - (MIDDLE '(IEQP LASTMOUSEBUTTONS 1)) - (RIGHT '(IEQP LASTMOUSEBUTTONS 2)) - (SHOULDNT)))) - -(PUTPROPS \TEDIT.CHECK MACRO - [ARGS (COND - [(AND (BOUNDP 'CHECK) - CHECK) - (CONS 'PROGN (for I in ARGS as J on ARGS - when (NOT (STRINGP I)) - collect (LIST 'OR I (LIST 'HELP - "TEdit consistency-check failure [RETURN to continue]: " - (COND - ((STRINGP (CADR J))) - (T (KWOTE I] - (T (CONS COMMENTFLG ARGS]) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(ACCESSFNS TEDITTERMCODE ((TTCLASS (LOGAND DATUM 224)) - (TTDECODE (LOGAND DATUM 31)))) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ NONE.TTC 0) - -(RPAQQ CHARDELETE.TTC 1) - -(RPAQQ WORDDELETE.TTC 2) - -(RPAQQ DELETE.TTC 3) - -(RPAQQ FUNCTIONCALL.TTC 4) - -(RPAQQ REDO.TTC 5) - -(RPAQQ UNDO.TTC 6) - -(RPAQQ CMD.TTC 7) - -(RPAQQ NEXT.TTC 8) - -(RPAQQ EXPAND.TTC 9) - -(RPAQQ PUNCT.TTC 20) - -(RPAQQ TEXT.TTC 21) - -(RPAQQ WHITESPACE.TTC 22) - - -(CONSTANTS (NONE.TTC 0) - (CHARDELETE.TTC 1) - (WORDDELETE.TTC 2) - (DELETE.TTC 3) - (FUNCTIONCALL.TTC 4) - (REDO.TTC 5) - (UNDO.TTC 6) - (CMD.TTC 7) - (NEXT.TTC 8) - (EXPAND.TTC 9) - (PUNCT.TTC 20) - (TEXT.TTC 21) - (WHITESPACE.TTC 22)) -) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ MSPACE 153) - -(RPAQQ NSPACE 152) - -(RPAQQ THINSPACE 159) - -(RPAQQ FIGSPACE 154) - - -(CONSTANTS (MSPACE 153) - (NSPACE 152) - (THINSPACE 159) - (FIGSPACE 154)) -) -) - - - -(* ;; "FROM TEDITWINDOW") - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(DATATYPE TEDITCARET (TCNOWTIME - - (* Used to hold the current time, when checking to see if a transition is due) - - TCTHENTIME (* Time when the next transition is - to take place) - TCFORCEDDOWN (* TCFORCEDOWN = T means - (Make the caret visible at the next - call to \EDIT.FLIPCARET.)) - TCUP - - (* TCUP = T => The caret is NOT VISIBLE. - Used to track the current state of the caret) - - TCCARETDS (* The display stream that the caret - appears in) - TCCURSORBM (* The CURSOR representing the caret) - TCCARETRATE (* %# of MSEC between caret up/down - transitions) - TCFORCEUP - - (* T => The caret is not allowed to become visible. - Used to keep the caret up during screen updates) - - TCCARETX (* X position in the window that the - caret appears at) - TCCARETY (* Y position in the window where - the caret appears) - TCCARET (* A lisp CARET to be flashed - (eventually)) - ) - TCNOWTIME _ (CREATECELL \FIXP) - TCTHENTIME _ (CREATECELL \FIXP) - TCCURSORBM _ BXCARET TCCARETRATE _ \CARETRATE TCUP _ T TCCARET _ - (\CARET.CREATE BXCARET)) -) - -(/DECLAREDATATYPE 'TEDITCARET '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER) - '((TEDITCARET 0 POINTER) - (TEDITCARET 2 POINTER) - (TEDITCARET 4 POINTER) - (TEDITCARET 6 POINTER) - (TEDITCARET 8 POINTER) - (TEDITCARET 10 POINTER) - (TEDITCARET 12 POINTER) - (TEDITCARET 14 POINTER) - (TEDITCARET 16 POINTER) - (TEDITCARET 18 POINTER) - (TEDITCARET 20 POINTER)) - '22) -) - -(/DECLAREDATATYPE 'TEDITCARET '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER) - '((TEDITCARET 0 POINTER) - (TEDITCARET 2 POINTER) - (TEDITCARET 4 POINTER) - (TEDITCARET 6 POINTER) - (TEDITCARET 8 POINTER) - (TEDITCARET 10 POINTER) - (TEDITCARET 12 POINTER) - (TEDITCARET 14 POINTER) - (TEDITCARET 16 POINTER) - (TEDITCARET 18 POINTER) - (TEDITCARET 20 POINTER)) - '22) - - - -(* ;; "FROM PCTREE added by Nakamura") - -(DECLARE%: EVAL@COMPILE - -(DATATYPE PCTNODE (CHNUM (* ; - "Character #of piece in this node.") - PCE (* ; "PIECE ") - LO (* ; - "Subtree these nodes' ch#are less than this node.") - HI (* ; - " Subtree these nodes' ch#are more than this node.") - BF (* ; "Balance factor.") - (* ; - "1: Right(HI) Subtree is higher than left(lo) subtree.") - (* ; - "0: Right subtree and left subtree are same height") - (* ; - "-1: Right(HI) Subtree is shorter than left(lo) subtree.") - RANK (* ; "(# of nodes in left subtree) +1") - ) - CHNUM _ 0 BF _ 0 RANK _ 1) -) - -(/DECLAREDATATYPE 'PCTNODE '(POINTER POINTER POINTER POINTER POINTER POINTER) - '((PCTNODE 0 POINTER) - (PCTNODE 2 POINTER) - (PCTNODE 4 POINTER) - (PCTNODE 6 POINTER) - (PCTNODE 8 POINTER) - (PCTNODE 10 POINTER)) - '12) - - - -(* ;;; "THE END") - - - - -(* ;; -"Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character " -) - -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ NOTBEFORE.LB 1) - -(RPAQQ NOTAFTER.LB 2) - -(RPAQQ BEFORE.LB 4) - -(RPAQQ AFTER.LB 8) - -(RPAQQ DISAPPEAR-IF-NOT-SPLIT.LB 16) - -(RPAQQ NEWCHAR-IF-SPLIT.LB 32) - - -(CONSTANTS (NOTBEFORE.LB 1) - (NOTAFTER.LB 2) - (BEFORE.LB 4) - (AFTER.LB 8) - (DISAPPEAR-IF-NOT-SPLIT.LB 16) - (NEWCHAR-IF-SPLIT.LB 32)) -) -) -(PUTPROPS TEDITDCL COPYRIGHT ("Venue" 1986 1987 1988 1989 1990 1991 1993 1994 1995)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/library/new/TEDITDCL.LCOM b/obsolete/library/new/TEDITDCL.LCOM deleted file mode 100644 index 1cbff1f1..00000000 --- a/obsolete/library/new/TEDITDCL.LCOM +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Mar-95 14:06:27" ("compiled on " {DSK}library>new>TEDITDCL.;1) " 2-Feb-95 10:57:29" bcompl'd in "Medley 2-Feb-95 ..." dated " 2-Feb-95 12:09:48") (FILECREATED "22-Mar-95 18:05:53" {DSK}library>new>TEDITDCL.;1 86457 changes to%: (RECORDS PIECE) previous date%: "25-Aug-94 10:53:00" {DSK}library>TEDITDCL.;2) (PRETTYCOMPRINT TEDITDCLCOMS) (RPAQQ TEDITDCLCOMS ((* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.") (* ;; "FROM TEDIT") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))) (* ;; "FROM TEDITSELECTION") (RECORDS SELECTION) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (COPYSELSHADE 30583) (COPYLOOKSSELSHADE 30583) (EDITMOVESHADE -1) (EDITGRAY 32800))) (VARS TEDITFILES) (* ;; "FROM TEDITSCREEN") (RECORDS THISLINE LINEDESCRIPTOR LINECACHE) (DECLARE%: EVAL@COMPILE DONTCOPY ( CONSTANTS (LMInvisibleRun 401) (LMLooksChange 400))) (* ;; "FROM TEXTOFD") (RECORDS EDITMARK) (RECORDS PIECE TEXTOBJ TEXTIMAGEDATA TEXTSTREAM) (OPTIMIZERS TEXTPROP) (COMS (* ;; "Private data structures and constants FROM TEXTOFD") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS ( \PCTBFreePieces 0) (\PCTBLastPieceOffset 1) (\FirstPieceOffset 2) (\SecondPieceOffset 4) ( \EltsPerPiece 2)) (MACROS \EDITELT \GETCH \GETCHB \EDITSETA \WORDSETA) (GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV))) (* ;;; "FROM TEDITPAGE") (RECORDS PAGEFORMATTINGSTATE PAGEREGION) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITPAPERSIZE) (FUNCTIONS \NEW-COLUMN-START \FIRST-COLUMN-START)) (* ;; "FROM TEDITFIND") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\AlphaNumericFlag 256) (\AlphaFlag 512) (\OneCharPattern 1024) (\AnyStringPattern 1025) (\OneAlphaPattern 1026) (\AnyAlphaPattern 1027) ( \OneNonAlphaPattern 1028) (\AnyNonAlphaPattern 1029) (\LeftBracketPattern 1030) (\RightBracketPattern 1031) (\SpecialPattern 1024))) (* ;; " FROM TEDITLOOKS") (RECORDS CHARLOOKS FMTSPEC PENDINGTAB) ( DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \SMALLPIN \SMALLPOUT ONOFF)) (* ;; "FROM TEDITMENU") ( DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MBUTTON)) (INITRECORDS MBUTTON) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS NWAYBUTTON)) (INITRECORDS NWAYBUTTON) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MARGINBAR)) (INITRECORDS MARGINBAR) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TAB)) (RECORDS MB.3STATE MB.BUTTON MB.INSERT MB.MARGINBAR MB.NWAY MB.TEXT MB.TOGGLE) (FUNCTIONS WITHOUT-UPDATES) (* ;; "FROM TEDITHISTORY") (RECORDS TEDITHISTORYEVENT) (* ;; "FROM TEDITFILE") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PieceDescriptorLOOKS 0) (\PieceDescriptorOBJECT 1) (\PieceDescriptorPARA 2) ( \PieceDescriptorPAGEFRAME 3) (\PieceDescriptorCHARLOOKSLIST 4) (\PieceDescriptorPARALOOKSLIST 5) ( \PieceDescriptorSAFEOBJECT 6))) (* ;; "FROM TEDITCOMMAND") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \INSERT\TTY\BUFFER \TEDIT.MOUSESTATE \TEDIT.CHECK)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITTERMCODE)) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NONE.TTC 0) (CHARDELETE.TTC 1) ( WORDDELETE.TTC 2) (DELETE.TTC 3) (FUNCTIONCALL.TTC 4) (REDO.TTC 5) (UNDO.TTC 6) (CMD.TTC 7) (NEXT.TTC 8) (EXPAND.TTC 9) (PUNCT.TTC 20) (TEXT.TTC 21) (WHITESPACE.TTC 22))) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MSPACE 153) (NSPACE 152) (THINSPACE 159) (FIGSPACE 154))) (* ;; "FROM TEDITWINDOW") ( DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITCARET)) (INITRECORDS TEDITCARET) (* ;; "FROM PCTREE added by Nakamura") (RECORDS PCTNODE) (* ;;; "THE END") (COMS (* ;; "Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character " ) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NOTBEFORE.LB 1) (* ; "Must not break before this character (e.g. Japanese right-paren)") (NOTAFTER.LB 2) (* ; "Must not break after this character (e.g. Japanese open-quote)") (BEFORE.LB 4) (* ; "OK to break before this character, provided it's OK to break after the prior char (true of most non-white-space)" ) (AFTER.LB 8) (* ; "OK to break after this char, if it's OK to break before the next one (true of most white space)") ( DISAPPEAR-IF-NOT-SPLIT.LB 16) (* ; "This character shouldn't be rendered if it isn't the last char on the line (non-breaking hyphen has this)" ) (NEWCHAR-IF-SPLIT.LB 32) (* ; "Look this char up in *TEDIT-SPLITCHAR-HASH* if this IS the last character on a line, and render it as the char we found." )))))) (DATATYPE SELECTION ((* ;; "Description of a piece of selected text for TEdit. Text has to be selected before it can be operated on by the user." ) Y0 (* ; "Y value of topmost line of selection") X0 (* ; "X value of left edge of selection") DX (* ; "Width of the selection, if it's on one line.") CH# (* ; "CH# of the first selected character") XLIM (* ; "X value of right edge of last selected character") CHLIM (* ; "CH# of the last character in the selection") DCH (* ; "# of characters selected (can be zero, for point selection.)") L1 (* ; "-> line descriptor for the line where the first selected character is") LN (* ; "-> line descriptor for the line which contains the end of the selection") YLIM (* ; "Y value of the bottom of the line that ends the selection") POINT (* ; "Which end should the caret appear at? (LEFT or RIGHT)") (SET FLAG) (* ; "T if this selection is real; NIL if not") (\TEXTOBJ FULLXPOINTER) (* ; "TEXTOBJ that describes the selected text") SELKIND (* ; "What kind of selection? CHAR or WORD or LINE or PARA") HOW (* ; "SHADE used to highlight this selection") HOWHEIGHT (* ; "Height of the highlight (1 usually, full line for delete selection...)") (HASCARET FLAG) (* ; "T if there should be a caret for this selection") SELOBJ (* ; "If this selection is inside an object, which object?") (ONFLG FLAG) (* ; "T if the selection is highlighted on the screen, else NIL") SELOBJINFO (* ; "A Place for the selected object to put info about selection inside itself.")) SET _ NIL HOW _ BLACKSHADE HOWHEIGHT _ 1 HASCARET _ T Y0 _ 0 X0 _ 0 POINT _ (QUOTE LEFT) L1 _ (LIST NIL) LN _ (LIST NIL)) (/DECLAREDATATYPE (QUOTE SELECTION) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER FLAG POINTER FLAG POINTER)) (QUOTE ((SELECTION 0 POINTER) (SELECTION 2 POINTER) (SELECTION 4 POINTER) (SELECTION 6 POINTER) ( SELECTION 8 POINTER) (SELECTION 10 POINTER) (SELECTION 12 POINTER) (SELECTION 14 POINTER) (SELECTION 16 POINTER) (SELECTION 18 POINTER) (SELECTION 20 POINTER) (SELECTION 20 (FLAGBITS . 0)) (SELECTION 22 FULLXPOINTER) (SELECTION 24 POINTER) (SELECTION 26 POINTER) (SELECTION 28 POINTER) (SELECTION 28 ( FLAGBITS . 0)) (SELECTION 30 POINTER) (SELECTION 30 (FLAGBITS . 0)) (SELECTION 32 POINTER))) (QUOTE 34 )) (RPAQQ TEDITFILES (PCTREE TEXTOFD TEDIT TEDITABBREV TEDITCOMMAND TEDITDCL TEDITFILE TEDITFIND TEDITFNKEYS TEDITHCPY TEDITHISTORY TEDITLOOKS TEDITMENU TEDITPAGE TEDITSCREEN TEDITSELECTION TEDITWINDOW)) (DATATYPE THISLINE ((* ;; "Cache for line-related character location info, for selection and line-display code to use.") (DESC FULLXPOINTER) (* ; "Line descriptor for the line this describes now") LEN (* ; "Length of the line in characters") CHARS (* ;; "Array of character codes (or objects) on the line (charcode of 400 => dummy entry for looks change--go get next entry in LOOKS)" ) WIDTHS (* ; "Array of each character's width in points") LOOKS (* ; "Array of any looks changes within the line. LOOKS (0) = starting character looks for the line") TLSPACEFACTOR (* ; "The SPACEFACTOR to be used in printing this line") TLFIRSTSPACE (* ; "The first space to which SPACEFACTOR is to apply. This is used so that spaces to the left of a TAB have their default width." )) LEN _ 0 CHARS _ (ARRAY 512 (QUOTE POINTER) 0 0) WIDTHS _ (ARRAY 512 (QUOTE POINTER) 0 0) LOOKS _ ( ARRAY 512 (QUOTE POINTER) NIL 0) TLFIRSTSPACE _ 0) (DATATYPE LINEDESCRIPTOR ((* ;; "Description of a single line of formatted text, either on the display or for a printed page.") YBOT ( * ; "Y value for the bottom of the line (below the descent)") YBASE (* ; "Yvalue for the base line the characters sit on") LEFTMARGIN (* ; "Left margin, in screen points") RIGHTMARGIN (* ; "Right margin, in screen points") LXLIM (* ; "X value of right edge of rightmost character on the line (may exceed right margin, if char is a space.)" ) SPACELEFT (* ; "Space left on the line, ignoring trailing blanks & CRs.") LHEIGHT (* ; "Total height of hte line, Ascent+Descent.") ASCENT (* ; "Ascent of the line above YBASE") DESCENT (* ; "How far line descends below YBASE") LTRUEDESCENT (* ; "The TRUE DESCENT for this line, unadjusted for line leading.") LTRUEASCENT (* ; "The TRUE ASCENT for this line, unadjusted for pre-paragraph leading.") CHAR1 (* ; "CH# of the first character on the line.") CHARLIM (* ; "CH# of the last character on the line") CHARTOP (* ; "CH# of the character which forced the line break (may exceed CHARLIM)") NEXTLINE (* ; "Next line chain pointer") (PREVLINE FULLXPOINTER) (* ; "Previous line chain pointer") LMARK (* ; "One of SOLID, GREY, NIL. Tells what kind of special-line marker should be put in the left margin for this paragraph. (For hardcopy, can also be an indicator for special processing?)" ) LTEXTOBJ (* ; "A cached TEXTOBJ that this line took its text from. Used in hardcopy to disambiguate when chno's should be updated..." ) CACHE (* ; "A cached THISLINE, for keeping hardcopy info around while we crunch with the line descriptors to make things fit." ) LDOBJ (* ; "The object which lies behind this line of text, for updating, etc.") LFMTSPEC (* ; "The format spec for this line's paragraph (eventually)") (DIRTY FLAG) (* ; "T if this line has changed since it was last formatted.") (CR\END FLAG) (* ; "T if this line ends with a CR.") (DELETED FLAG) (* ; "T if this line has been completely deleted since it was last formatted or displayed. (Used by deletion routines to detect garbage lines)" ) (LHASPROT FLAG) (* ; "This line contains protected text.") (LHASTABS FLAG) (* ; "If this line has a tab in it, this is the line-relative ch# of the final tab. This is to let us punt properly with tabs in a line." ) (1STLN FLAG) (* ; "This line is the first line in a paragraph") (LSTLN FLAG) (* ; "This is the last line in a paragraph")) CHARLIM _ 1000000 NEXTLINE _ NIL PREVLINE _ NIL DIRTY _ NIL YBOT _ 0 YBASE _ 0 LEFTMARGIN _ 0 DELETED _ NIL) (DATATYPE LINECACHE ((* ;; "Image cache for display lines.") LCBITMAP (* ; "The bitmap that will be used by this instance of the cache") (LCNEXTCACHE FULLXPOINTER) (* ; "The next cache in the chain, for screen updates."))) (/DECLAREDATATYPE (QUOTE THISLINE) (QUOTE (FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((THISLINE 0 FULLXPOINTER) (THISLINE 2 POINTER) (THISLINE 4 POINTER) (THISLINE 6 POINTER) (THISLINE 8 POINTER) (THISLINE 10 POINTER) (THISLINE 12 POINTER))) (QUOTE 14)) (/DECLAREDATATYPE (QUOTE LINEDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG)) (QUOTE ((LINEDESCRIPTOR 0 POINTER) ( LINEDESCRIPTOR 2 POINTER) (LINEDESCRIPTOR 4 POINTER) (LINEDESCRIPTOR 6 POINTER) (LINEDESCRIPTOR 8 POINTER) (LINEDESCRIPTOR 10 POINTER) (LINEDESCRIPTOR 12 POINTER) (LINEDESCRIPTOR 14 POINTER) ( LINEDESCRIPTOR 16 POINTER) (LINEDESCRIPTOR 18 POINTER) (LINEDESCRIPTOR 20 POINTER) (LINEDESCRIPTOR 22 POINTER) (LINEDESCRIPTOR 24 POINTER) (LINEDESCRIPTOR 26 POINTER) (LINEDESCRIPTOR 28 POINTER) ( LINEDESCRIPTOR 30 FULLXPOINTER) (LINEDESCRIPTOR 32 POINTER) (LINEDESCRIPTOR 34 POINTER) ( LINEDESCRIPTOR 36 POINTER) (LINEDESCRIPTOR 38 POINTER) (LINEDESCRIPTOR 40 POINTER) (LINEDESCRIPTOR 40 (FLAGBITS . 0)) (LINEDESCRIPTOR 40 (FLAGBITS . 16)) (LINEDESCRIPTOR 40 (FLAGBITS . 32)) ( LINEDESCRIPTOR 40 (FLAGBITS . 48)) (LINEDESCRIPTOR 38 (FLAGBITS . 0)) (LINEDESCRIPTOR 38 (FLAGBITS . 16)) (LINEDESCRIPTOR 38 (FLAGBITS . 32)))) (QUOTE 42)) (/DECLAREDATATYPE (QUOTE LINECACHE) (QUOTE (POINTER FULLXPOINTER)) (QUOTE ((LINECACHE 0 POINTER) ( LINECACHE 2 FULLXPOINTER))) (QUOTE 4)) (RECORD EDITMARK ((* ;; "Used for fast access to a given place in the text--a %"Marker%". It consists of the piece, and the offset within the piece, and the piece number within the piece table. That's everything that's needed to set a text stream up quickly to start reading from a given place." ) PC PCOFF . PCNO)) (DATATYPE PIECE ((* ; "The piece describes either a string or part of a file. , or a generalized OBJECT.") PSTR (* ; "The string where this piece's text resides, or NIL") PFILE (* ; "The file which contains this piece's text, or NIL") (PFPOS FIXP) (* ; "The FILEPTR of the start of the piece in the file") (PLEN FIXP) (* ; "Length of the piece, in characters.") (NEXTPIECE FULLXPOINTER) (* ; "-> Next piece in this textobj.") (PREVPIECE FULLXPOINTER) (* ; "-> Prior piece in this text object.") PLOOKS (* ; "Formatting info and formatting events in this piece") POBJ (* ; "The OBJECT this piece describes") ( PPARALAST FLAG) (* ; "This piece contains a paragraph break") PPARALOOKS (* ; "Paragraph looks for this piece") (PNEW FLAG) (* ; "This text is new here; used by the tentative edit system, and anyone else interested.") (PFATP FLAG) (* ; "T if the characters in this piece are FAT -- i.e., are 16 bits each.") (PTREENODE XPOINTER) (* ; "Points to the PCTB tree-node that contains this piece.")) PSTR _ NIL PFILE _ NIL PFPOS _ 0 PLEN _ 0 PPARALOOKS _ TEDIT.DEFAULT.FMTSPEC PTREENODE _ NIL) (DATATYPE TEXTOBJ ((* ;; "This is where TEdit stores its state information, and internal data about the text being edited.") PCTB (* ; "The piece table") TEXTLEN (* ; "# of chars in the text") \INSERTPC (* ; "Piece to hold type-in") \INSERTPCNO (* ; "Piece # of the input piece") \INSERTNEXTCH (* ; "CH# of next char which is typed into that piece.") \INSERTLEFT (* ; "Space left in the type-in piece" ) \INSERTLEN (* ; "# of characters already in the piece.") \INSERTSTRING (* ; "The string which the piece describes.") \INSERTFIRSTCH (* ; "CH# of first char in the piece.") ( \INSERTPCVALID FLAG) (* ; "T if it's OK to use the cached piece. Set to NIL by people who require that the next insertion/deletion use a different piece." ) \WINDOW (* ; "The window where this textobj is displayed") MOUSEREGION (* ; "Section of the window the mouse is in.") LINES (* ; "-> to top of chain of line descriptors for displayed text") DS (* ; "Display stream where this textobj is displayed") SEL (* ; "The current selection within the text") SCRATCHSEL (* ; "Scratch space for the selection code") MOVESEL (* ; "Source for the next MOVE of text") SHIFTEDSEL (* ; "Source for the next COPY") DELETESEL (* ; "Text to be deleted imminently") WRIGHT (* ; "Right edge of the window (or subregion) where this is displayed") WTOP (* ; "Top of the window/region") WBOTTOM (* ; "Bottom of the window/region") WLEFT (* ; "Left edge of the window/region") TXTFILE (* ; "The original text file we're editing") (\XDIRTY FLAG) (* ; "T => changed since last saved.") (STREAMHINT FULLXPOINTER) (* ; "-> the TEXTOFD stream which gives access to this textobj") EDITFINISHEDFLG (* ; "T => The guy has asked the editor to go way") CARET (* ; "Describes the flashing caret for the editing window") CARETLOOKS (* ; "Font to be used for inserted text.") WINDOWTITLE (* ; "Original title for this window, of there was one.") THISLINE (* ; "Cache of line-related info, to speed up selection &c") (MENUFLG FLAG) (* ; "T if this TEXTOBJ is a tedit-style menu") FMTSPEC (* ; "Default Formatting Spec to be used when formatting paragraphs") (FORMATTEDP FLAG) (* ; "Flag for paragraph formatting. T if this document is to contain paragraph formatting information.") (TXTREADONLY FLAG) (* ; "This is only available for shift selection.") (TXTEDITING FLAG) (* ; "T => This document is in a window and there is an edit process behind it. For example, it only makes sense to have a caret show up if you are editing." ) (TXTNONSCHARS FLAG) (* ; "T => If TEdit rns into a 255, it won't attempt to convert to NS characters. Used for REALLY plain-text manipulation." ) TXTTERMSA (* ; "Special instructions for displaying characters on the screen") EDITOPACTIVE (* ; "T if there is an editing operation in progress. Used to interlock the TEdit menu") DEFAULTCHARLOOKS (* ; "The default character looks -- if any -- to be applied to characters coming into the file from outside." ) TXTRTBL (* ; "The READTABLE to be used by the command loop for command dispatch") TXTWTBL (* ; "The READTABLE to be used to decide on word breaks") EDITPROPS (* ; "The PROPS that were passed into this edit session") (BLUEPENDINGDELETE FLAG) (* ; "T if the next insertion in this document is to be preceded by a deletion of the then-current selection" ) TXTHISTORY (* ; "The history list for this edit session.") (SELWINDOW FULLXPOINTER) (* ; "The window in which the last 'real' selection got made for this edit; used to control caret placement" ) PROMPTWINDOW (* ; "A window to be used for unscheduled interactions; normally a small window above the edit window") DISPLAYCACHE (* ; "The bitmap to be used when building the image of a line for display") DISPLAYCACHEDS (* ; "The DISPLAYSTREAM that is used to build line images") DISPLAYHCPYDS (* ; "The DISPLAYSTREAM used to build line images of lines that are displayed in 'hardcopy' simulation mode" ) TXTPAGEFRAMES (* ; "A tree of page frames, specifying how the document is to be laid out.") TXTCHARLOOKSLIST (* ; "List of all the CHARLOOKSs in the document, so they can be kept unique") TXTPARALOOKSLIST (* ; "List of all the FMTSPECs in the document, so they can be kept unique") ( TXTNEEDSUPDATE FLAG) (* ; "T => Screen invalid, need to run updater") (TXTDON'TUPDATE FLAG) (* ; "T if we're holding off on screen updates until later. Used, e.g., by the menu-SHOW code so that you don't get piecemeal updates, but only one at the end of the SHOW." ) TXTRAWINCLUDESTREAM (* ; "NODIRCORE stream used to cache RAW includes (and maybe later, all includes?)") DOCPROPS (* ; "Document properties that are stored with the document (not used yet)") TXTSTYLESHEET (* ; "Style sheet local to this document. Not currently saved as part of the file.")) (ACCESSFNS TEXTOBJ ( (\DIRTY (ffetch (TEXTOBJ \XDIRTY) of DATUM) (PROGN (IF (NEQ (FETCH (TEXTOBJ \XDIRTY) OF DATUM) NEWVALUE) THEN (* ; "update the title to reflect the change") (\TEDIT.WINDOW.TITLE DATUM ( \TEDIT.ORIGINAL.WINDOW.TITLE (ffetch (TEXTOBJ TXTFILE) of DATUM) NEWVALUE))) (freplace \XDIRTY OF DATUM WITH NEWVALUE))))) SEL _ (create SELECTION) SCRATCHSEL _ (create SELECTION) MOVESEL _ (create SELECTION HOWHEIGHT _ 32767 HASCARET _ NIL) SHIFTEDSEL _ (create SELECTION HASCARET _ NIL) DELETESEL _ (create SELECTION HOWHEIGHT _ 32767 HASCARET _ NIL) \INSERTNEXTCH _ -1 \INSERTPC _ NIL \INSERTLEFT _ 0 \INSERTLEN _ 0 \INSERTSTRING _ NIL \INSERTFIRSTCH _ 1000000 TEXTLEN _ 0 WRIGHT _ 0 WTOP _ 0 WLEFT _ 0 WBOTTOM _ 0 TXTFILE _ NIL \XDIRTY _ NIL MOUSEREGION _ (QUOTE TEXT) THISLINE _ (create THISLINE) MENUFLG _ NIL FMTSPEC _ TEDIT.DEFAULT.FMTSPEC FORMATTEDP _ NIL) (DATATYPE TEXTIMAGEDATA ((* ;; "Fills the IMAGEDATA field of text streams.") TICURPARALOOKS (* ; "The current paragraph looks") TICURIMAGESTREAM (* ; "The image stream for this hardcopy transduction" ) TILOOKSUPDATEFN (* ; "The function to call to update looks for this stream") TIPCOFFSET (* ; "The offset into the current piece, as of the last page cross."))) (ACCESSFNS TEXTSTREAM ((* ;; "Overlay for the STREAM record to allow mnemonic access to stream fields for Text streams.") (REALFILE (fetch F1 of DATUM) (REPLACE F1 OF DATUM WITH NEWVALUE)) (* ; "The real, underlying file behind the current piece") (CHARSLEFT (fetch F2 of DATUM) (REPLACE F2 OF DATUM WITH NEWVALUE)) (* ;; "The # of characters that will be left in the current piece the next time its file crosses a page boundary" ) (TEXTOBJ (fetch F3 of DATUM) (REPLACE F3 OF DATUM WITH NEWVALUE)) (* ; "The TEXTOBJ that is editing this text") (PIECE (fetch F5 of DATUM) (REPLACE F5 OF DATUM WITH NEWVALUE )) (* ; "The PIECE we're currently fetching chars from/putting chars into") (PCNO (fetch FW8 of DATUM) (REPLACE FW8 OF DATUM WITH NEWVALUE)) (* ; "The position of that piece in the piece table") ( PCSTARTPG (fetch FW6 of DATUM) (REPLACE FW6 OF DATUM WITH NEWVALUE)) (* ; "The underlying file page# that this piece starts on") (PCSTARTCH (fetch FW7 of DATUM) (REPLACE FW7 OF DATUM WITH NEWVALUE)) (* ; "The char within page of the underlying file that this piece starts on -- for backbin & co") (PCOFFSET (fetch TIPCOFFSET of (fetch IMAGEDATA of DATUM)) (REPLACE TIPCOFFSET OF (fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "The offset into the current piece, as of the last page cross.") (CURRENTLOOKS ( fetch F10 of DATUM) (replace F10 of DATUM with NEWVALUE)) (* ; "The CHARLOOKS that are currently applicable to characters being taken from the stream.") ( CURRENTPARALOOKS (fetch TICURPARALOOKS of (fetch IMAGEDATA of DATUM)) (REPLACE TICURPARALOOKS OF ( fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "The FMTSPEC that is currently applicable to characters being taken from the stream.") ( CURRENTIMAGESTREAM (fetch TICURIMAGESTREAM of (fetch IMAGEDATA of DATUM)) (REPLACE TICURIMAGESTREAM OF (fetch IMAGEDATA of DATUM) with NEWVALUE) (* ; "The image stream that this text is being put onto; used for scaling decisions")) (LOOKSUPDATEFN ( fetch TILOOKSUPDATEFN of (fetch IMAGEDATA of DATUM)) (REPLACE TILOOKSUPDATEFN OF (fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "Function to be called each time character looks change.") (FATSTREAMP ( fetch F4 of DATUM) (REPLACE F4 OF DATUM WITH NEWVALUE)) (* ; "T if the current piece is 16 bit characters.")) (CREATE (create STREAM using \TEXTOFD IMAGEDATA _ ( create TEXTIMAGEDATA)))) (/DECLAREDATATYPE (QUOTE PIECE) (QUOTE (POINTER POINTER FIXP FIXP FULLXPOINTER FULLXPOINTER POINTER POINTER FLAG POINTER FLAG FLAG XPOINTER)) (QUOTE ((PIECE 0 POINTER) (PIECE 2 POINTER) (PIECE 4 FIXP) ( PIECE 6 FIXP) (PIECE 8 FULLXPOINTER) (PIECE 10 FULLXPOINTER) (PIECE 12 POINTER) (PIECE 14 POINTER) ( PIECE 14 (FLAGBITS . 0)) (PIECE 16 POINTER) (PIECE 16 (FLAGBITS . 0)) (PIECE 16 (FLAGBITS . 16)) ( PIECE 18 XPOINTER))) (QUOTE 20)) (/DECLAREDATATYPE (QUOTE TEXTOBJ) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER POINTER POINTER)) (QUOTE ((TEXTOBJ 0 POINTER) (TEXTOBJ 2 POINTER) (TEXTOBJ 4 POINTER) (TEXTOBJ 6 POINTER) (TEXTOBJ 8 POINTER) (TEXTOBJ 10 POINTER) (TEXTOBJ 12 POINTER) (TEXTOBJ 14 POINTER) (TEXTOBJ 16 POINTER) (TEXTOBJ 16 (FLAGBITS . 0)) ( TEXTOBJ 18 POINTER) (TEXTOBJ 20 POINTER) (TEXTOBJ 22 POINTER) (TEXTOBJ 24 POINTER) (TEXTOBJ 26 POINTER ) (TEXTOBJ 28 POINTER) (TEXTOBJ 30 POINTER) (TEXTOBJ 32 POINTER) (TEXTOBJ 34 POINTER) (TEXTOBJ 36 POINTER) (TEXTOBJ 38 POINTER) (TEXTOBJ 40 POINTER) (TEXTOBJ 42 POINTER) (TEXTOBJ 44 POINTER) (TEXTOBJ 44 (FLAGBITS . 0)) (TEXTOBJ 46 FULLXPOINTER) (TEXTOBJ 48 POINTER) (TEXTOBJ 50 POINTER) (TEXTOBJ 52 POINTER) (TEXTOBJ 54 POINTER) (TEXTOBJ 56 POINTER) (TEXTOBJ 56 (FLAGBITS . 0)) (TEXTOBJ 58 POINTER) ( TEXTOBJ 58 (FLAGBITS . 0)) (TEXTOBJ 58 (FLAGBITS . 16)) (TEXTOBJ 58 (FLAGBITS . 32)) (TEXTOBJ 58 ( FLAGBITS . 48)) (TEXTOBJ 60 POINTER) (TEXTOBJ 62 POINTER) (TEXTOBJ 64 POINTER) (TEXTOBJ 66 POINTER) ( TEXTOBJ 68 POINTER) (TEXTOBJ 70 POINTER) (TEXTOBJ 70 (FLAGBITS . 0)) (TEXTOBJ 72 POINTER) (TEXTOBJ 74 FULLXPOINTER) (TEXTOBJ 76 POINTER) (TEXTOBJ 78 POINTER) (TEXTOBJ 80 POINTER) (TEXTOBJ 82 POINTER) ( TEXTOBJ 84 POINTER) (TEXTOBJ 86 POINTER) (TEXTOBJ 88 POINTER) (TEXTOBJ 88 (FLAGBITS . 0)) (TEXTOBJ 88 (FLAGBITS . 16)) (TEXTOBJ 90 POINTER) (TEXTOBJ 92 POINTER) (TEXTOBJ 94 POINTER))) (QUOTE 96)) (/DECLAREDATATYPE (QUOTE TEXTIMAGEDATA) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE (( TEXTIMAGEDATA 0 POINTER) (TEXTIMAGEDATA 2 POINTER) (TEXTIMAGEDATA 4 POINTER) (TEXTIMAGEDATA 6 POINTER) )) (QUOTE 8)) (DEFOPTIMIZER TEXTPROP (TEXTOBJ PROP &OPTIONAL (VAL NIL WRITING)) (* ;; "compiles calls to TEXTPROP") (COND ((NOT (LISTP PROP)) (* ; "property is not quoted.") (QUOTE IGNOREMACRO)) ((NOT (EQ (CAR PROP) ( QUOTE QUOTE))) (* ; "property is not quoted.") (QUOTE IGNOREMACRO)) ((NOT WRITING) (* ; "fetching a TEXTPROP property.") (SELECTQ (CADR PROP) ((READONLY READ-ONLY) (BQUOTE (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ (\, TEXTOBJ))))) ((BEING-EDITED ACTIVE) (BQUOTE (fetch (TEXTOBJ TXTEDITING) of (TEXTOBJ (\, TEXTOBJ))))) ((NO-NS-CHARS NONSCHARS NO-NSCHARS) (BQUOTE (fetch (TEXTOBJ TXTNONSCHARS) of (TEXTOBJ (\, TEXTOBJ))))) (BQUOTE (LISTGET (fetch (TEXTOBJ EDITPROPS) of (TEXTOBJ (\, TEXTOBJ))) ( \, PROP))))) (T (* ; "storing a window property") (SELECTQ (CADR PROP) ((READONLY READ-ONLY) (BQUOTE ( REPLACE (TEXTOBJ TXTREADONLY) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) ((BEING-EDITED ACTIVE) ( BQUOTE (REPLACE (TEXTOBJ TXTEDITING) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) ((NO-NS-CHARS NONSCHARS NO-NSCHARS) (BQUOTE (REPLACE (TEXTOBJ TXTNONSCHARS) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)) )) (BQUOTE (LET* (($$TEXTOBJ$$ (TEXTOBJ (\, TEXTOBJ))) ($$PROPLST$$ (FETCH EDITPROPS OF $$TEXTOBJ$$))) (COND ($$PROPLST$$ (LISTPUT $$PROPLST$$ (\, PROP) (\, VAL))) (T (REPLACE EDITPROPS OF $$TEXTOBJ$$ WITH (LIST (\, PROP) (\, VAL))))))))))) (RECORD PAGEFORMATTINGSTATE ((* ;; "Contains the state for a TEdit page-formatting job.") PAGE# (* ; "The current page number. Counted from 1") FIRSTPAGE (* ;; "T if the current page is the 'first page' . Is set initially, and can be set again by the user at will. Gets reset after each page image is printed." ) MINPAGE# (* ; "The page # of the first page to be printed, or NIL") MAXPAGE# (* ; "The page # of the last page to be printed, or NIL") STATE (* ; "One of FORMATTING or SEARCHING.") REQUIREDREGIONTYPE (* ; "If STATE is SEARCHING, the kind of box we're looking for. If STATE is :SEARCHING-FOR-EQUIVALENT-PAGE, this is the page count for the matching page." ) MAINSTREAM (* ; "The principal textobj/stream source") CHNO (* ; "Our position in that stream") PRESSREGION (* ; "The press code's REGION info.") PAGEHEADINGS (* ; "The list of current values to be printed, indexed by heading type") PAGE#GENERATOR (* ; "List of page numbers; later, maybe, a function to generate page numbers. Used to fill in PAGE#TEXT, below" ) PAGE#TEXT (* ; "If special page numbers are in use, this is the place to take them from. PAGE# is still used for recto/verso decisions &c" ) PAGEISRECTO (* ; "T if this is a recto page, NIL if it's a VERSO page.") PAGEFOOTNOTELINES (* ; "A list of extant footnote lines that should appear at the next opportunity") PAGEFLOATINGTOPLINES (* ; "A list of lines that should float to the top of the next available place") PAGECOUNT (* ; "The number of pages we've formatted so far.") PAGELINECACHE (* ; "A cache for pre-created LINEDESCRIPTOR/THISLINE sets, to avoid the overhead of re-allocating them all the time" ) NEWPAGELAYOUT (* ; "If we switch page layouts in mid-document, this is where the new layout gets cached until we get started again." )) PAGECOUNT _ 0) (DATATYPE PAGEREGION ((* ;; "Describe a part of a page for page formatting. Can be made into compound descriptions.") REGIONFILLMETHOD (* ; "What kind of a region this is -- TEXT, FOLIO, PAGEHEADING, etc.") REGIONSPEC (* ; "The page-relative region this occupies") REGIONLOCALINFO (* ; "A PLIST for local information") ( REGIONPARENT FULLXPOINTER) (* ; "The parent node for this box, for sub-boxes") REGIONSUBBOXES (* ; "The sub-regions of this region") REGIONTYPE (* ; "A user-settable region type"))) (/DECLAREDATATYPE (QUOTE PAGEREGION) (QUOTE (POINTER POINTER POINTER FULLXPOINTER POINTER POINTER)) ( QUOTE ((PAGEREGION 0 POINTER) (PAGEREGION 2 POINTER) (PAGEREGION 4 POINTER) (PAGEREGION 6 FULLXPOINTER ) (PAGEREGION 8 POINTER) (PAGEREGION 10 POINTER))) (QUOTE 12)) (DATATYPE CHARLOOKS ((* ;; "Describes the appearance (%"Looks%") of characters in a TEdit document.") CLFONT (* ; "The font descriptor for these characters") CLNAME (* ;; "Name of the font (e.g., HELVETICA) THIS FIELD IS A HINT, OR FOR USE IN CHARLOOKS-BUILDING CODE. USE FONTPROP TO GET THE RIGHT VALUE FROM CLFONT." ) CLSIZE (* ; "Font size, in points") (CLITAL FLAG) (* ; "T if the characters are italic, else NIL") ( CLBOLD FLAG) (* ; "T if the characters are bold, else NIL") (CLULINE FLAG) (* ; "T if the characters are to be underscored, else NIL") (CLOLINE FLAG) (* ; "T if the characters are to be overscored, else NIL") (CLSTRIKE FLAG) (* ; "T if the characters are to be struck thru, else nil.") CLOFFSET (* ; "A superscripting offset in points (?) else NIL (SUBSCRIPTING IF NEGATIVE.)") (CLSMALLCAP FLAG) (* ; "T if small caps, else NIL") (CLINVERTED FLAG) (* ; "T if the characters are to be shown white-on-black") (CLPROTECTED FLAG) (* ; "T if chars can't be selected, else NIL") (CLINVISIBLE FLAG) (* ; "T if TEDIT is to ignore these chars; else NIL") (CLSELHERE FLAG) (* ;; "T if TEDIT can put selection after this char (for menu blanks) else NIL; anything typed after this char will NOT BE PROTECTED." ) (CLCANCOPY FLAG) (* ;; "T if this text can be selected for copying, even tho protected (it will become unprotected after the copy; for Dribble/TTY interface)" ) CLSTYLE (* ; "The style to be used in marking these characters; overridden by the other fields") CLUSERINFO (* ; "Any information that an outsider wants to include") CLLEADER (* ; "For creating dotted and other kinds of leader") CLRULES (* ;; "For arbitrarily-places horizontal rules. List of pairs, of (widthinpts . offsetfrombaselineinpts). Should be taken account of in ascent/descent calcs." ) (CLMARK FLAG) (* ;; "Used for a mark-&-sweep of looks at PUT time -- T means this set of looks really IS in use in the document" )) CLOFFSET _ 0) (DATATYPE FMTSPEC ((* ;; "Describe the paragraph formatting for a paragraph in a TEdit document.") 1STLEFTMAR (* ; "Left margin of the first line of the paragraph") LEFTMAR (* ; "Left margin of the rest of the lines in the paragraph") RIGHTMAR (* ; "Right margin for the paragraph") LEADBEFORE (* ; "Leading above the paragraph's first line, in points") LEADAFTER (* ; "Leading below the paragraph's bottom line, in points. NOT IMPLEMENTED.") LINELEAD (* ; "Leading between lines, in points. Actually, this space is added BELOW each line in the para.") FMTBASETOBASE (* ; "The baseline-to-baseline spacing between lines in this paragraph. THIS OVERRIDES THE LINE LEADING") TABSPEC (* ; "The list of tabs for this paragraph, including CAR for a default tab width") QUAD (* ; "How the para is formatted: one of LEFT, RIGHT, CENTERED, JUSTIFIED") FMTSTYLE (* ; "The STYLE that controls this paragraph's appearance") FMTCHARSTYLES (* ; "The characterstyles that control the appearance of characters in this para (maybe? may be part of the fmtstyle.)" ) FMTUSERINFO (* ; "Space for a PLIST of user info") FMTSPECIALX (* ; "A special horizontal location on the printed page for this para.") FMTSPECIALY (* ; "A special vertical location on the page for this para") (FMTHEADINGKEEP FLAG) (* ; "This para should be kept with the top line or so of the next para..") FMTPARATYPE (* ; "What kind of para this is: TEXT, PAGEHEADING, whatever") FMTPARASUBTYPE (* ; "Sub type of the type, e.g., what KIND of page heading this is.") FMTNEWPAGEBEFORE (* ; "Start a new box (if T) or back up the page formatting tree to make a new box of the type named in the value -- by going the least distance back up the tree, then back down until you find that kind of box." ) FMTNEWPAGEAFTER (* ; "Similarly") FMTKEEP (* ; "For information about how this paragraph is to be kept with other paragraphs.") FMTCOLUMN (* ; "For setting up side-by-side paragraphs easily ala BravoX") FMTVERTRULES (* ; "For Keeping track of vertical rules in force") (FMTMARK FLAG) (* ; "Used to keep track of which PARALOOKSs are really being used -- a mark & collect is done just before a PUT, so that only 'real' PARALOOKSs make it into the file" ) (* ; "Used for a mark&sweep of para looks at PUT time -- T means this looks really IS in use in the document, so it makes sense to save it on the file." ) (FMTHARDCOPY FLAG) (* ; "T if this paragraph is to be displayed in hardcopy-format.") FMTREVISED (* ; "T (or perhaps a revision level or revision-mark spec??) if this paragraph is to be marked as changed on output." )) TABSPEC _ (CONS NIL NIL)) (DATATYPE PENDINGTAB ((* ;; "The data structure for a tab, within the line formatter, that we haven't finished dealing with yet, e.g. a centered tab where you need to wait for AFTER the centered text to do the formatting." ) PTNEWTX (* ;; "An updated TX, being passed back to the line formatter. This results from the resolution of an old RIGHT, CENTERED, or DECIMAL tab, which changed the width of a prior tab." ) PTOLDTAB (* ; "The pending tab") PTTYPE (* ; "Its tab type") PTTABX (* ; "Its nominal X position") ( PTWBASE FULLXPOINTER) (* ; "The WBASE for its width, for updating when we've figured out how wide the tab really is") PTOLDTX (* ; "The TX as of when the tab was encountered."))) (/DECLAREDATATYPE (QUOTE CHARLOOKS) (QUOTE (POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER FLAG)) (QUOTE ((CHARLOOKS 0 POINTER) ( CHARLOOKS 2 POINTER) (CHARLOOKS 4 POINTER) (CHARLOOKS 4 (FLAGBITS . 0)) (CHARLOOKS 4 (FLAGBITS . 16)) (CHARLOOKS 4 (FLAGBITS . 32)) (CHARLOOKS 4 (FLAGBITS . 48)) (CHARLOOKS 2 (FLAGBITS . 0)) (CHARLOOKS 6 POINTER) (CHARLOOKS 6 (FLAGBITS . 0)) (CHARLOOKS 6 (FLAGBITS . 16)) (CHARLOOKS 6 (FLAGBITS . 32)) ( CHARLOOKS 6 (FLAGBITS . 48)) (CHARLOOKS 2 (FLAGBITS . 16)) (CHARLOOKS 2 (FLAGBITS . 32)) (CHARLOOKS 8 POINTER) (CHARLOOKS 10 POINTER) (CHARLOOKS 12 POINTER) (CHARLOOKS 14 POINTER) (CHARLOOKS 14 (FLAGBITS . 0)))) (QUOTE 16)) (/DECLAREDATATYPE (QUOTE FMTSPEC) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER)) (QUOTE ((FMTSPEC 0 POINTER) (FMTSPEC 2 POINTER) (FMTSPEC 4 POINTER ) (FMTSPEC 6 POINTER) (FMTSPEC 8 POINTER) (FMTSPEC 10 POINTER) (FMTSPEC 12 POINTER) (FMTSPEC 14 POINTER) (FMTSPEC 16 POINTER) (FMTSPEC 18 POINTER) (FMTSPEC 20 POINTER) (FMTSPEC 22 POINTER) (FMTSPEC 24 POINTER) (FMTSPEC 26 POINTER) (FMTSPEC 26 (FLAGBITS . 0)) (FMTSPEC 28 POINTER) (FMTSPEC 30 POINTER) (FMTSPEC 32 POINTER) (FMTSPEC 34 POINTER) (FMTSPEC 36 POINTER) (FMTSPEC 38 POINTER) (FMTSPEC 40 POINTER) (FMTSPEC 40 (FLAGBITS . 0)) (FMTSPEC 40 (FLAGBITS . 16)) (FMTSPEC 42 POINTER))) (QUOTE 44)) (/DECLAREDATATYPE (QUOTE PENDINGTAB) (QUOTE (POINTER POINTER POINTER POINTER FULLXPOINTER POINTER)) ( QUOTE ((PENDINGTAB 0 POINTER) (PENDINGTAB 2 POINTER) (PENDINGTAB 4 POINTER) (PENDINGTAB 6 POINTER) ( PENDINGTAB 8 FULLXPOINTER) (PENDINGTAB 10 POINTER))) (QUOTE 12)) (TYPERECORD MB.3STATE ((* ;; "Describes a 3-state menu button.") MBLABEL (* ; "Label for the button on the screen") MBFONT (* ; "Font the label text should appear in") MBCHANGESTATEFN (* ; "Function to call when the button's state changes") MBINITSTATE (* ; "Button's initial state.")) MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))) (TYPERECORD MB.BUTTON (MBLABEL MBBUTTONEVENTFN MBFONT) MBBUTTONEVENTFN _ (QUOTE MB.DEFAULTBUTTON.FN) MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))) (TYPERECORD MB.INSERT (MBINITENTRY)) (TYPERECORD MB.MARGINBAR (ignoredfield)) (TYPERECORD MB.NWAY (MBBUTTONS MBFONT MBCHANGESTATEFN MBINITSTATE MBMAXITEMSPERLINE) MBFONT _ ( FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))) (TYPERECORD MB.TEXT (MBSTRING MBFONT)) (TYPERECORD MB.TOGGLE (MBTEXT MBFONT MBCHANGESTATEFN MBINITSTATE) MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))) (DEFMACRO WITHOUT-UPDATES (TEXTOBJ SCRATCHSEL &BODY BODY) (* ;; "For TEdit windows, run BODY without updating the edit window for TEXTOBJ. This is useful if you're making a log of changes to a document at one time, where the changes are in essence atomic, and you don't need to see intermediate results. It's also a good bit faster than constant updating." ) (* ;; "TEXTOBJ is the TEXTOBJ for the document you'll be modifying.") (* ;; "SCRATCHSEL should be the scratch selection (often used in this work)") (BQUOTE (LET ((OLD-UNWIND-FLAG (FETCH (TEXTOBJ TXTDON'TUPDATE) OF (\, TEXTOBJ)))) (CL:UNWIND-PROTECT (PROGN (replace (TEXTOBJ TXTDON'TUPDATE) of (\, TEXTOBJ) with T) (\,@ BODY)) (\SHOWSEL (\, SCRATCHSEL) NIL NIL) (replace SET of (\, SCRATCHSEL) with NIL) (\TEDIT.MARK.LINES.DIRTY (\, TEXTOBJ) 1 (fetch (TEXTOBJ TEXTLEN) of (\, TEXTOBJ))) (replace (TEXTOBJ TXTDON'TUPDATE) of (\, TEXTOBJ) with OLD-UNWIND-FLAG) ( TEDIT.UPDATE.SCREEN (\, TEXTOBJ)))))) (RECORD TEDITHISTORYEVENT ((* ;; "Describes one event on the TEdit edit history list.") THACTION (* ; "A LITATOM, specifying what the event was") THPOINT (* ; "Was the selection to the left or right?") THLEN (* ; "The # of chars involved") THCH# (* ; "The starting ch#") THFIRSTPIECE (* ; "First piece involved") THOLDINFO (* ; "Old info, for undo") THAUXINFO (* ; "Auxiliary info about the event, primarily for redo") THTEXTOBJ (* ;; "Place to remember a second textobj, for those like MOVE who need to remember both a source and a destination." )) THPOINT _ (QUOTE LEFT)) (/DECLAREDATATYPE (QUOTE TEDITCARET) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TEDITCARET 0 POINTER) (TEDITCARET 2 POINTER) (TEDITCARET 4 POINTER) (TEDITCARET 6 POINTER) (TEDITCARET 8 POINTER) (TEDITCARET 10 POINTER) (TEDITCARET 12 POINTER) (TEDITCARET 14 POINTER) (TEDITCARET 16 POINTER) (TEDITCARET 18 POINTER) (TEDITCARET 20 POINTER))) ( QUOTE 22)) (DATATYPE PCTNODE (CHNUM (* ; "Character #of piece in this node.") PCE (* ; "PIECE ") LO (* ; "Subtree these nodes' ch#are less than this node.") HI (* ; " Subtree these nodes' ch#are more than this node.") BF (* ; "Balance factor.") (* ; "1: Right(HI) Subtree is higher than left(lo) subtree.") (* ; "0: Right subtree and left subtree are same height") (* ; "-1: Right(HI) Subtree is shorter than left(lo) subtree.") RANK (* ; "(# of nodes in left subtree) +1" )) CHNUM _ 0 BF _ 0 RANK _ 1) (/DECLAREDATATYPE (QUOTE PCTNODE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE (( PCTNODE 0 POINTER) (PCTNODE 2 POINTER) (PCTNODE 4 POINTER) (PCTNODE 6 POINTER) (PCTNODE 8 POINTER) ( PCTNODE 10 POINTER))) (QUOTE 12)) (PUTPROPS TEDITDCL COPYRIGHT ("Venue" 1986 1987 1988 1989 1990 1991 1993 1994 1995)) NIL \ No newline at end of file diff --git a/obsolete/library/new/TEDITFILE b/obsolete/library/new/TEDITFILE deleted file mode 100644 index bc49b39a..00000000 --- a/obsolete/library/new/TEDITFILE +++ /dev/null @@ -1,3620 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 4-May-95 10:30:33" {DSK}library>new>TEDITFILE.;2 244496 - - changes to%: (FNS TEDIT.INCLUDE TEDIT.BUILD.PCTB0) - - previous date%: "25-Aug-94 10:53:27" {DSK}export>lispcore>library>TEDITFILE.;3) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995 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 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)) - (* ; "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 copybytes if need by.") - (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)) - (* ; "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 TEXTOBJ)) - (* ; - "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 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] (* ; "And 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 4-May-95 10:29 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)) - (* ; "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] (* ; - "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 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 (- (fetch (TEXTOBJ TEXTLEN) of STREAM) - (+ TEXTLEN LEN))) - STREAM) (* ; "Set the fileptr to the end of the insertion; the (- fetch ...) form accounts for any change due to NSCHAR translation that may occur duing the screen update.") - T) - (T (TEDIT.PROMPTPRINT STREAM "Please choose the place for the INCLUDE first." T]) - -(TEDIT.RAW.INCLUDE - [LAMBDA (STREAM INFILE START END) (* ; - "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] - 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.") - ) - (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] - (* ; - "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) - (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 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 NIL - (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] - [(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.") - '((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") - (SETQ OFILE (OPENSTREAM (fetch (STREAM FULLFILENAME) of OFILE) - 'INPUT] (* ; - "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.") - (replace (TEXTOBJ \DIRTY) of TEXTOBJ with NIL) - (* ; - "We can safely QUIT now without losing anything.") - ) - (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 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)) - (* ; - "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.") - (AND (NOT UNFORMATTED?) - (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") - ] - ((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 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))(* ; - "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)) - (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] - (* ; - "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] - (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] - (* ; - "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] - (* ; - "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] - (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] - (* ; "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 2-May-95 14:11 by sybalsky:mv:envos") - -(* ;;; "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)) - (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) 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) - (\INSERTPIECE PC 'LASTPIECE TEXTOBJ) - (* INSERT-BRT (CREATEPCNODE CURCH# - PC) PCTB) - (add CURCH# (fetch (PIECE PLEN) of PC)) - finally (* INSERT-BRT (CREATEPCNODE CURCH# - (QUOTE 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 1995)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3089 57219 (TEDIT.BUILD.PCTB 3099 . 37241) (\TEDIT.CONVERT.FOREIGN.FORMAT 37243 . 38684 -) (TEDIT.FORMATTEDFILEP 38686 . 42550) (TEDIT.GET 42552 . 50903) (TEDIT.PARSE.PAGEFRAMES1 50905 . -52611) (\ARBIN 52613 . 53234) (\ATMIN 53236 . 53565) (\DWIN 53567 . 53845) (\STRINGIN 53847 . 54444) ( -\TEDIT.FORMATTEDP1 54446 . 56710) (\TEDIT.SET.WINDOW 56712 . 57217)) (57255 77016 (TEDIT.INCLUDE 57265 - . 68392) (TEDIT.RAW.INCLUDE 68394 . 77014)) (77050 121476 (TEDIT.PUT 77060 . 86750) (TEDIT.PUT.PCTB -86752 . 115212) (\TEDIT.PUTRESET 115214 . 115460) (TEDIT.PUT.PIECE.DESCRIPTOR 115462 . 117925) ( -\ARBOUT 117927 . 119127) (\ATMOUT 119129 . 119644) (\DWOUT 119646 . 119929) (\STRINGOUT 119931 . -120383) (\TEDIT-OPEN-FONT-FILE 120385 . 121474)) (121477 131989 (\TEDIT.GET.CHARLOOKS.LIST 121487 . -121892) (\TEDIT.GET.SINGLE.CHARLOOKS 121894 . 124939) (\TEDIT.PUT.CHARLOOKS.LIST 124941 . 126736) ( -\TEDIT.PUT.SINGLE.CHARLOOKS 126738 . 131987)) (131990 146269 (\TEDIT.GET.PARALOOKS.LIST 132000 . -132413) (\TEDIT.GET.SINGLE.PARALOOKS 132415 . 138809) (\TEDIT.PUT.PARALOOKS.LIST 138811 . 139805) ( -\TEDIT.PUT.SINGLE.PARALOOKS 139807 . 146267)) (146577 207053 (TEDIT.BUILD.PCTB2 146587 . 159943) ( -\TEDIT.GET.CHARLOOKS.LIST2 159945 . 160352) (\TEDIT.GET.SINGLE.CHARLOOKS2 160354 . 163266) ( -\TEDIT.PUT.SINGLE.PARALOOKS2 163268 . 167982) (\TEDIT.PUT.SINGLE.CHARLOOKS2 167984 . 172480) ( -\TEDIT.GET.PARALOOKS.LIST2 172482 . 172889) (\TEDIT.GET.SINGLE.PARALOOKS2 172891 . 177479) ( -TEDIT.PUT.PCTB2 177481 . 204357) (\TEDIT.PUT.CHARLOOKS.LIST2 204359 . 206156) ( -\TEDIT.PUT.PARALOOKS.LIST2 206158 . 207051)) (207130 228254 (TEDIT.BUILD.PCTB1 207140 . 217330) ( -TEDIT.GET.PAGEFRAMES1 217332 . 217587) (\TEDIT.GET.CHARLOOKS1 217589 . 221139) (\TEDIT.GET.PARALOOKS1 -221141 . 225722) (TEDIT.GET.OBJECT1 225724 . 228252)) (228314 244346 (TEDIT.BUILD.PCTB0 228324 . -234357) (TEDIT.GET.CHARLOOKS0 234359 . 238378) (TEDIT.GET.OBJECT0 238380 . 240908) ( -TEDIT.GET.PARALOOKS0 240910 . 244344))))) -STOP diff --git a/obsolete/library/new/TEDITFILE.LCOM b/obsolete/library/new/TEDITFILE.LCOM deleted file mode 100644 index 9b95e8e8..00000000 Binary files a/obsolete/library/new/TEDITFILE.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITFIND.LCOM b/obsolete/library/new/TEDITFIND.LCOM deleted file mode 100644 index eef44183..00000000 Binary files a/obsolete/library/new/TEDITFIND.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITFNKEYS.LCOM b/obsolete/library/new/TEDITFNKEYS.LCOM deleted file mode 100644 index 08227e05..00000000 Binary files a/obsolete/library/new/TEDITFNKEYS.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITHCPY.LCOM b/obsolete/library/new/TEDITHCPY.LCOM deleted file mode 100644 index dd0b09f3..00000000 Binary files a/obsolete/library/new/TEDITHCPY.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITHISTORY b/obsolete/library/new/TEDITHISTORY deleted file mode 100644 index 03775d97..00000000 --- a/obsolete/library/new/TEDITHISTORY +++ /dev/null @@ -1,622 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 4-May-95 10:38:22" {DSK}library>new>TEDITHISTORY.;3 38709 - - changes to%: (FNS TEDIT.REDO.INSERTION \TEDIT.CUMULATE.EVENTS TEDIT.UNDO TEDIT.UNDO.REPLACE) - - previous date%: "22-Mar-95 18:20:17" {DSK}library>new>TEDITHISTORY.;1) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1990, 1991, 1993, 1995 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TEDITHISTORYCOMS) - -(RPAQQ TEDITHISTORYCOMS - ((FILES TEDITDECLS) - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) - (FILES (LOADCOMP) - TEDITDECLS)) - (GLOBALVARS TEDIT.HISTORY.TYPELST TEDIT.HISTORYLST) - (INITVARS (TEDIT.HISTORY.TYPELST NIL) - (TEDIT.HISTORYLST NIL)) - (COMS - (* ;; "History-list maintenance functions") - - (FNS \TEDIT.HISTORYADD \TEDIT.CUMULATE.EVENTS)) - (COMS - (* ;; "Specialized UNDO & REDO functions.") - - (FNS TEDIT.UNDO TEDIT.UNDO.INSERTION TEDIT.UNDO.DELETION TEDIT.REDO - TEDIT.REDO.INSERTION TEDIT.UNDO.MOVE TEDIT.UNDO.REPLACE TEDIT.REDO.REPLACE - TEDIT.REDO.MOVE)))) - -(FILESLOAD TEDITDECLS) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \SCRATCHLEN 64) - - -(CONSTANTS (\SCRATCHLEN 64)) -) - - -(FILESLOAD (LOADCOMP) - TEDITDECLS) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS TEDIT.HISTORY.TYPELST TEDIT.HISTORYLST) -) - -(RPAQ? TEDIT.HISTORY.TYPELST NIL) - -(RPAQ? TEDIT.HISTORYLST NIL) - - - -(* ;; "History-list maintenance functions") - -(DEFINEQ - -(\TEDIT.HISTORYADD - [LAMBDA (TEXTOBJ EVENT) (* ; "Edited 3-Sep-87 10:36 by jds") - - (* ;; "Add a new event to the history list. For now, this just re-sets the whole list to be the one event...") - - (* ;; - "This function also takes care of cumulating cumulative events, like successive deletions.") - - (LET* ((OLDEVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) - (ETYPE (fetch (TEDITHISTORYEVENT THACTION) of EVENT)) - (OETYPE (fetch (TEDITHISTORYEVENT THACTION) of OLDEVENT)) - (REALEVENT EVENT)) - [COND - ((AND OLDEVENT (EQ OETYPE ETYPE) - (EQ ETYPE 'Delete)) (* ; - "Repeated successive deletions. See if we can combine them.") - - (LET* [(OSTART (fetch (TEDITHISTORYEVENT THCH#) of OLDEVENT)) - (NSTART (fetch (TEDITHISTORYEVENT THCH#) of EVENT)) - (OLDEND (+ OSTART (fetch (TEDITHISTORYEVENT THLEN) of OLDEVENT))) - (NEWEND (+ NSTART (fetch (TEDITHISTORYEVENT THLEN) of EVENT] - (COND - ((IEQP OLDEND NSTART) (* ; - "The old deletion was just in front of the current one; cumulate them.") - - (SETQ REALEVENT (\TEDIT.CUMULATE.EVENTS OLDEVENT EVENT T))) - ((IEQP NEWEND OSTART) (* ; - "The new deletion was just in front of the old one; cumulate them.") - - (SETQ REALEVENT (\TEDIT.CUMULATE.EVENTS EVENT OLDEVENT T] - (replace (TEXTOBJ TXTHISTORY) of TEXTOBJ with REALEVENT]) - -(\TEDIT.CUMULATE.EVENTS - [LAMBDA (EVENT1 EVENT2 PIECES-TO-SAVE?) (* ; - "Edited 3-Apr-95 12:23 by sybalsky:mv:envos") - - (* ;; "Accumulate history events that should really be combined into a single event.") - - (* ;; "For now, this assumes they're events of the same type. Actually, this should be able to cumulate a delete/insert pair into a replacement, etc.") - - (LET* [(OLDLEN (fetch (TEDITHISTORYEVENT THLEN) of EVENT1)) - (NEWPC1 (CAR (fetch (TEDITHISTORYEVENT THFIRSTPIECE) of EVENT2))) - (REALEVENT (create TEDITHISTORYEVENT using EVENT1 THLEN _ - (+ OLDLEN (fetch (TEDITHISTORYEVENT - THLEN) of EVENT2] - (bind (PC _ (CAR (fetch (TEDITHISTORYEVENT THFIRSTPIECE) of EVENT1))) - (CHCOUNT _ 0) while (< (SETQ CHCOUNT (+ CHCOUNT (fetch (PIECE PLEN) - of PC))) - OLDLEN) do (SETQ PC (fetch (PIECE NEXTPIECE) - of PC)) - finally (replace (PIECE NEXTPIECE) of PC with NEWPC1) - (replace (PIECE PREVPIECE) of NEWPC1 with PC) - (RETURN)) - REALEVENT]) -) - - - -(* ;; "Specialized UNDO & REDO functions.") - -(DEFINEQ - -(TEDIT.UNDO - [LAMBDA (TEXTOBJ) (* ; - "Edited 22-Mar-95 16:48 by sybalsky:mv:envos") - - (* ;; "Undo the last thing this guy did.") - - (COND - ((NOT (fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ)) - - (* ;; "Only undo things if the document is allowed to change.") - - (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - EVENT CH# LEN FIRSTPIECE) - (COND - ((SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) - (* ; - "There really is something to UNDO. Decide what, & fix it.") - (SETQ LEN (fetch THLEN of EVENT)) (* ; - "Length of the text that was inserted/deleted/changed") - (SETQ CH# (fetch THCH# of EVENT)) (* ; "Starting CH# of the change") - (SETQ FIRSTPIECE (CAR (fetch THFIRSTPIECE of EVENT))) - (* ; - "First piece affected by the change") - (RESETLST - (RESETSAVE (CURSOR WAITINGCURSOR)) - (\SHOWSEL SEL NIL NIL) - [SELECTQ (fetch THACTION of EVENT) - ((Insert Copy Include) (* ; "It was an insertion") - (TEDIT.UNDO.INSERTION TEXTOBJ EVENT LEN CH# FIRSTPIECE)) - (Delete (* ; "It was a deletion") - (TEDIT.UNDO.DELETION TEXTOBJ EVENT LEN CH# FIRSTPIECE)) - (Looks (* ; "It was a character-looks change") - (TEDIT.UNDO.LOOKS TEXTOBJ EVENT LEN CH# FIRSTPIECE)) - (ParaLooks (* ; "It was a PARA looks change") - (TEDIT.UNDO.PARALOOKS TEXTOBJ EVENT LEN CH# FIRSTPIECE)) - (Move (TEDIT.UNDO.MOVE TEXTOBJ EVENT LEN CH# FIRSTPIECE) - (* ; "He moved some text") - ) - ((Replace LowerCase UpperCase) - - (* ;; "He replaced one piece of text with another ; Lower-casing and upper-casing have the same undo event.") - - (TEDIT.UNDO.REPLACE TEXTOBJ EVENT LEN CH# FIRSTPIECE)) - (Get (* ; "He did a GET -- not undoable.") - (TEDIT.PROMPTPRINT TEXTOBJ "You can't UNDO a GET." T)) - (Put (* ; "He did a PUT -- not undoable.") - (TEDIT.PROMPTPRINT TEXTOBJ "You can't UNDO a Put." T)) - (COND - ((AND (SETQ UNDOFN (ASSOC (fetch THACTION of EVENT) - TEDIT.HISTORY.TYPELST)) - (SETQ UNDOFN (CADDR UNDOFN))) - (* ; - "TEDIT.HISTORY.TYPELST is an ALST of form (type redofn undofn)") - (APPLY* UNDOFN TEXTOBJ EVENT LEN CH# FIRSTPIECE)) - (T (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "UNDO not implemented for " - (fetch THACTION of EVENT)) - T] - (\SHOWSEL SEL NIL T))) - (T (TEDIT.PROMPTPRINT TEXTOBJ "Nothing to UNDO." T]) - -(TEDIT.UNDO.INSERTION - [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 21-Apr-93 01:33 by jds") - - (* ;; "UNDO a prior Insert, Copy, or Include.") - - (PROG (OBJ DELETEFN) - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; - "Keep TEdit from reusing the current cache piece in the future -- it is probably invalid") - (\DELETECH CH# (IPLUS CH# LEN) - LEN TEXTOBJ) - (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ) - (fetch (TEXTOBJ SEL) of TEXTOBJ) - CH# - (IPLUS CH# LEN) - TEXTOBJ) (* ; - "Fix the line descriptors & selection") - (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ; - "Fix up the display for all this foofaraw") - (replace (SELECTION POINT) of (fetch (TEXTOBJ SEL) of TEXTOBJ) - with 'LEFT) - (\FIXSEL (fetch (TEXTOBJ SEL) of TEXTOBJ) - TEXTOBJ) (* ; "Really fix the selection") - (replace THACTION of EVENT with 'Delete) - (* ; - "Make the UNDO be UNDOable, by changing the event to a deletion.") - ]) - -(TEDIT.UNDO.DELETION - [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 21-Apr-93 12:01 by jds") - - (* ;; "UNDO a prior Deletion of text.") - - (PROG ((NPC (fetch (PIECE NEXTPIECE) of FIRSTPIECE)) - (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - NEWPIECE INSPC OBJECT INSERTFN START-OF-PIECE) - (SETQ INSPC (\CHTOPC CH# PCTB T)) - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; - "Keep future people from stepping on the current cache piece, which is probably no longer valid.") - (COND - ((fetch (TEXTOBJ TXTREADONLY) of TEXTOBJ) - (* ; - "Don't change read-only documents.") - (RETURN))) - [COND - ((IGREATERP CH# START-OF-PIECE) - (SETQ INSPC (\SPLITPIECE INSPC (- CH# START-OF-PIECE) - TEXTOBJ INSPC#] - (SETQ NEWPIECE (create PIECE using FIRSTPIECE)) - (replace THFIRSTPIECE of EVENT with NEWPIECE) - (bind (TL _ 0) while (ILESSP TL LEN) do (\INSERTPIECE NEWPIECE INSPC TEXTOBJ) - (* ; "Insert the piece back in") - [COND - ([AND (SETQ OBJECT - (fetch (PIECE POBJ) - of NEWPIECE)) - (SETQ INSERTFN - (IMAGEOBJPROP OBJECT - 'WHENINSERTEDFN] - (* ; - "If this is an imageobject, and it has an insertfn, call it.") - (APPLY* INSERTFN OBJECT ( - \TEDIT.PRIMARYW - TEXTOBJ) - NIL - (TEXTSTREAM TEXTOBJ] - (SETQ TL (IPLUS TL (fetch - (PIECE PLEN) - of FIRSTPIECE) - )) - (* ; - "Keep track of how much we've re-inserted") - (SETQ FIRSTPIECE NPC) - (* ; - "Move to the next piece to insert") - (AND NPC (SETQ NPC (fetch - (PIECE NEXTPIECE) - of NPC))) - (SETQ NEWPIECE (create PIECE - using FIRSTPIECE)) - ) (* ; - "Done here because \INSERTPIECE creams the NEXTPIECE field.") - (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS (fetch (TEXTOBJ TEXTLEN) - of TEXTOBJ) - LEN)) - (* ; - "Reset the text length and EOF ptr of the text stream.") - (\FIXILINES TEXTOBJ SEL CH# LEN OTEXTLEN) (* ; - "Fix the line descriptors & selection") - (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ; - "Fix up the display for all this foofaraw") - (replace (SELECTION CH#) of SEL with CH#) - (* ; - "Make the selection point at the re-inserted text") - (replace (SELECTION CHLIM) of SEL with (IPLUS CH# LEN)) - (replace (SELECTION DCH) of SEL with LEN) - (replace (SELECTION POINT) of SEL with (fetch THPOINT of EVENT)) - (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL) - (\FIXSEL SEL TEXTOBJ) (* ; "Really fix the selection") - (replace THACTION of EVENT with 'Insert) - (* ; - "Make the UNDO be UNDOable, by changing the event to a insertion.") - ]) - -(TEDIT.REDO - [LAMBDA (TEXTOBJ) (* ; "Edited 30-May-91 21:27 by jds") - - (* ;; "REDO the last thing this guy did.") - - (PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - EVENT CH) - (COND - ((FETCH (TEXTOBJ TXTREADONLY) OF TEXTOBJ) - - (* ;; "The document is read-only; don't make any changes.") - - NIL) - ((SETQ EVENT (fetch (TEXTOBJ TXTHISTORY) of TEXTOBJ)) - (* ; - "There really is something to REDO Decide what, & do it.") - (RESETLST - (RESETSAVE (CURSOR WAITINGCURSOR)) - (\SHOWSEL SEL NIL NIL) - (SELECTQ (fetch THACTION of EVENT) - ((Insert Copy Include) (* ; "It was an insertion") - (TEDIT.REDO.INSERTION TEXTOBJ EVENT - (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL) - (LEFT (fetch (SELECTION CH#) of SEL)) - (RIGHT (fetch (SELECTION CHLIM) of SEL)) - NIL)))) - (Delete (* ; "It was a deletion") - (\TEDIT.DELETE SEL TEXTOBJ)) - (Replace (* ; - "It was a replacement (a del/insert combo)") - (TEDIT.REDO.REPLACE TEXTOBJ EVENT)) - (LowerCase (* ; "He lower-cased something") - (\TEDIT.LCASE.SEL TEXTOBJ TEXTOBJ SEL)) - (UpperCase (* ; "He upper-cased something") - (\TEDIT.LCASE.SEL TEXTOBJ TEXTOBJ SEL)) - (Looks (* ; "It was a looks change") - (TEDIT.REDO.LOOKS TEXTOBJ EVENT (IMAX 1 - (SELECTQ (fetch (SELECTION - POINT) - of SEL) - (LEFT (fetch (SELECTION - CH#) - of SEL)) - (RIGHT (fetch (SELECTION - CHLIM) - of SEL)) - NIL)))) - (ParaLooks (* ; "It was a Paragraph looks change") - (TEDIT.REDO.PARALOOKS TEXTOBJ EVENT - (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL) - (LEFT (fetch (SELECTION CH#) of SEL)) - (RIGHT (fetch (SELECTION CHLIM) of SEL)) - NIL)))) - (Find (* ; "EXACT-MATCH SEARCH COMMAND") - (RESETLST - (RESETSAVE (CURSOR WAITINGCURSOR)) - (TEDIT.PROMPTPRINT TEXTOBJ "Searching..." T) - (SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (\SHOWSEL SEL NIL NIL) - (SETQ CH (TEDIT.FIND TEXTOBJ (fetch THAUXINFO of EVENT))) - (COND - (CH (TEDIT.PROMPTPRINT TEXTOBJ "done.") - (replace (SELECTION CH#) of SEL with CH) - [replace (SELECTION CHLIM) of SEL - with (IPLUS CH (NCHARS (fetch THAUXINFO - of EVENT] - (replace (SELECTION DCH) of SEL - with (NCHARS (fetch THAUXINFO of EVENT))) - (replace (SELECTION POINT) of SEL with - 'RIGHT) - (\FIXSEL SEL TEXTOBJ) - (TEDIT.NORMALIZECARET TEXTOBJ) - (\SHOWSEL SEL NIL T)) - (T (TEDIT.PROMPTPRINT TEXTOBJ "[Not found]")))) - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; "Drop the cached piece. WHY??") - ) - ((Move ReplaceMove) (* ; "He moved some text") - (TEDIT.REDO.MOVE TEXTOBJ EVENT (fetch THLEN of EVENT) - (IMAX 1 (SELECTQ (fetch (SELECTION POINT) of SEL) - (LEFT (fetch (SELECTION CH#) of SEL)) - (RIGHT (fetch (SELECTION CHLIM) of SEL)) - NIL)) - (fetch THFIRSTPIECE of EVENT))) - (Get (* ; "He did a GET -- not undoable.") - (TEDIT.PROMPTPRINT TEXTOBJ "You can't REDO a GET." T)) - (Put (* ; "He did a PUT -- not undoable.") - (TEDIT.PROMPTPRINT TEXTOBJ "You can't REDO a PUT." T)) - (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT "REDO of the action " (fetch THACTION - of EVENT) - " isn't implemented.") - T)) - (\SHOWSEL SEL NIL T))) - (T (TEDIT.PROMPTPRINT TEXTOBJ "Nothing to REDO." T]) - -(TEDIT.REDO.INSERTION - [LAMBDA (TEXTOBJ EVENT CH#) (* ; - "Edited 3-Apr-95 15:55 by sybalsky:mv:envos") - (* ; - "REDO a prior Insert/Copy/Include of text.") - (PROG (INSPC INSPC# NPC (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (LEN (fetch THLEN of EVENT)) - (FIRSTPIECE (create PIECE using (CAR (fetch THFIRSTPIECE of EVENT)) - PNEW _ T)) - (OTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - OBJ COPYFN ORIGFIRSTPC) - (SETQ ORIGFIRSTPC FIRSTPIECE) - (replace THFIRSTPIECE of EVENT with (LIST FIRSTPIECE)) - (* ; - "So we can UNDO this, and remove the right set of pieces.") - (replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL) - (* ; - "Force any further insertions to make new pieces.") - (SETQ NPC (fetch (PIECE NEXTPIECE) of FIRSTPIECE)) - (SETQ INSPC (\CHTOPC CH# PCTB T)) - [SETQ INSPC (COND - ((IEQP CH# START-OF-PIECE) (* ; - "We're inserting just before an existing piece") - INSPC) - (T (* ; - "We must split this piece, and insert before the second part.") - (\SPLITPIECE INSPC (- CH# START-OF-PIECE) - TEXTOBJ] - (bind (TL _ 0) while (ILESSP TL LEN) - do - - (* ;; "Loop thru the pieces of the prior insertion, inserting copies of enough of them to cover the length of the insertion.") - - [COND - ((SETQ OBJ (fetch (PIECE POBJ) of FIRSTPIECE)) - (* ; "This piece describes an object") - [COND - [(SETQ COPYFN (IMAGEOBJPROP OBJ 'COPYFN)) - (SETQ OBJ (APPLY* COPYFN OBJ (fetch (TEXTOBJ STREAMHINT) of - TEXTOBJ - ) - (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))) - (COND - ((EQ OBJ 'DON'T) - (TEDIT.PROMPTPRINT TEXTOBJ "COPY of this object not allowed." T) - (RETFROM 'TEDIT.COPY)) - (T (replace (PIECE POBJ) of FIRSTPIECE with OBJ] - (OBJ (replace (PIECE POBJ) of FIRSTPIECE with (COPY 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 TEXTOBJ)) - 'DSP) - (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) - (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ] - (\INSERTPIECE FIRSTPIECE INSPC TEXTOBJ) (* ; "Insert the piece back in") - (SETQ TL (IPLUS TL (fetch (PIECE PLEN) of FIRSTPIECE))) - (* ; - "Keep track of how much we've re-inserted") - (SETQ FIRSTPIECE (create PIECE using NPC PNEW _ T)) - (* ; - "Move to the next piece to insert") - (AND NPC (SETQ NPC (fetch (PIECE NEXTPIECE) of NPC))) - (* ; - "Done here because \INSERTPIECE creams the NEXTPIECE field.") - ) - (\TEDIT.DIFFUSE.PARALOOKS (fetch (PIECE PREVPIECE) of ORIGFIRSTPC) - INSPC) (* ; - "propagate paragraph formatting into the new insertion") - (replace (TEXTOBJ TEXTLEN) of TEXTOBJ with (IPLUS (fetch (TEXTOBJ TEXTLEN) - of TEXTOBJ) - LEN)) - (* ; - "Reset the text length and EOF ptr of the text stream.") - (\FIXILINES TEXTOBJ SEL CH# LEN OTEXTLEN) (* ; - "Fix the line descriptors & selection") - (TEDIT.UPDATE.SCREEN TEXTOBJ) (* ; - "Fix up the display for all this foofaraw") - (replace (SELECTION CH#) of SEL with CH#) - (* ; - "Make the selection point at the re-inserted text") - (replace (SELECTION CHLIM) of SEL with (IPLUS CH# LEN)) - (replace (SELECTION DCH) of SEL with LEN) - (\TEDIT.SET.SEL.LOOKS SEL 'NORMAL) - (\FIXSEL SEL TEXTOBJ) (* ; "Really fix the selection") - (replace THACTION of EVENT with 'Insert) - (* ; - "Make the UNDO be UNDOable, by changing the event to a insertion.") - ]) - -(TEDIT.UNDO.MOVE - [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 30-May-91 21:27 by jds") - (* ; "UNDO a MOVE command") - (PROG ((TOOBJ (fetch THAUXINFO of EVENT)) - (FROMOBJ (fetch THTEXTOBJ of EVENT)) - (SOURCECH# (fetch THOLDINFO of EVENT)) - (CH# (fetch THCH# of EVENT)) - TOSEL TOTEXTLEN) - (\SHOWSEL (fetch (TEXTOBJ SEL) of TOOBJ) - NIL NIL) (* ; - "Turn off the selections in the old source and target documents") - (\SHOWSEL (fetch (TEXTOBJ SEL) of FROMOBJ) - NIL NIL) - (\DELETECH CH# (IPLUS CH# LEN) - LEN FROMOBJ) (* ; - "Delete the characters we moved, from the place we moved them to") - (\FIXDLINES (fetch (TEXTOBJ LINES) of FROMOBJ) - (fetch (TEXTOBJ SEL) of FROMOBJ) - CH# - (IPLUS CH# LEN) - FROMOBJ) - (replace (SELECTION CH#) of (fetch (TEXTOBJ SEL) of FROMOBJ) - with (replace (SELECTION CHLIM) of (fetch (TEXTOBJ SEL) of FROMOBJ) - with CH#)) (* ; - "Make this document's selection be a point sel at the place the text used to be.") - (replace (SELECTION DCH) of (fetch (TEXTOBJ SEL) of FROMOBJ) with - 0) - (replace (SELECTION POINT) of (fetch (TEXTOBJ SEL) of FROMOBJ) - with 'LEFT) (* ; - "Mark lines for update, and fix the selection") - (SETQ TOTEXTLEN (fetch (TEXTOBJ TEXTLEN) of TOOBJ)) - (* ; - "The pre-insertion len of the place the text is returning to, for the line udpater below") - (\TEDIT.INSERT.PIECES TOOBJ SOURCECH# (fetch THFIRSTPIECE of EVENT) - LEN) - - (* ;; "Put the pieces we moved back where they came from (no need to copy them, since we did that on the original move.)") - - (\FIXILINES TOOBJ (fetch (TEXTOBJ SEL) of TOOBJ) - SOURCECH# LEN TOTEXTLEN) (* ; - "Mark lines that need updating, and fix up the selection") - (add (fetch (TEXTOBJ TEXTLEN) of TOOBJ) - LEN) (* ; - "Update the text length of the erstwhile move source") - (TEDIT.UPDATE.SCREEN FROMOBJ) (* ; - "Update the erstwhile text location's image.") - (COND - ((NEQ FROMOBJ TOOBJ) (* ; - "If they aren't the same document, we need to update the other document image as well.") - (TEDIT.UPDATE.SCREEN TOOBJ))) - (\FIXSEL (fetch (TEXTOBJ SEL) of TOOBJ) - TOOBJ) (* ; - "Fix up the selections so their images will be OK") - (\FIXSEL (fetch (TEXTOBJ SEL) of FROMOBJ) - FROMOBJ) - (\COPYSEL (fetch (TEXTOBJ SEL) of FROMOBJ) - TEDIT.SELECTION) (* ; - "It's handy to think of this as the last selection made, also.") - (replace THACTION of EVENT with 'Move) - (replace THTEXTOBJ of EVENT with TOOBJ) - (replace THAUXINFO of EVENT with FROMOBJ) - (replace THOLDINFO of EVENT with CH#) - (replace THCH# of EVENT with SOURCECH#) - (\SHOWSEL (fetch (TEXTOBJ SEL) of TOOBJ) - NIL T) - (\SHOWSEL (fetch (TEXTOBJ SEL) of FROMOBJ) - NIL T]) - -(TEDIT.UNDO.REPLACE - [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; - "Edited 22-Mar-95 16:47 by sybalsky:mv:envos") - (PROG ((OLDEVENT (fetch THOLDINFO of EVENT)) - (CH# (fetch THCH# of EVENT)) - (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) - (\SHOWSEL SEL NIL NIL) - (TEDIT.UNDO.INSERTION TEXTOBJ EVENT LEN CH# FIRSTPIECE) - (\SHOWSEL SEL NIL NIL) - (TEDIT.UNDO.DELETION TEXTOBJ OLDEVENT (fetch THLEN of OLDEVENT) - CH# - (CAR (fetch THFIRSTPIECE of OLDEVENT))) - (replace THOLDINFO of OLDEVENT with EVENT) - (replace THACTION of OLDEVENT with 'Replace) - (replace THOLDINFO of EVENT with NIL) - (\TEDIT.HISTORYADD TEXTOBJ OLDEVENT) - (replace (SELECTION CH#) of SEL with CH#) - (replace (SELECTION CHLIM) of SEL with (IPLUS CH# (fetch THLEN of - OLDEVENT))) - (replace (SELECTION DCH) of SEL with (fetch THLEN of OLDEVENT)) - (replace (SELECTION POINT) of SEL with (fetch THPOINT of EVENT)) - (replace THPOINT of OLDEVENT with (fetch THPOINT of EVENT)) - (\FIXSEL SEL TEXTOBJ) - (\SHOWSEL SEL NIL T]) - -(TEDIT.REDO.REPLACE - [LAMBDA (TEXTOBJ EVENT) (* ; "Edited 30-May-91 21:28 by jds") - (PROG ((OLDEVENT (fetch THOLDINFO of EVENT)) - (CH# (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL) of TEXTOBJ))) - (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))) - (\SHOWSEL SEL NIL NIL) - (\DELETECH (fetch (SELECTION CH#) of SEL) - (fetch (SELECTION CHLIM) of SEL) - (IDIFFERENCE (fetch (SELECTION CHLIM) of SEL) - (fetch (SELECTION CH#) of SEL)) - TEXTOBJ) - (\FIXDLINES (fetch (TEXTOBJ LINES) of TEXTOBJ) - SEL - (fetch (SELECTION CH#) of SEL) - (fetch (SELECTION CHLIM) of SEL) - TEXTOBJ) - (replace (SELECTION POINT) of SEL with 'LEFT) - (TEDIT.REDO.INSERTION TEXTOBJ EVENT CH#) - (replace THOLDINFO of EVENT with (SETQ OLDEVENT (fetch (TEXTOBJ TXTHISTORY) - of TEXTOBJ))) - (replace THACTION of OLDEVENT with 'Replace) - (replace THACTION of EVENT with 'Replace) - (replace THCH# of EVENT with CH#) - (\TEDIT.HISTORYADD TEXTOBJ EVENT]) - -(TEDIT.REDO.MOVE - [LAMBDA (TEXTOBJ EVENT LEN CH# FIRSTPIECE) (* ; "Edited 30-May-91 21:28 by jds") - (PROG ((FROMOBJ TEXTOBJ) - (SOURCECH# (fetch THOLDINFO of EVENT)) - (OLDCH# (fetch THCH# of EVENT)) - (SEL (fetch (TEXTOBJ SEL) of TEXTOBJ)) - (MOVESEL (fetch (TEXTOBJ MOVESEL) of TEXTOBJ)) - OLDCHLIM) - (replace (SELECTION CH#) of MOVESEL with OLDCH#) - (replace (SELECTION CHLIM) of MOVESEL with (IPLUS OLDCH# LEN)) - (replace (SELECTION DCH) of MOVESEL with LEN) - (replace (SELECTION SET) of MOVESEL with T) - (\FIXSEL MOVESEL TEXTOBJ) - (\TEDIT.SET.SEL.LOOKS MOVESEL 'MOVE) - (TEDIT.MOVE MOVESEL SEL]) -) -(PUTPROPS TEDITHISTORY COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1990 1991 1993 -1995)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1696 5135 (\TEDIT.HISTORYADD 1706 . 3591) (\TEDIT.CUMULATE.EVENTS 3593 . 5133)) (5188 -38576 (TEDIT.UNDO 5198 . 9210) (TEDIT.UNDO.INSERTION 9212 . 10798) (TEDIT.UNDO.DELETION 10800 . 16735) - (TEDIT.REDO 16737 . 23674) (TEDIT.REDO.INSERTION 23676 . 30392) (TEDIT.UNDO.MOVE 30394 . 34827) ( -TEDIT.UNDO.REPLACE 34829 . 36330) (TEDIT.REDO.REPLACE 36332 . 37757) (TEDIT.REDO.MOVE 37759 . 38574))) -)) -STOP diff --git a/obsolete/library/new/TEDITHISTORY.LCOM b/obsolete/library/new/TEDITHISTORY.LCOM deleted file mode 100644 index a7cdd2f6..00000000 Binary files a/obsolete/library/new/TEDITHISTORY.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITLOOKS.LCOM b/obsolete/library/new/TEDITLOOKS.LCOM deleted file mode 100644 index a214e28f..00000000 Binary files a/obsolete/library/new/TEDITLOOKS.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITMENU b/obsolete/library/new/TEDITMENU deleted file mode 100644 index 70d40cc7..00000000 --- a/obsolete/library/new/TEDITMENU +++ /dev/null @@ -1,4538 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Apr-95 15:10:41" {DSK}library>new>TEDITMENU.;1 275626 - - changes to%: (FNS \TEDIT.TABTYPE.SET) - - previous date%: "25-Aug-94 10:54:56" {DSK}export>lispcore>library>TEDITMENU.;4) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TEDITMENUCOMS) - -(RPAQQ TEDITMENUCOMS - [(FILES TEDITDCL) - (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64)) - (FILES (LOADCOMP) - TEDITDCL)) - [COMS (* ; "Simple Menu Button support") - (FNS MB.BUTTONEVENTINFN MB.DISPLAY MB.SETIMAGE MB.SELFN MB.SIZEFN MB.WHENOPERATEDFN - MB.COPYFN MB.GETFN MB.PUTFN MB.SHOWSELFN MBUTTON.CREATE MBUTTON.CHANGENAME - MBUTTON.FIND.BUTTON MBUTTON.FIND.NEXT.BUTTON MBUTTON.FIND.NEXT.FIELD MBUTTON.INIT - MBUTTON.NEXT.FIELD.AS.NUMBER MBUTTON.NEXT.FIELD.AS.PIECES - MBUTTON.NEXT.FIELD.AS.TEXT MBUTTON.NEXT.FIELD.AS.ATOM MBUTTON.SET.FIELD - MBUTTON.SET.NEXT.FIELD MBUTTON.SET.NEXT.BUTTON.STATE TEDITMENU.STREAM - \TEDITMENU.SELSCREENER) - (GLOBALVARS MBUTTONIMAGEFNS) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MBUTTON.INIT)) - (ADDVARS (IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN] - [COMS - (* ;; - "Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD") - - (FNS MB.CREATE.THREESTATEBUTTON MB.THREESTATE.DISPLAY MB.THREESTATE.SHOWSELFN - MB.THREESTATE.WHENOPERATEDFN MB.THREESTATEBUTTON.FN THREESTATE.INIT) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (THREESTATE.INIT] - [COMS (* ; "One-of-N Menu button sets") - (FNS MB.CREATE.NWAYBUTTON MB.NB.DISPLAYFN MB.NB.WHENOPERATEDFN MB.NB.SIZEFN - MB.NWAYBUTTON.SELFN MB.NWAYMENU.NEWBUTTON NWAYBUTTON.INIT MB.NB.PACKITEMS - MB.NWAYBUTTON.ADDITEM) - (GLOBALVARS NWAYBUTTONIMAGEFNS) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (NWAYBUTTON.INIT)) - (ADDVARS (IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN] - [COMS - (* ;; "Two-state, toggling menu buttons.") - - (FNS \TEXTMENU.TOGGLE.CREATE \TEXTMENU.TOGGLE.DISPLAY \TEXTMENU.TOGGLE.SHOWSELFN - \TEXTMENU.TOGGLE.WHENOPERATEDFN \TEXTMENU.TOGGLEFN \TEXTMENU.TOGGLE.INIT - \TEXTMENU.SET.TOGGLE) - (GLOBALVARS \TOGGLEIMAGEFNS) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEXTMENU.TOGGLE.INIT)) - (ADDVARS (IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN] - [COMS - (* ;; "Margin Setting and display") - - (FNS DRAWMARGINSCALE MARGINBAR MARGINBAR.CREATE MB.MARGINBAR.SELFN MB.MARGINBAR.SIZEFN - MB.MARGINBAR.DISPLAYFN MDESCALE MSCALE MB.MARGINBAR.SHOWTAB MB.MARGINBAR.TABTRACK - \TEDIT.TABTYPE.SET MARGINBAR.INIT) - (BITMAPS \TEDIT.LEFTTAB \TEDIT.CENTERTAB \TEDIT.RIGHTTAB \TEDIT.DECIMALTAB - \TEDIT.DOTTED.LEFTTAB \TEDIT.DOTTED.CENTERTAB \TEDIT.DOTTED.RIGHTTAB - \TEDIT.DOTTED.DECIMALTAB TEDIT.EXTENDEDRIGHTMARK) - (GLOBALVARS MARGINBARIMAGEFNS) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MARGINBAR.INIT)) - (ADDVARS (IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN] - (COMS - (* ;; "Text menu creation and support") - - (FNS \TEXTMENU.START \TEXTMENU.DOC.CREATE TEXTMENU.CLOSEFN) - (BITMAPS TEXTMENUICON TEXTMENUICONMASK)) - [COMS (* ; "TEdit-specific support") - (FNS \TEDITMENU.CREATE \TEDIT.EXPANDED.MENU MB.DEFAULTBUTTON.FN - \TEDITMENU.RECORD.UNFORMATTED MB.DEFAULTBUTTON.ACTIONFN) - (FNS \TEDIT.CHARLOOKSMENU.CREATE \TEDIT.EXPANDEDCHARLOOKS.MENU \TEDIT.APPLY.BOLDNESS - \TEDIT.APPLY.CHARLOOKS \TEDIT.APPLY.OLINE \TEDIT.SHOW.CHARLOOKS - \TEDIT.NEUTRALIZE.CHARLOOKS \TEDIT.FILL.IN.CHARLOOKS.MENU - \TEDIT.NEUTRALIZE.CHARLOOKS.MENU \TEDIT.PARSE.CHARLOOKS.MENU \TEDIT.APPLY.SLOPE - \TEDIT.APPLY.STRIKEOUT \TEDIT.APPLY.ULINE) - (FNS \TEDITPARAMENU.CREATE \TEDIT.EXPANDEDPARA.MENU \TEDIT.APPLY.PARALOOKS - \TEDIT.SHOW.PARALOOKS \TEDIT.NEUTRALIZE.PARALOOKS.MENU \TEDIT.RECORD.TABLEADERS) - (FNS \TEDIT.SHOW.PAGEFORMATTING \TEDITPAGEMENU.CREATE \TEDIT.APPLY.PAGEFORMATTING - TEDIT.UNPARSE.PAGEFORMAT) - (COMS (* ; "Initialization Code") - (GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU - TEDIT.MENUDIVIDER.SPEC TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC - TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC TEDIT.EXPANDED.PAGEMENU) - (FNS \TEDIT.MENU.INIT) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TEDIT.MENU.INIT) - (\TEDITMENU.CREATE) - (\TEDIT.CHARLOOKSMENU.CREATE) - (\TEDITPARAMENU.CREATE) - (\TEDITPAGEMENU.CREATE] - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA]) - -(FILESLOAD TEDITDCL) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ \SCRATCHLEN 64) - - -(CONSTANTS (\SCRATCHLEN 64)) -) - - -(FILESLOAD (LOADCOMP) - TEDITDCL) -) - - - -(* ; "Simple Menu Button support") - -(DEFINEQ - -(MB.BUTTONEVENTINFN - [LAMBDA (OBJ STREAM SEL RELX RELY SELWINDOW TEXTSTREAM)(* ; "Edited 30-May-91 22:15 by jds") - - (* There was a buttn event inside a menu button. - Make sure that the button gets turned OFF when the mouse moves outside it.) - - (PROG [(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX] - (replace (SELECTION SELKIND) of SEL with 'VOLATILE) - (COND - ((IMAGEOBJPROP OBJ 'MENUBUTTON.SELECTED) - - (* This button is still active from an earlier hit. - Don't let it be selected again.) - - (RETURN 'DON'T)) - ((AND (IGEQ RELX 0) - (IGEQ RELY 0) - (ILEQ RELX (fetch XSIZE of OBJBOX)) - (ILEQ RELY (fetch YSIZE of OBJBOX))) - (* We're really inside the thing. - Return an indication that we're to - be left alone.) - (RETURN T)) - (T (* He's moved outside the button. - Don't permit the selection.) - (RETURN 'DON'T]) - -(MB.DISPLAY - [LAMBDA (OBJ STREAM MODE) (* ; "Edited 11-Jan-89 16:58 by jds") - - (* ;; "Display the innards of a menu button") - - (SELECTQ (IMAGESTREAMTYPE STREAM) - (DISPLAY - (* ;; "Going to the display. Use the cached bitmap version of the button") - - [PROG (BITMAP DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) - (X (DSPXPOSITION NIL STREAM)) - (Y (DSPYPOSITION NIL STREAM))) - [SETQ BITMAP (COND - ((IMAGEOBJPROP OBJ 'BITCACHE)) - (T (MB.SETIMAGE OBJ) - (IMAGEOBJPROP OBJ 'BITCACHE] - [BITBLT BITMAP 0 0 STREAM X (SETQ Y (IDIFFERENCE Y (fetch YDESC - of OBJBOX] - (* ; "Display the button's image") - (COND - ((EQ (IMAGEOBJPROP OBJ 'STATE) - 'ON) (* ; - "If the button is ON, mark it so.") - (BITBLT NIL 0 0 STREAM X Y (fetch XSIZE of OBJBOX) - (fetch YSIZE of OBJBOX) - 'TEXTURE - 'INVERT BLACKSHADE]) - (PROG (BITMAP DS (FONT (IMAGEOBJPROP OBJ 'MBFONT)) - (TEXT (IMAGEOBJPROP OBJ 'MBTEXT)) - OLOOKS) (* ; - "Going to some output image stream. Use the actual text.") - (SETQ OLOOKS (DSPFONT (FONTCOPY FONT 'DEVICE STREAM) - STREAM)) (* ; - "Change to the font for this menu button.") - (PRIN1 TEXT STREAM) (* ; "Print the button text") - (DSPFONT OLOOKS STREAM) (* ; - "And put the font back as it was.") - ]) - -(MB.SETIMAGE - [LAMBDA (OBJ) (* jds "23-Aug-84 13:22") - (PROG ((MBFONT (IMAGEOBJPROP OBJ 'MBFONT)) - (MBTEXT (IMAGEOBJPROP OBJ 'MBTEXT)) - BOX BITMAP DS) - (SETQ BOX (create IMAGEBOX - XSIZE _ (STRINGWIDTH MBTEXT MBFONT) - YSIZE _ (FONTPROP MBFONT 'HEIGHT) - YDESC _ (FONTPROP MBFONT 'DESCENT) - XKERN _ 0)) - (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of BOX) - (fetch YSIZE of BOX))) - (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) - (IMAGEOBJPROP OBJ 'BOUNDBOX BOX) - (SETQ DS (DSPCREATE BITMAP)) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPFONT MBFONT DS) - (MOVETO 0 (FONTPROP MBFONT 'DESCENT) - DS) - (PRIN1 MBTEXT DS) - (RETURN OBJ]) - -(MB.SELFN - [LAMBDA (OBJ SEL W FN) (* ; "Edited 30-May-91 22:15 by jds") - (* Calls a menu-button's associated - function, then turns off the - highlighting of the menu button.) - (PROG [(TSEL (create SELECTION)) - (BUTTONFN (OR FN (IMAGEOBJPROP OBJ 'MBFN] - (\COPYSEL SEL TSEL) (* Save the selection that points to - the menu button.) - (replace (SELECTION SELKIND) of SEL with 'CHAR) - (replace (SELECTION SET) of SEL with NIL) - (replace (SELECTION ONFLG) of SEL with NIL) - (* Call the button's function) - (COND - ((NEQ (AND BUTTONFN (APPLY* BUTTONFN OBJ SEL W)) - 'DON'T) (* If the button fn left the - selection alone,) - (\FIXSEL TSEL (fetch (SELECTION \TEXTOBJ) of TSEL)) - (\SHOWSEL TSEL NIL NIL))) (* Turn off the button hilite) - ]) - -(MB.SIZEFN - [LAMBDA (OBJ STREAM CURX RIGHTMARGIN) (* jds "30-Aug-84 11:24") - (* Tell the size of a menu button) - (PROG ((FONT (IMAGEOBJPROP OBJ 'MBFONT)) - BOX) - [COND - ((DISPLAYSTREAMP STREAM) (* We're formatting for the DISPLAY) - ) - [(EQ 'INTERPRESS (IMAGESTREAMTYPE STREAM)) - (SETQ FONT (FONTCOPY FONT 'DEVICE 'INTERPRESS] - ((EQ 'PRESS (IMAGESTREAMTYPE STREAM)) - (SETQ FONT (FONTCOPY FONT 'DEVICE 'PRESS] - (SETQ BOX (create IMAGEBOX - XSIZE _ (STRINGWIDTH (IMAGEOBJPROP OBJ 'MBTEXT) - FONT) - YSIZE _ (FONTPROP FONT 'HEIGHT) - YDESC _ (FONTPROP FONT 'DESCENT) - XKERN _ 0)) - (IMAGEOBJPROP OBJ 'BOUNDBOX BOX) - (RETURN BOX]) - -(MB.WHENOPERATEDFN - [LAMBDA (OBJ DS OPERATION SEL) (* jds " 7-Feb-84 14:20") - (SELECTQ OPERATION - (HIGHLIGHTED (MB.SHOWSELFN OBJ SEL T DS)) - (UNHIGHLIGHTED (MB.SHOWSELFN OBJ SEL NIL DS)) - (SELECTED (MB.SELFN OBJ SEL DS)) - (DESELECTED) - NIL]) - -(MB.COPYFN - [LAMBDA (OBJ) (* jds "23-May-84 11:32") - (* Copy a menu button object.) - (create IMAGEOBJ - OBJECTDATUM _ (COPY (fetch (IMAGEOBJ OBJECTDATUM) of OBJ)) - IMAGEOBJPLIST _ (COPY (fetch (IMAGEOBJ IMAGEOBJPLIST) of OBJ)) - IMAGEOBJFNS _ (fetch (IMAGEOBJ IMAGEOBJFNS) of OBJ]) - -(MB.GETFN - [LAMBDA (OBJ FILE) (* ; "Edited 20-Aug-87 16:17 by jds") - (* READ a menu button from a file.) - (ERROR) - (PROG [(TEXT (IMAGEOBJPROP OBJ 'MBTEXT)) - (MBFN (IMAGEOBJPROP OBJ 'MBFN)) - (FONT (IMAGEOBJPROP OBJ 'MBFONT] - (\STRINGOUT FILE TEXT) - (\ATMOUT FILE MBFN) - (\ATMOUT FILE (FONTPROP FONT 'FAMILY)) - (\SMALLPOUT FILE (FONTPROP FONT 'SIZE)) - (for ATTR in (FONTPROP FONT 'FACE) do (\ATMOUT FILE ATTR]) - -(MB.PUTFN - [LAMBDA (OBJ FILE) (* ; "Edited 20-Aug-87 16:17 by jds") - - (* ;; - "Write a menu button from a file; suitable for re-reading using the image objects GETFN.") - - (PROG [(TEXT (IMAGEOBJPROP OBJ 'MBTEXT)) - (MBFN (IMAGEOBJPROP OBJ 'MBFN)) - (FONT (IMAGEOBJPROP OBJ 'MBFONT] - (HELP) - (\STRINGOUT FILE TEXT) (* ; "The button's image") - - (\ATMOUT FILE MBFN) (* ; "The FN called when hit") - - (\ATMOUT FILE (FONTPROP FONT 'FAMILY)) - (\SMALLPOUT FILE (FONTPROP FONT 'SIZE)) - (for ATTR in (FONTPROP FONT 'FACE) do (\ATMOUT FILE ATTR]) - -(MB.SHOWSELFN - [LAMBDA (OBJ SEL ON DS) (* ; "Edited 11-Jan-89 16:35 by jds") - (LET [(OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX] - (OR (IMAGEOBJPROP OBJ 'BITCACHE) - (MB.DISPLAY OBJ)) (* ; - "MAKE SURE THE DISPLAY FORM EXISTS") - (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE) - 0 0 DS 0 0 (fetch (IMAGEBOX XSIZE) of OBJBOX) - (fetch (IMAGEBOX YSIZE) of OBJBOX) - 'INPUT - 'REPLACE) - (COND - ((OR ON (EQ (IMAGEOBJPROP OBJ 'STATE) - 'ON)) - (BITBLT NIL 0 (fetch (IMAGEBOX YDESC) of OBJBOX) - DS 0 0 (fetch (IMAGEBOX XSIZE) of OBJBOX) - (fetch (IMAGEBOX YSIZE) of OBJBOX) - 'TEXTURE - 'INVERT BLACKSHADE]) - -(MBUTTON.CREATE - [LAMBDA (MBTEXT MBFN MBFONT IMAGEFNS) (* ; "Edited 11-Jan-89 16:10 by jds") - - (* ;; "Create a MENU BUTTON image object, and fill in its image and function-hook fields") - - (LET* ([REAL-FONT (OR MBFONT (FONTCLASSCOMPONENT DEFAULTFONT 'DISPLAY] - (OBJ (IMAGEOBJCREATE NIL (OR IMAGEFNS MBUTTONIMAGEFNS))) - (BOX (create IMAGEBOX - XSIZE _ (STRINGWIDTH MBTEXT REAL-FONT) - YSIZE _ (FONTPROP REAL-FONT 'HEIGHT) - YDESC _ (FONTPROP REAL-FONT 'DESCENT) - XKERN _ 0)) - BITMAP DS) - (IMAGEOBJPROP OBJ 'MBFN MBFN) (* ; - "The function to be called when the button is pushed") - (IMAGEOBJPROP OBJ 'MBTEXT MBTEXT) (* ; - "The text displayed in the button") - (IMAGEOBJPROP OBJ 'MBFONT REAL-FONT) (* ; "The font that text appears in") - (MB.SETIMAGE OBJ) (* ; - "Set up the image for the button, so we don't create it repeatedly.") - OBJ]) - -(MBUTTON.CHANGENAME - [LAMBDA (TEXTOBJ OBJ NEWNAME) (* jds "23-Aug-84 13:26") - - (* Change the text that appears in a button, and redisplay the button if it's - visible) - - (PROG (BOX BITMAP DS) - (IMAGEOBJPROP OBJ 'MBTEXT NEWNAME) - (MB.SETIMAGE OBJ) - (TEDIT.OBJECT.CHANGED TEXTOBJ OBJ]) - -(MBUTTON.FIND.BUTTON - [LAMBDA (LABEL TEXTSTREAM CH#) (* ; "Edited 22-Apr-93 15:40 by jds") - (* "27-Sep-84 00:52" gbn) - - (* * returns the piece no containing the imageobj with MBTEXT prop LABEL) - - (PROG ((LABELATOM (MKATOM LABEL)) - OBJ STARTPCNO (PCTB (fetch (TEXTOBJ PCTB) of (TEXTOBJ TEXTSTREAM))) - START-OF-PIECE PC) - (RETURN (first (SETQ PC (\CHTOPC (OR CH# 1) - PCTB T)) while (AND PC (NOT (ATOM PC))) - do (SETQ OBJ (fetch (PIECE POBJ) of PC)) - (COND - ([AND OBJ (EQ LABELATOM (MKATOM (IMAGEOBJPROP OBJ 'MBTEXT] - (RETURN PCNO))) - (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) - -(MBUTTON.FIND.NEXT.BUTTON - [LAMBDA (TEXTOBJ CH#) (* ; "Edited 22-Apr-93 16:39 by jds") - - (* ;; "Finds the next instance of an OBJECT which looks like a menu button, 3-state button, or menuobj. If none is found, return NIL") - - (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - START-OF-PIECE) - (RETURN (bind PC OBJ first (SETQ PC (\CHTOPC CH# PCTB T)) - while (AND PC (NOT (ATOM PC))) - do (* ; - "Loo thru the piece table, looking for pieces with objects in them") - (SETQ OBJ (fetch (PIECE POBJ) of PC)) - [COND - ((AND OBJ (OR (type? MBUTTON OBJ) - (type? MARGINBAR OBJ) - (type? NWAYBUTTON OBJ))) - (* ; - "Which are some kind of menu-buttonish object") - (RETURN (CONS OBJ START-OF-PIECE] - (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC]) - -(MBUTTON.FIND.NEXT.FIELD - [LAMBDA (TEXTOBJ CH# DON'TFIX) (* ; "Edited 22-Apr-93 16:53 by jds") - - (* ;; "Starting from CH#, find the next fill-in area (usually surrounded by a {-} pair), and select any text it contains. Returns the TEXTOBJ's SCRATCHSEL with the text selected. (If no insert point is found, NIL.)") - - (PROG ((PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - CH1 PCNO PCNO1 PC CH LEN START-OF-PIECE (DEPTH 0)) - (COND - ((IGREATERP CH# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) - (* ; - "Can't look past the end of the document") - (RETURN NIL))) - (SETQ PC (\CHTOPC CH# PCTB T)) - (while PC do (* ; - "Look thru the pieces for one which starts a user-fill-in area") - (COND - ((fetch (CHARLOOKS CLSELHERE) of (fetch (PIECE PLOOKS) - of PC)) - (* ; "Found it, so return") - (RETURN))) - (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) - (COND - (PC (* ; - "We found a starting point for a type-in field") - (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) - (SETQ CH1 START-OF-PIECE) (* ; - "Remember the starting character number") - (SETQ PC (fetch (PIECE NEXTPIECE) of PC)) - (while PC do (COND - ((fetch (CHARLOOKS CLPROTECTED) - of (fetch (PIECE PLOOKS) of PC)) - (RETURN))) - (add START-OF-PIECE (fetch (PIECE PLEN) of PC)) - (SETQ PC (fetch (PIECE NEXTPIECE) of PC))) - (SETQ LEN (IDIFFERENCE START-OF-PIECE CH1)) - (replace (SELECTION CH#) of SCRATCHSEL with CH1) - (replace (SELECTION CHLIM) of SCRATCHSEL with (IPLUS CH1 - (IMAX 0 LEN))) - (replace (SELECTION DCH) of SCRATCHSEL with LEN) - (replace (SELECTION SELOBJ) of SCRATCHSEL with NIL) - (replace (SELECTION POINT) of SCRATCHSEL with 'LEFT) - (* ; - "So if it's used, it'll be in the correct spot.") - (replace (SELECTION SELKIND) of SCRATCHSEL with 'CHAR)) - (T (* ; - "No fill-in blank found, so return an indication.") - (RETURN NIL))) - (COND - ((NOT DON'TFIX) - (\FIXSEL SCRATCHSEL TEXTOBJ))) - (RETURN SCRATCHSEL]) - -(MBUTTON.INIT - [LAMBDA NIL (* jds "12-Feb-85 14:32") - (SETQ MBUTTONIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.DISPLAY) - (FUNCTION MB.SIZEFN) - (FUNCTION MB.PUTFN) - (FUNCTION MB.GETFN) - 'MB.COPYFN - (FUNCTION MB.BUTTONEVENTINFN) - 'NILL - 'NILL - 'NILL - 'NILL - 'NILL - (FUNCTION MB.WHENOPERATEDFN) - 'NIL - 'TEditMenuButton]) - -(MBUTTON.NEXT.FIELD.AS.NUMBER - [LAMBDA (TEXTOBJ CH#) (* ; "Edited 12-Jun-90 19:00 by mitani") - (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T) - (NUMBERP (MKATOM (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) - (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ]) - -(MBUTTON.NEXT.FIELD.AS.PIECES - [LAMBDA (TEXTOBJ CH#) (* ; "Edited 30-Mar-94 16:02 by jds") - - (* ;; - "Find the next fill-in field in the menu after CH#, and return its contents as A LIST OF PIECES.") - - (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T) - (TEDIT.SELECTED.PIECES TEXTOBJ (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ) - NIL - 'CL:IDENTITY]) - -(MBUTTON.NEXT.FIELD.AS.TEXT - [LAMBDA (TEXTOBJ CH#) (* ; "Edited 22-Apr-93 16:14 by jds") - - (* ;; "Find the next fill-in field in the menu after CH#, and return its contents as a string.") - - (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T) - (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) - (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ]) - -(MBUTTON.NEXT.FIELD.AS.ATOM - [LAMBDA (TEXTOBJ CH#) (* ; "Edited 12-Jun-90 19:00 by mitani") - - (* Find the next fill-in field, and return its contents as an atom. - If the field is empty, return NIL.) - - (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH# T) (* Move to the next fill-in blank.) - (PROG [(STR (TEDIT.SEL.AS.STRING (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ) - (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ] - (COND - ((ZEROP (NCHARS STR)) (* The field is empty.) - (RETURN NIL)) - (T (* It's non-empty. - Convert the string to an atom.) - (RETURN (MKATOM STR]) - -(MBUTTON.SET.FIELD - [LAMBDA (TEXTSTREAM FIELD VALUE) (* ; "Edited 22-Apr-93 10:56 by jds") - - (* ;; "Makes the contents of the field with name FIELD be VALUE.") - - (PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM)) - PCTB OBJ SAVED.SEL FIELD.SEL PCNO NEW-STRING) - (SETQ PCTB (fetch (TEXTOBJ PCTB) of TEXTOBJ)) - (SETQ PCNO (MBUTTON.FIND.BUTTON FIELD TEXTSTREAM)) - (COND - (PCNO [SETQ FIELD.SEL (MBUTTON.FIND.NEXT.FIELD TEXTOBJ (fetch (PCTNODE CHNUM) - of (FINDNODE-INDEX - PCTB PCNO] - (* ; - "select the field following this button.") - (COND - (FIELD.SEL (* ; - "there are contents to set for this button") - (\FIXSEL FIELD.SEL TEXTOBJ) - (TEDIT.SETSEL TEXTSTREAM (fetch (SELECTION CH#) of FIELD.SEL) - (fetch (SELECTION DCH) of FIELD.SEL) - (fetch (SELECTION POINT) of FIELD.SEL) - T) - (SETQ NEW-STRING (MKSTRING VALUE)) - (COND - ((ZEROP (NCHARS NEW-STRING)) (* ; - "Nothing to replace, so just delete it.") - (TEDIT.DELETE TEXTSTREAM)) - (T (* ; - "there IS new info, so insert it.") - (TEDIT.INSERT TEXTSTREAM (MKSTRING VALUE]) - -(MBUTTON.SET.NEXT.FIELD - [LAMBDA (TEXTOBJ CH# NEWVALUE DONTUPDATESCREEN) (* ; "Edited 30-May-91 22:15 by jds") - - (* SET the text content of the next fill-in field in this document to be - NEWVALUE) - - (PROG ((SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ))) - (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#) (* Find the next menu fill-in field) - (\FIXSEL SCRATCHSEL TEXTOBJ) - - (* Fix up the SELECTION that describes its contents, so we've got the right - screen coordinates &c) - - (OR (ZEROP (fetch (SELECTION DCH) of SCRATCHSEL)) - (\TEDIT.DELETE SCRATCHSEL TEXTOBJ T)) (* If there is text in that fill-in, - delete it to make room for ours) - (COND - (NEWVALUE (* Only insert something if there IS - something to insert.) - (TEDIT.\INSERT (MKSTRING NEWVALUE) - SCRATCHSEL TEXTOBJ))) (* Then fill it with out new value.) - ]) - -(MBUTTON.SET.NEXT.BUTTON.STATE - [LAMBDA (TEXTOBJ STARTINGCH NEWSTATE) (* jds "31-Jul-85 22:09") - - (* * Find the next menu button in the document, and set its state to NEWSTATE. - Return 1 + the CH# of the button, for further searchers) - - (PROG* ((NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ STARTINGCH)) - (BUTTON (CAR NEXTB))) - (IMAGEOBJPROP BUTTON 'STATE NEWSTATE) - (RETURN (ADD1 (CDR NEXTB]) - -(TEDITMENU.STREAM - [LAMBDA (TEXTSTREAM) (* jds "13-Aug-84 14:10") - - (* returns the textstream of the teditmenu attached to this stream if any) - - (PROG (MENUW (MAINWINDOW (\TEDIT.MAINW TEXTSTREAM))) - [SETQ MENUW (for W in (ATTACHEDWINDOWS MAINWINDOW) - thereis (AND (WINDOWPROP W 'TEDITMENU) - (EQUAL (WINDOWPROP W 'TITLE) - "TEdit Menu"] - (RETURN (COND - (MENUW (TEXTSTREAM MENUW]) - -(\TEDITMENU.SELSCREENER - [LAMBDA (TEXTOBJ SEL SELECTMODE FINAL?) (* ; "Edited 30-May-91 22:15 by jds") - - (* Called to screen potential selections in the TEdit menu window; - if an edit op is in progress, no selection will be permitted.-) - - (PROG ((MAINW (WINDOWPROP (fetch (TEXTOBJ \WINDOW) of TEXTOBJ) - 'MAINWINDOW)) - MAINTEXT) - (SETQ MAINTEXT (WINDOWPROP MAINW 'TEXTOBJ)) - (COND - ((AND (EQ (fetch (SELECTION CH#) of SEL) - (fetch (SELECTION CH#) of TEDIT.SCRATCHSELECTION)) - (EQ (fetch (SELECTION DCH) of SEL) - (fetch (SELECTION DCH) of TEDIT.SCRATCHSELECTION)) - (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT)) - (\COPYSEL SEL TEDIT.SCRATCHSELECTION) - (RETURN 'DON'T)) - ((EQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) - T) - (TEDIT.PROMPTPRINT TEXTOBJ "Edit operation in progress; please wait." T) - (RETURN 'DON'T)) - ((fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) - (TEDIT.PROMPTPRINT TEXTOBJ (CONCAT (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) - " in progress; please wait.") - T) - (\COPYSEL SEL TEDIT.SCRATCHSELECTION) - (RETURN 'DON'T]) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS MBUTTONIMAGEFNS) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(MBUTTON.INIT) - - -(ADDTOVAR IMAGEOBJTYPES (TEditMenuButton FILE TEDITMENU GETFN MB.GETFN)) -) - - - -(* ;; "Three-state (ON-OFF-NEUTRAL) menu buttons, for, e.g., character properties like BOLD") - -(DEFINEQ - -(MB.CREATE.THREESTATEBUTTON - [LAMBDA (TEXT FONT STATECHANGEFN INITSTATE) (* jds "24-Sep-86 00:49") - (PROG ((OBJ (IMAGEOBJCREATE NIL THREESTATEIMAGEFNS)) - (BOX (create IMAGEBOX - XSIZE _ (STRINGWIDTH TEXT FONT) - YSIZE _ (FONTPROP FONT 'HEIGHT) - YDESC _ (FONTPROP FONT 'DESCENT) - XKERN _ 0)) - DS BITMAP X Y) - (SETQ X (fetch XSIZE of BOX)) - (SETQ Y (fetch YSIZE of BOX)) - (IMAGEOBJPROP OBJ 'MBTEXT TEXT) - (IMAGEOBJPROP OBJ 'MBFONT FONT) - (IMAGEOBJPROP OBJ 'MBFN 'MB.THREESTATEBUTTON.FN) - (IMAGEOBJPROP OBJ 'STATECHANGEFN STATECHANGEFN) - (IMAGEOBJPROP OBJ 'STATE (OR INITSTATE 'NEUTRAL)) - (SETQ BITMAP (BITMAPCREATE X Y)) - (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) - (SETQ DS (DSPCREATE BITMAP)) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPFONT FONT DS) - (MOVETO 0 (FONTPROP FONT 'DESCENT) - DS) - (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT) - DS) - (RETURN OBJ]) - -(MB.THREESTATE.DISPLAY - [LAMBDA (OBJ STREAM MODE) (* jds "30-Aug-84 13:53") - (* Display the innards of a menu - button) - (PROG (DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) - (FONT (IMAGEOBJPROP OBJ 'MBFONT)) - (CURX (DSPXPOSITION NIL STREAM)) - (CURY (DSPYPOSITION NIL STREAM)) - BITMAP X Y) - (OR OBJBOX (SETQ OBJBOX (MB.SIZEFN OBJ STREAM))) (* Make sure the size is set.) - (SETQ X (fetch XSIZE of OBJBOX)) - (SETQ Y (fetch YSIZE of OBJBOX)) - (COND - ((SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE)) (* The image bitmap exists already. - Use it.) - ) - (T (* Need to create an image for this - object.) - (SETQ BITMAP (BITMAPCREATE X Y)) - (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) - (SETQ DS (DSPCREATE BITMAP)) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPFONT FONT DS) - (MOVETO 0 (FONTPROP FONT 'DESCENT) - DS) - (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT) - DS))) - (BITBLT BITMAP 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) - X Y 'INPUT 'PAINT) - (SELECTQ (IMAGEOBJPROP OBJ 'STATE) - (ON - - (* The button is ON. Display it as white text on black background) - - (BITBLT NIL 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) - X Y 'TEXTURE 'INVERT BLACKSHADE)) - (OFF - - (* The button is OFF. Mark it with a diagonal line thru it.) - - (DRAWLINE CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) - (SUB1 (IPLUS CURX X)) - (SUB1 (IPLUS (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) - Y)) - 1 - 'PAINT STREAM)) - (NEUTRAL (* The button is neutral. - Just display it regular.)) - NIL]) - -(MB.THREESTATE.SHOWSELFN - [LAMBDA (OBJ SEL ON DS) (* ; "Edited 30-May-91 22:16 by jds") - (PROG [(IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) - (IMAGEBOX OBJ DS] - (COND - (ON (SELECTQ (IMAGEOBJPROP OBJ 'STATE) - (ON (* Switch from ON to NEUTRAL) - (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'TEXTURE - 'INVERT BLACKSHADE)) - (OFF (* Switch from OFF to ON) - (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE) - 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'INPUT - 'REPLACE) - (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'TEXTURE - 'INVERT BLACKSHADE)) - (NEUTRAL (* Switch from NEUTRAL to OFF) - (DRAWLINE 0 0 (SUB1 (fetch XSIZE of IMAGEBOX)) - (SUB1 (fetch YSIZE of IMAGEBOX)) - 1 - 'PAINT DS)) - NIL)) - ((fetch (SELECTION SET) of SEL) - (SELECTQ (IMAGEOBJPROP OBJ 'STATE) - (ON (* Switch from NEUTRAL to ON) - (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'TEXTURE - 'INVERT BLACKSHADE)) - (OFF (* Switch from ON to OFF) - (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'TEXTURE - 'INVERT BLACKSHADE) - (DRAWLINE 0 0 (SUB1 (fetch XSIZE of IMAGEBOX)) - (SUB1 (fetch YSIZE of IMAGEBOX)) - 1 - 'PAINT DS)) - (NEUTRAL (* Switch from OFF to NEUTRAL) - (BITBLT (IMAGEOBJPROP OBJ 'BITCACHE) - 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'INPUT - 'REPLACE)) - NIL]) - -(MB.THREESTATE.WHENOPERATEDFN - [LAMBDA (OBJ DS OPERATION SEL) (* ; "Edited 30-May-91 22:16 by jds") - (* Handle operations on a - three-state button) - (SELECTQ OPERATION - (HIGHLIGHTED (* It is being hilighted) - (MB.THREESTATE.SHOWSELFN OBJ SEL T DS)) - (UNHIGHLIGHTED (* And being de-hilighted) - (MB.THREESTATE.SHOWSELFN OBJ SEL NIL DS)) - (SELECTED (* It's being selected) - (MB.THREESTATEBUTTON.FN OBJ SEL DS) (* Run the state-changing function) - (replace (SELECTION SET) of SEL with NIL) - (* And mar the selection turned off, - so others can use it without - trashing us) - (replace (SELECTION ONFLG) of SEL with NIL) - (replace (SELECTION SET) of TEDIT.SELECTION with NIL)) - (DESELECTED) - NIL]) - -(MB.THREESTATEBUTTON.FN - [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:16 by jds") - (* MBFN for TEdit default menu item - buttons.) - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (STATECHANGEFN (IMAGEOBJPROP OBJ 'STATECHANGEFN)) - OFILE CH NEWSTATE) - (SETQ NEWSTATE (SELECTQ (IMAGEOBJPROP OBJ 'STATE) - (OFF 'ON) - (ON 'NEUTRAL) - (NEUTRAL 'OFF) - 'ON)) - (if STATECHANGEFN - then (* apply the user supplied state - change fn if she supplied one) - (APPLY* STATECHANGEFN OBJ NEWSTATE (TEXTSTREAM TEXTOBJ))) - (IMAGEOBJPROP OBJ 'STATE NEWSTATE) - (replace (SELECTION ONFLG) of SEL with NIL]) - -(THREESTATE.INIT - [LAMBDA NIL (* jds " 9-Feb-86 15:17") - (* Initialize the IMAGEFNS for 3-state - menu button IMAGEOBJs) - (SETQ THREESTATEIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.THREESTATE.DISPLAY) - (FUNCTION MB.SIZEFN) - (FUNCTION MB.PUTFN) - (FUNCTION MB.GETFN) - (FUNCTION MB.COPYFN) - (FUNCTION MB.BUTTONEVENTINFN) - 'NILL - 'NILL - 'NILL - 'NILL - 'NILL - (FUNCTION MB.THREESTATE.WHENOPERATEDFN) - 'NILL - '3StateMenuButton]) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(THREESTATE.INIT) -) - - - -(* ; "One-of-N Menu button sets") - -(DEFINEQ - -(MB.CREATE.NWAYBUTTON - [LAMBDA (BUTTONS FONT CHANGESTATEFN INITSTATE MAXITEMS/LINE) - (* gbn "24-Sep-84 15:31") - (PROG ((OBJECT (IMAGEOBJCREATE NIL NWAYBUTTONIMAGEFNS)) - HEIGHT IMAGES IMAGE DS DESCENT SPACING SIDEEFFECTFNS WIDTHS TWIDTHS) - (SETQ FONT (OR FONT (FONTCREATE 'HELVETICA 10))) - (SETQ HEIGHT (FONTPROP FONT 'HEIGHT)) - (SETQ DESCENT (FONTPROP FONT 'DESCENT)) - (SETQ WIDTHS (for BUTTON in BUTTONS collect (STRINGWIDTH (COND - ((NLISTP BUTTON) - BUTTON) - (T (CAR BUTTON))) - FONT))) - (SETQ IMAGES (for WIDTH in WIDTHS as BUTTON in BUTTONS collect (BITMAPCREATE WIDTH HEIGHT)) - ) - (SETQ SPACING (STRINGWIDTH " " FONT)) - [SETQ SIDEEFFECTFNS (for BUTTON in BUTTONS collect (AND (LISTP BUTTON) - (CADR BUTTON] - (SETQ DS (DSPCREATE)) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPFONT FONT DS) - (DSPRIGHTMARGIN 32000 DS) - (for IMAGE in IMAGES as BUTTON in BUTTONS do (DSPDESTINATION IMAGE DS) - (MOVETO 0 DESCENT DS) - (PRIN1 (COND - ((NLISTP BUTTON) - BUTTON) - (T (CAR BUTTON))) - DS)) - (IMAGEOBJPROP OBJECT 'MINWIDTH (for WIDTH in WIDTHS largest WIDTH)) - (* We always need at least one - button's width) - (IMAGEOBJPROP OBJECT 'MINHEIGHT (IPLUS HEIGHT 2)) (* And at least one button's height) - [IMAGEOBJPROP OBJECT 'MAXWIDTH (COND - [MAXITEMS/LINE (SETQ TWIDTHS (SORT (COPY WIDTHS))) - (IPLUS (CAR TWIDTHS) - (for WIDTH in (CDR TWIDTHS) as I - from 1 to (SUB1 MAXITEMS/LINE) - sum (IPLUS WIDTH SPACING] - (T (IPLUS (CAR WIDTHS) - (for WIDTH in (CDR WIDTHS) - sum (IPLUS WIDTH SPACING] - - (* At most, we're as wide as the N widest buttons put together) - - (IMAGEOBJPROP OBJECT 'MAXHEIGHT (ITIMES (IPLUS HEIGHT 2) - (LENGTH BUTTONS))) - (IMAGEOBJPROP OBJECT 'ITEMSPACE SPACING) - (IMAGEOBJPROP OBJECT 'BUTTONS BUTTONS) - (IMAGEOBJPROP OBJECT 'BUTTONIMAGES IMAGES) - (IMAGEOBJPROP OBJECT 'BUTTONHEIGHT (IPLUS HEIGHT 2)) - (IMAGEOBJPROP OBJECT 'BUTTONWIDTHS WIDTHS) - (IMAGEOBJPROP OBJECT 'NBUTTONS (LENGTH BUTTONS)) - (IMAGEOBJPROP OBJECT 'STATE INITSTATE) - (IMAGEOBJPROP OBJECT 'SELECTEDBUTTON NIL) - (IMAGEOBJPROP OBJECT 'SIDEEFFECTFNS SIDEEFFECTFNS) - (IMAGEOBJPROP OBJECT 'DESCENT DESCENT) - (IMAGEOBJPROP OBJECT 'MBFONT FONT) - (IMAGEOBJPROP OBJECT 'MAXITEMS/LINE MAXITEMS/LINE) - (RETURN OBJECT]) - -(MB.NB.DISPLAYFN - [LAMBDA (OBJ STREAM MODE) (* jds "28-Aug-84 15:07") - (* Display the innards of a menu - button) - (PROG (BITMAP DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) - (X (DSPXPOSITION NIL STREAM)) - (Y (DSPYPOSITION NIL STREAM)) - (BUTTONX (IMAGEOBJPROP OBJ 'BUTTONX)) - (BUTTONY (IMAGEOBJPROP OBJ 'BUTTONY)) - (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONS)) - (BUTTONIMAGES (IMAGEOBJPROP OBJ 'BUTTONIMAGES)) - STATE) - [COND - ((SETQ BITMAP (IMAGEOBJPROP OBJ 'IMAGECACHE)) (* The button image exists already) - ) - (T (* Have to make one.) - (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of OBJBOX) - (fetch YSIZE of OBJBOX))) - (IMAGEOBJPROP OBJ 'IMAGECACHE BITMAP) - (SETQ DS (DSPCREATE BITMAP)) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPFONT (IMAGEOBJPROP OBJ 'MBFONT) - DS) - (for X in BUTTONX as Y in BUTTONY as IMAGE in BUTTONIMAGES - do (* Display the images) - (BITBLT IMAGE 0 0 DS X Y NIL NIL 'INPUT 'REPLACE] - [BITBLT BITMAP 0 0 STREAM X (SETQ Y (IDIFFERENCE Y (fetch YDESC of OBJBOX] - (* Display the button's image) - (COND - ((SETQ STATE (IMAGEOBJPROP OBJ 'STATE)) (* There's a selected button.) - (for BXVAL in BUTTONX as BYVAL in BUTTONY as IMAGE in BUTTONIMAGES as BUTTON - in BUTTONLIST when (EQ STATE BUTTON) do (BITBLT IMAGE 0 0 STREAM (IPLUS X BXVAL) - (IPLUS Y BYVAL) - NIL NIL 'INVERT 'REPLACE]) - -(MB.NB.WHENOPERATEDFN - [LAMBDA (OBJ DS OPERATION SEL) (* ; "Edited 30-May-91 22:16 by jds") - (SELECTQ OPERATION - (HIGHLIGHTED (* (MB.SHOWSELFN OBJ SEL T DS))) - (UNHIGHLIGHTED (* (MB.SHOWSELFN OBJ SEL NIL DS))) - (SELECTED (* There may be a side-effect to - occur upon selection.) - [PROG ((STATE (IMAGEOBJPROP OBJ 'STATE)) - FN) - (for BUTTON in (IMAGEOBJPROP OBJ 'BUTTONS) as SIDEFN - in (IMAGEOBJPROP OBJ 'SIDEEFFECTFNS) when (EQ STATE BUTTON) - do (COND - (SIDEFN (MB.SELFN OBJ SEL DS SIDEFN] - (replace (SELECTION SET) of SEL with NIL)) - (DESELECTED) - NIL]) - -(MB.NB.SIZEFN - [LAMBDA (OBJ STREAM CURX RIGHTMARGIN) (* jds " 6-Sep-84 14:19") - (* Tell the size of an n-way menu) - (PROG ((OLDBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) - BOX - (MAXITEMS/LINE (IMAGEOBJPROP OBJ 'MAXITEMS/LINE)) - (MAXWIDTH (IMAGEOBJPROP OBJ 'MAXWIDTH)) - (MINWIDTH (IMAGEOBJPROP OBJ 'MINWIDTH)) - (MAXHEIGHT (IMAGEOBJPROP OBJ 'MAXHEIGHT)) - (MINHEIGHT (IMAGEOBJPROP OBJ 'MINHEIGHT)) - (LINEHEIGHT (IMAGEOBJPROP OBJ 'LINEHEIGHT)) - (BUTTONHEIGHT (IMAGEOBJPROP OBJ 'BUTTONHEIGHT)) - (BUTTONWIDTHS (IMAGEOBJPROP OBJ 'BUTTONWIDTHS)) - (SPACING (IMAGEOBJPROP OBJ 'ITEMSPACE)) - (SLACK (IDIFFERENCE RIGHTMARGIN CURX)) - BUTTONX BUTTONY BUTTONINFO WIDTH HEIGHT) - [COND - ((AND (IGEQ SLACK MAXWIDTH) - (NOT MAXITEMS/LINE)) - - (* There's space for all the items on one line. - Use it) - - (SETQ WIDTH MAXWIDTH) - (SETQ HEIGHT MINHEIGHT) - [SETQ BUTTONX (bind (CURX _ 0) for ITEM in BUTTONWIDTHS - collect (PROG1 CURX (add CURX SPACING) - (add CURX ITEM] - (SETQ BUTTONY (for ITEM in BUTTONWIDTHS collect 0))) - [(ILEQ SLACK MINWIDTH) (* Have to stack it vertically.) - (SETQ WIDTH MINWIDTH) - (SETQ HEIGHT MAXHEIGHT) - (SETQ BUTTONX (for ITEM in BUTTONWIDTHS collect 0)) - (SETQ BUTTONY (bind (CURY _ (ITIMES BUTTONHEIGHT (LENGTH BUTTONWIDTHS))) for ITEM - in BUTTONWIDTHS collect (add CURY (IMINUS BUTTONHEIGHT] - (T (SETQ BUTTONINFO (MB.NB.PACKITEMS SLACK BUTTONWIDTHS SPACING MAXITEMS/LINE)) - [SETQ BUTTONX (for LINE in BUTTONINFO join (COPY (CDR LINE] - [SETQ BUTTONY (bind (CURY _ (ITIMES BUTTONHEIGHT (LENGTH BUTTONINFO))) for LINE - in BUTTONINFO join (PROGN (SETQ CURY (IDIFFERENCE CURY BUTTONHEIGHT) - ) - (for X in (CDR LINE) collect CURY] - [SETQ WIDTH (CAR (for LINE in BUTTONINFO largest (CAR LINE] - (SETQ HEIGHT (ITIMES BUTTONHEIGHT (LENGTH BUTTONINFO] - (COND - ((AND OLDBOX (IEQP WIDTH (fetch XSIZE of OLDBOX)) - (IEQP HEIGHT (fetch YSIZE of OLDBOX))) (* If nothing changed, don't bother - reformatting.) - (RETURN OLDBOX)) - (T (* Otherwise invalidate the image - cache) - (IMAGEOBJPROP OBJ 'IMAGECACHE NIL))) - (SETQ BOX (create IMAGEBOX - XSIZE _ WIDTH - YSIZE _ HEIGHT - YDESC _ (IMAGEOBJPROP OBJ 'DESCENT) - XKERN _ 0)) - (IMAGEOBJPROP OBJ 'BOUNDBOX BOX) - (IMAGEOBJPROP OBJ 'BUTTONX BUTTONX) - (IMAGEOBJPROP OBJ 'BUTTONY BUTTONY) - (RETURN BOX]) - -(MB.NWAYBUTTON.SELFN - [LAMBDA (OBJ W SEL MOUSEX MOUSEY) (* ; "Edited 30-May-91 22:16 by jds") - (* Selecting an NWAY button.) - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) - (OLDSTATE (IMAGEOBJPROP OBJ 'STATE)) - (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONS)) - (BUTTONX (IMAGEOBJPROP OBJ 'BUTTONX)) - (BUTTONIMAGES (IMAGEOBJPROP OBJ 'BUTTONIMAGES)) - (BUTTONY (IMAGEOBJPROP OBJ 'BUTTONY)) - (BUTTONWIDTHS (IMAGEOBJPROP OBJ 'BUTTONWIDTHS)) - (BUTTONLIST (IMAGEOBJPROP OBJ 'BUTTONLIST)) - (BUTTONHEIGHT (IMAGEOBJPROP OBJ 'BUTTONHEIGHT)) - CH STATE) - [for BUTTON in BUTTONLIST as X in BUTTONX as Y in BUTTONY - as WIDTH in BUTTONWIDTHS as IMAGE in BUTTONIMAGES - do (COND - ((INSIDE? (create REGION - LEFT _ X - BOTTOM _ Y - WIDTH _ WIDTH - HEIGHT _ BUTTONHEIGHT) - MOUSEX MOUSEY) (* The mouse is pointing here. - Select this.) - (SETQ STATE BUTTON) - (BITBLT IMAGE 0 0 W X Y NIL NIL 'INVERT 'REPLACE)) - ((EQ OLDSTATE BUTTON) (* This was the old selection - (and it's different, too)%. - Unselect it) - (BITBLT IMAGE 0 0 W X Y NIL NIL 'INPUT 'REPLACE] - (IMAGEOBJPROP OBJ 'STATE STATE) - (RETURN T]) - -(MB.NWAYMENU.NEWBUTTON - [LAMBDA (TEXTOBJ CH# OLDBUTTON NEWBUTTON) (* jds " 8-Feb-84 19:41") - - (* Given a hook on an existing button, and an insertion point, insert a new - button) - - (PROG ((ARBITRATOR (IMAGEOBJPROP OLDBUTTON 'ARBITRATOR)) - BUTTON) - (IMAGEOBJPROP BUTTON 'ARBITRATOR ARBITRATOR) - (TEDIT.INSERT.OBJECT BUTTON TEXTOBJ CH#) - (TEDIT.INSERT TEXTOBJ " " (ADD1 CH#)) - (TEDIT.LOOKS TEXTOBJ '(PROTECTED ON) (ADD1 CH#) - 2) - (RETURN BUTTON]) - -(NWAYBUTTON.INIT - [LAMBDA (BUTTONS FONT INITSTATE) (* jds " 9-Feb-86 15:17") - (SETQ NWAYBUTTONIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.NB.DISPLAYFN) - (FUNCTION MB.NB.SIZEFN) - (FUNCTION MB.PUTFN) - (FUNCTION MB.GETFN) - (FUNCTION MB.COPYFN) - (FUNCTION MB.NWAYBUTTON.SELFN) - 'NILL - 'NILL - 'NILL - 'NILL - 'NILL - (FUNCTION MB.NB.WHENOPERATEDFN) - 'NILL - 'NWayButton]) - -(MB.NB.PACKITEMS - [LAMBDA (WIDTH ITEMWIDTHS SPACING MAXITEMS/LINE) (* jds "24-Oct-84 17:42") - - (* * Pack items into lines WIDTH wide. Item widths are in ITEMWIDTHS, and each - pair of items on a line is separated by SPACING. - Returns a list of lists, one per line packed, of the relative X starts of the - items) - - (PROG ((CURX 0) - (LINES NIL) - (CURLINE NIL) - (CURLINEITEMS 0) - ITEM) - (while ITEMWIDTHS do (SETQ ITEM (pop ITEMWIDTHS)) - (COND - ((OR [ILESSP WIDTH (IPLUS CURX ITEM (COND - (CURLINE SPACING) - (T 0] - (AND MAXITEMS/LINE (IGEQ CURLINEITEMS MAXITEMS/LINE))) - (* Time for a new line) - (SETQ LINES (NCONC1 LINES (CONS CURX CURLINE))) - (* Add to our list of lines so far) - (SETQ CURLINE NIL) (* Empty the line accumulator) - (SETQ CURLINEITEMS 0) (* reset the line item count) - (SETQ CURX 0))) - (AND CURLINE (add CURX SPACING)) - (SETQ CURLINE (NCONC1 CURLINE CURX)) - (add CURX ITEM) - (add CURLINEITEMS 1)) - [AND CURLINE (SETQ LINES (NCONC1 LINES (CONS CURX CURLINE] - (* Capture the last partial line, if - there is one.) - (RETURN LINES]) - -(MB.NWAYBUTTON.ADDITEM - [LAMBDA (OBJECT NEWBUTTON) (* jds "11-Jul-85 12:44") - - (* Given an existing n-way choice menu button, add another choice to the list) - - (PROG ([BUTTONS (CONS NEWBUTTON (IMAGEOBJPROP OBJECT 'BUTTONS] - HEIGHT IMAGES IMAGE DS DESCENT SPACING SIDEEFFECTFNS WIDTHS FONT) - (SETQ FONT (IMAGEOBJPROP OBJECT 'MBFONT)) - (SETQ HEIGHT (FONTPROP FONT 'HEIGHT)) - (SETQ DESCENT (FONTPROP FONT 'DESCENT)) - (SETQ WIDTHS (for BUTTON in BUTTONS collect (STRINGWIDTH (COND - ((NLISTP BUTTON) - BUTTON) - (T (CAR BUTTON))) - FONT))) - (SETQ IMAGES (for WIDTH in WIDTHS as BUTTON in BUTTONS collect (BITMAPCREATE WIDTH HEIGHT)) - ) - (SETQ SPACING (STRINGWIDTH " " FONT)) - [SETQ SIDEEFFECTFNS (for BUTTON in BUTTONS collect (AND (LISTP BUTTON) - (CADR BUTTON] - (SETQ DS (DSPCREATE)) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPFONT FONT DS) - (DSPRIGHTMARGIN 32000 DS) - (for IMAGE in IMAGES as BUTTON in BUTTONS do (DSPDESTINATION IMAGE DS) - (MOVETO 0 DESCENT DS) - (PRIN1 (COND - ((NLISTP BUTTON) - BUTTON) - (T (CAR BUTTON))) - DS)) - (IMAGEOBJPROP OBJECT 'MINWIDTH (for WIDTH in WIDTHS largest WIDTH)) - (IMAGEOBJPROP OBJECT 'MINHEIGHT (IPLUS HEIGHT 2)) - [IMAGEOBJPROP OBJECT 'MAXWIDTH (IPLUS (CAR WIDTHS) - (for WIDTH in (CDR WIDTHS) - sum (IPLUS WIDTH SPACING] - (IMAGEOBJPROP OBJECT 'MAXHEIGHT (ITIMES (IPLUS HEIGHT 2) - (LENGTH BUTTONS))) - (IMAGEOBJPROP OBJECT 'ITEMSPACE SPACING) - (IMAGEOBJPROP OBJECT 'BUTTONS BUTTONS) - (IMAGEOBJPROP OBJECT 'BUTTONIMAGES IMAGES) - (IMAGEOBJPROP OBJECT 'BUTTONHEIGHT (IPLUS HEIGHT 2)) - (IMAGEOBJPROP OBJECT 'BUTTONWIDTHS WIDTHS) - (IMAGEOBJPROP OBJECT 'NBUTTONS (LENGTH BUTTONS)) - (IMAGEOBJPROP OBJECT 'SELECTEDBUTTON NIL) - (IMAGEOBJPROP OBJECT 'SIDEEFFECTFNS SIDEEFFECTFNS) - (IMAGEOBJPROP OBJECT 'DESCENT DESCENT) - (RETURN OBJECT]) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS NWAYBUTTONIMAGEFNS) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(NWAYBUTTON.INIT) - - -(ADDTOVAR IMAGEOBJTYPES (NWayButton FILE TEDITMENU GETFN MB.GETFN)) -) - - - -(* ;; "Two-state, toggling menu buttons.") - -(DEFINEQ - -(\TEXTMENU.TOGGLE.CREATE - [LAMBDA (TEXT FONT STATECHANGEFN INITSTATE) (* gbn "24-Sep-84 14:45") - - (* Creates a TOGGLE menu button, that can turn off and on alternately.) - - (PROG ((OBJ (IMAGEOBJCREATE NIL \TOGGLEIMAGEFNS)) - (BOX (create IMAGEBOX - XSIZE _ (STRINGWIDTH TEXT FONT) - YSIZE _ (FONTPROP FONT 'HEIGHT) - YDESC _ (FONTPROP FONT 'DESCENT) - XKERN _ 0)) - DS BITMAP X Y) - (SETQ X (fetch XSIZE of BOX)) - (SETQ Y (fetch YSIZE of BOX)) - (IMAGEOBJPROP OBJ 'MBTEXT TEXT) - (IMAGEOBJPROP OBJ 'MBFONT FONT) - (IMAGEOBJPROP OBJ 'MBFN '\TEXTMENU.TOGGLEFN) - (IMAGEOBJPROP OBJ 'STATECHANGEFN STATECHANGEFN) - - (* a function to be called on finalization of selection of this button to - provide for user side-effects) - - (IMAGEOBJPROP OBJ 'STATE (OR INITSTATE 'OFF)) - (SETQ BITMAP (BITMAPCREATE X Y)) - (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) - (SETQ DS (DSPCREATE BITMAP)) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPFONT FONT DS) - (MOVETO 0 (FONTPROP FONT 'DESCENT) - DS) - (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT) - DS) - (RETURN OBJ]) - -(\TEXTMENU.TOGGLE.DISPLAY - [LAMBDA (OBJ STREAM MODE) (* gbn "27-Sep-84 01:23") - (* "27-Sep-84 01:11" gbn) - (* Display the innards of a menu - toggle) - (PROG (DS (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) - (FONT (IMAGEOBJPROP OBJ 'MBFONT)) - (CURX (DSPXPOSITION NIL STREAM)) - (CURY (DSPYPOSITION NIL STREAM)) - BITMAP X Y) - (OR OBJBOX (SETQ OBJBOX (MB.SIZEFN OBJ STREAM))) (* Make sure the size is set.) - (SETQ X (fetch XSIZE of OBJBOX)) - (SETQ Y (fetch YSIZE of OBJBOX)) - (COND - ([type? BITMAP (SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE] - (* The image bitmap exists already. - Use it.) - ) - (T (* Need to create an image for this - object.) - (SETQ BITMAP (BITMAPCREATE X Y)) - (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) - (SETQ DS (DSPCREATE BITMAP)) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPFONT FONT DS) - (MOVETO 0 (FONTPROP FONT 'DESCENT) - DS) - (PRIN1 (IMAGEOBJPROP OBJ 'MBTEXT) - DS))) - (BITBLT BITMAP 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) - X Y 'INPUT 'PAINT) - (SELECTQ (IMAGEOBJPROP OBJ 'STATE) - (ON - - (* The button is ON. Display it as white text on black background) - - (BITBLT NIL 0 0 STREAM CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) - X Y 'TEXTURE 'INVERT BLACKSHADE)) - (OFF (* The button is OFF. - Just display it regular.)) - (ERROR "Invalid state in toggle button " OBJ]) - -(\TEXTMENU.TOGGLE.SHOWSELFN - [LAMBDA (OBJ SEL ON DS) (* ; "Edited 30-May-91 22:16 by jds") - (PROG [(IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) - (IMAGEBOX OBJ DS] - (COND - (ON (SELECTQ (IMAGEOBJPROP OBJ 'STATE) - (ON (* Switch from ON to - (NEUTRAL (* Switch from OFF to - NEUTRAL) (BITBLT (IMAGEOBJPROP OBJ - (QUOTE BITCACHE)) 0 0 DS 0 0 - (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - (QUOTE INPUT) (QUOTE REPLACE)))) - (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'TEXTURE - 'INVERT BLACKSHADE)) - (OFF (* Switch from OFF to ON) - (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'TEXTURE - 'INVERT BLACKSHADE)) - NIL)) - ((fetch (SELECTION SET) of SEL) - (SELECTQ (IMAGEOBJPROP OBJ 'STATE) - (ON (* Switch from OFF to ON) - (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'TEXTURE - 'INVERT BLACKSHADE)) - (OFF (* Switch from ON to OFF) - (BITBLT NIL 0 0 DS 0 0 (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX) - 'TEXTURE - 'INVERT BLACKSHADE)) - NIL]) - -(\TEXTMENU.TOGGLE.WHENOPERATEDFN - [LAMBDA (OBJ DS OPERATION SEL) (* ; "Edited 30-May-91 22:16 by jds") - (* Handle operations on a - three-state button) - (SELECTQ OPERATION - (HIGHLIGHTED (* It is being hilighted) - (\TEXTMENU.TOGGLE.SHOWSELFN OBJ SEL T DS)) - (UNHIGHLIGHTED (* And being de-hilighted) - (\TEXTMENU.TOGGLE.SHOWSELFN OBJ SEL NIL DS)) - (SELECTED (* It's being selected) - (\TEXTMENU.TOGGLEFN OBJ SEL DS) (* Run the state-changing function) - (replace (SELECTION SET) of SEL with NIL) - (* And mar the selection turned off, - so others can use it without - trashing us) - (replace (SELECTION ONFLG) of SEL with NIL) - (replace (SELECTION SET) of TEDIT.SELECTION with NIL)) - (DESELECTED) - NIL]) - -(\TEXTMENU.TOGGLEFN - [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:16 by jds") - (* MBFN for TOGGLE buttons--cycle - back and forthe betwen states.) - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (STATECHANGEFN (IMAGEOBJPROP OBJ 'STATECHANGEFN)) - OFILE CH NEWSTATE) - (SETQ NEWSTATE (SELECTQ (IMAGEOBJPROP OBJ 'STATE) - (OFF 'ON) - (ON 'OFF) - 'ON)) - (COND - (STATECHANGEFN (* apply the user supplied state - change fn if he supplied one) - (APPLY* STATECHANGEFN OBJ NEWSTATE (TEXTSTREAM TEXTOBJ) - SEL))) - (IMAGEOBJPROP OBJ 'STATE NEWSTATE) - (replace (SELECTION ONFLG) of SEL with NIL]) - -(\TEXTMENU.TOGGLE.INIT - [LAMBDA NIL (* jds " 9-Feb-86 15:18") - (SETQ \TOGGLEIMAGEFNS (IMAGEFNSCREATE (FUNCTION \TEXTMENU.TOGGLE.DISPLAY) - (FUNCTION MB.SIZEFN) - (FUNCTION MB.PUTFN) - (FUNCTION MB.GETFN) - (FUNCTION MB.COPYFN) - (FUNCTION MB.BUTTONEVENTINFN) - 'NILL - 'NILL - 'NILL - 'NILL - 'NILL - (FUNCTION \TEXTMENU.TOGGLE.WHENOPERATEDFN) - 'NILL - 'ToggleButton]) - -(\TEXTMENU.SET.TOGGLE - [LAMBDA (TEXT VALUE TEXTSTREAM) (* ; "Edited 12-Jun-90 19:02 by mitani") - - (* * finds the button with MBTEXT field TEXT in TEXTSTREAM and sets its state - to VALUE) - - (PROG ((PCNO (MBUTTON.FIND.BUTTON TEXT TEXTSTREAM)) - OBJ PC) - (COND - ((NOT PCNO) - (ERROR TEXT " was not found as a button."))) - [SETQ OBJ (fetch (PIECE POBJ) of (SETQ PC (fetch (PCTNODE PCE) - of (FINDNODE-INDEX - (fetch (TEXTOBJ PCTB) - of (TEXTOBJ TEXTSTREAM) - ) - PCNO] - (IMAGEOBJPROP OBJ 'STATE VALUE) - (IMAGEOBJPROP OBJ 'BITCACHE 'JUNK) - (for WINDOW inside (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ TEXTSTREAM)) - do (\TEDIT.REPAINTFN WINDOW)) - (RETURN VALUE]) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \TOGGLEIMAGEFNS) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(\TEXTMENU.TOGGLE.INIT) - - -(ADDTOVAR IMAGEOBJTYPES (ToggleButton FILE TEDITMENU GETFN MB.GETFN)) -) - - - -(* ;; "Margin Setting and display") - -(DEFINEQ - -(DRAWMARGINSCALE - [LAMBDA (W UNIT) (* ; "Edited 12-Jun-90 18:59 by mitani") - - (* ;; " Draw the margin-bar scale -- the markings across the bottom of the margin bar that show you the margin values. Draws the scale in window W, according to UNIT = 1 for points, or 12 for picas.") - - (PROG ((WREG (DSPCLIPPINGREGION NIL W)) - (OLDOP (DSPOPERATION 'REPLACE W))) - (DSPFILL (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch (REGION WIDTH) of WREG) - HEIGHT _ 24) - WHITESHADE - 'REPLACE W) (* ; "CLEAR IT OUT FIRST.") - (SELECTQ UNIT - (1 (* ; "Straight Points") - [for X from 4 by 3 to (fetch (REGION WIDTH) of WREG) - do - - (* ;; "Put a tick every 3 points, with a number every inch.") - - (COND - ((ZEROP (IREMAINDER (IDIFFERENCE X 4) - 72)) - (BITBLT NIL 0 0 W X 8 1 16 'TEXTURE 'REPLACE BLACKSHADE) - (MOVETO (IDIFFERENCE X (LRSH (STRINGWIDTH (IDIFFERENCE X 4)) - 1)) - 10 W) - (PRIN1 (IDIFFERENCE X 4) - W)) - (T (BITBLT NIL 0 0 W X 20 1 4 'TEXTURE 'REPLACE BLACKSHADE]) - (12 (* ; "Picas") - (for X from 4 by 12 to (fetch (REGION WIDTH) of WREG) - as NOMX from 0 - do - - (* ;; "Put a tick every half-pica, with a number every inch.") - - (COND - ((ZEROP (IREMAINDER NOMX 6)) - (BITBLT NIL 0 0 W X 8 1 16 'TEXTURE 'REPLACE BLACKSHADE) - (MOVETO (IDIFFERENCE X (LRSH (STRINGWIDTH NOMX) - 1)) - 10 W) - (PRIN1 NOMX W)) - (T (BITBLT NIL 0 0 W X 20 1 4 'TEXTURE 'REPLACE BLACKSHADE))) - (BITBLT NIL 0 0 W (IPLUS X 6) - 22 1 2 'TEXTURE 'REPLACE BLACKSHADE))) - NIL) - (BITBLT NIL 0 0 W 4 23 (fetch (REGION WIDTH) of WREG) - 1 - 'TEXTURE - 'REPLACE BLACKSHADE) - (MOVETO 0 0 W) - (RELDRAWTO (IDIFFERENCE (fetch (REGION WIDTH) of WREG) - 2) - 0 1 'PAINT W) - (RELDRAWTO 0 (IDIFFERENCE (fetch (REGION HEIGHT) of WREG) - 2) - 1 - 'PAINT W) - (RELDRAWTO (IMINUS (IDIFFERENCE (fetch (REGION WIDTH) of WREG) - 2)) - 0 1 'PAINT W) - (RELDRAWTO 0 (IMINUS (IDIFFERENCE (fetch (REGION HEIGHT) of WREG) - 2)) - 1 - 'PAINT W) - (DSPOPERATION OLDOP W]) - -(MARGINBAR - [LAMBDA (W L1 LN R TABS UNIT UPDATE RIGHTLIM) (* ; "Edited 12-Jun-90 18:59 by mitani") - (* Given a set of margins and a - unit, show the margin bar properly) - (PROG ((OLDOP (DSPOPERATION 'ERASE W)) - (SCALEDL1 (MSCALE L1 UNIT)) - (SCALEDLN (MSCALE LN UNIT)) - (SCALEDR (MSCALE R UNIT)) - (FLOATINGRIGHT NIL) - (EXTENDEDRIGHT NIL) - UNSETL1 UNSETLN) - (OR UPDATE (DRAWMARGINSCALE W UNIT)) - (DSPFONT (FONTCREATE 'GACHA 10) - W) - (SETQ L1 (MKSTRING (ABS L1))) - (SETQ LN (MKSTRING (ABS LN))) - (SETQ R (MKSTRING (ABS R))) - [COND - [(ILESSP SCALEDR 4) (* Unset right margin. - Show specially, but at its usual - place.) - (SETQ FLOATINGRIGHT T) - (SETQ SCALEDR (IPLUS 4 (IDIFFERENCE 4 SCALEDR] - ((ILEQ SCALEDR 4) (* Floating right margin => marked - specially) - (SETQ FLOATINGRIGHT T) - (SETQ SCALEDR RIGHTLIM)) - ((IGREATERP SCALEDR RIGHTLIM) (* Not floating, so just limit it to - the rightmost that can be seen.) - (SETQ EXTENDEDRIGHT T) - (SETQ SCALEDR (IDIFFERENCE RIGHTLIM 8] - [COND - ((ILESSP SCALEDL1 4) (* Unset right FIRST LEFT margin. - Show specially, but at its usual - place.) - (SETQ UNSETL1 T) - (SETQ SCALEDL1 (IPLUS 4 (IDIFFERENCE 4 SCALEDL1] - [COND - ((ILESSP SCALEDLN 4) (* Unset LEFT margin. - Show specially, but at its usual - place.) - (SETQ UNSETLN T) - (SETQ SCALEDLN (IPLUS 4 (IDIFFERENCE 4 SCALEDLN] - (BITBLT NIL 0 0 W 1 26 (IDIFFERENCE (fetch (REGION WIDTH) of (DSPCLIPPINGREGION - NIL W)) - 3) - 32 - 'TEXTURE - 'REPLACE WHITESHADE) - (BITBLT NIL 0 0 W SCALEDL1 42 (IDIFFERENCE SCALEDR SCALEDL1) - 16 - 'TEXTURE - 'REPLACE BLACKSHADE) - (BITBLT NIL 0 0 W SCALEDLN 26 (IDIFFERENCE SCALEDR SCALEDLN) - 16 - 'TEXTURE - 'REPLACE BLACKSHADE) - (COND - (UNSETL1 (* 1st left margin isn't set, tho it - has a value. Mark it neutral) - (BITBLT NIL 0 0 W SCALEDL1 42 (IPLUS (STRINGWIDTH L1 W) - 2) - 16 - 'TEXTURE - 'REPLACE EDITGRAY) - (DSPOPERATION 'PAINT W) - (MOVETO (IPLUS SCALEDL1 2) - 44 W) - (PRIN1 L1 W) - (DSPOPERATION 'ERASE W)) - (T (MOVETO (IPLUS SCALEDL1 2) - 44 W) - (PRIN1 L1 W))) - (COND - (UNSETLN (* left margin isn't set, tho it has - a value. Mark it neutral) - (BITBLT NIL 0 0 W SCALEDLN 26 (IPLUS (STRINGWIDTH LN W) - 2) - 16 - 'TEXTURE - 'REPLACE EDITGRAY) - (DSPOPERATION 'PAINT W) - (MOVETO (IPLUS SCALEDLN 2) - 28 W) - (PRIN1 LN W) - (DSPOPERATION 'ERASE W)) - (T (MOVETO (IPLUS SCALEDLN 2) - 28 W) - (PRIN1 LN W))) - [COND - (FLOATINGRIGHT (* Floating right margin is marked - by a light gray marker) - (BITBLT NIL 0 0 W (IDIFFERENCE SCALEDR (IPLUS (STRINGWIDTH R W) - 2)) - 26 - (IPLUS (STRINGWIDTH R W) - 2) - 32 - 'TEXTURE - 'REPLACE EDITGRAY) - (DSPOPERATION 'PAINT W)) - (EXTENDEDRIGHT (* A non-visible right margin is - marked by two wavy lines indicating - a break) - (BITBLT TEDIT.EXTENDEDRIGHTMARK 0 0 W SCALEDR 26 8 32 'INPUT 'REPLACE] - (MOVETO (IDIFFERENCE SCALEDR (IPLUS (STRINGWIDTH R W) - 2)) - 36 W) - (PRIN1 R W) - (DSPOPERATION OLDOP W) - (COND - ((EQ TABS 'NEUTRAL) (* All tabs have been neutralized. - Just lay down a grey pattern over - them.) - (DSPFILL (create REGION - LEFT _ 2 - BOTTOM _ 1 - HEIGHT _ 8 - WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of ( - DSPCLIPPINGREGION - NIL W)) - 4)) - EDITGRAY - 'REPLACE W)) - (T (DSPFILL (create REGION - LEFT _ 2 - BOTTOM _ 1 - HEIGHT _ 8 - WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) - of (DSPCLIPPINGREGION NIL W)) - 4)) - WHITESHADE - 'REPLACE W) - (for TAB in TABS do (* Run thru the tabs, putting them - down in place.) - (MB.MARGINBAR.SHOWTAB W TAB UNIT 'PAINT]) - -(MARGINBAR.CREATE - [LAMBDA (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE) (* ; "Edited 12-Jun-90 18:59 by mitani") - (* Create an instance of the - margin-setting ruler for TEdit's - use.) - (PROG ((BOX (create IMAGEBOX - XSIZE _ 1008 - YSIZE _ 62 - YDESC _ 0 - XKERN _ 4)) - OBJ OBJDATUM BITMAP DS) - (SETQ OBJ - (IMAGEOBJCREATE (SETQ OBJDATUM - (create MARGINBAR - MARL1 _ MARL1 - MARLN _ MARLN - MARR _ MARR - MARTABS _ MARTABS - MARUNIT _ MARUNIT - MARTABTYPE _ MARTABTYPE)) - MARGINBARIMAGEFNS)) - - (* Create an IMAGEOBJ, containing an instance of the record to hold margin and - tab info) - - (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of BOX) - (fetch YSIZE of BOX))) (* A cache for the ruler's screen - image) - (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) - (SETQ DS (DSPCREATE BITMAP)) (* And a displaystream for modifying - that image) - (IMAGEOBJPROP OBJ 'DSPCACHE DS) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPCLIPPINGREGION (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch XSIZE of BOX) - HEIGHT _ (fetch YSIZE of BOX)) - DS) - (MARGINBAR DS (fetch (MARGINBAR MARL1) of OBJDATUM) - (fetch (MARGINBAR MARLN) of OBJDATUM) - (fetch (MARGINBAR MARR) of OBJDATUM) - (fetch (MARGINBAR MARTABS) of OBJDATUM) - (fetch (MARGINBAR MARUNIT) of OBJDATUM) - NIL - (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL DS))) - - (* Fill in the cache with the original value This does the time-consuming part - of drawing the ticks on the ruler and such, which would make drawing it on the - fly unbearable.) - - (IMAGEOBJPROP OBJ 'NEEDSUPDATE T) - - (* And tell the display function that it needs to be updated when first - displayed. Which is the faster part.) - - (RETURN OBJ]) - -(MB.MARGINBAR.SELFN - [LAMBDA (OBJ SELWINDOW SEL RELX RELY STREAM ORIGX ORIGY) - (* ; "Edited 12-Jun-90 18:59 by mitani") - (* ; - "Let the user adjust margins and tabs using the mouse.") - (PROG [(OBJDATUM (IMAGEOBJPROP OBJ 'OBJECTDATUM)) - (IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) - (IMAGEBOX OBJ STREAM 'DISPLAY] - (PROG ((L1 (fetch MARL1 of OBJDATUM)) - (LN (fetch MARLN of OBJDATUM)) - (R (fetch MARR of OBJDATUM)) - (TABS (fetch MARTABS of OBJDATUM)) - [SCALEDTABS (COND - ((LISTP (fetch MARTABS of OBJDATUM)) - (* ; - "Only scale the tabs if there are any, and they're not neutralized.") - (for TAB in (fetch MARTABS of OBJDATUM) - collect (MSCALE (fetch TABX of TAB) - (fetch MARUNIT of OBJDATUM] - (UNIT (fetch MARUNIT of OBJDATUM)) - (CLIP (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch XSIZE of IMAGEBOX) - HEIGHT _ (fetch YSIZE of IMAGEBOX))) - (RIGHTLIM (IDIFFERENCE (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL - SELWINDOW)) - 4)) - TAB TABX OL1 OLN OR) - (SETQ OL1 L1) - (SETQ OLN LN) - (SETQ OR R) - [COND - [(INSIDE? (create REGION - LEFT _ (IDIFFERENCE (MSCALE (ABS L1) - UNIT) - 2) - BOTTOM _ 42 - WIDTH _ 16 - HEIGHT _ 16) - RELX RELY) (* ; "Move the 1st-line left margin.") - (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) - (INSIDE? CLIP (LASTMOUSEX STREAM) - (LASTMOUSEY STREAM))) - do (SETQ L1 (MAX 0 (MDESCALE (LASTMOUSEX STREAM) - UNIT))) - [COND - ((\TEDIT.MOUSESTATE RIGHT) (* ; - "Right mouse button UNsets the margin.") - (SETQ L1 (MINUS L1] - (COND - ((NOT (EQUAL OL1 L1)) - (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM) - (SETQ OL1 L1] - [(INSIDE? (create REGION - LEFT _ (IDIFFERENCE (MSCALE (ABS LN) - UNIT) - 2) - BOTTOM _ 26 - WIDTH _ 16 - HEIGHT _ 16) - RELX RELY) (* ; "Move the skirt's left margin") - (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) - (INSIDE? CLIP (LASTMOUSEX STREAM) - (LASTMOUSEY STREAM))) - do (SETQ LN (MAX 0 (MDESCALE (LASTMOUSEX STREAM) - UNIT))) - [COND - ((\TEDIT.MOUSESTATE RIGHT) (* ; - "Right mouse button UNsets the margin.") - (SETQ LN (MINUS LN] - (COND - ((NOT (EQUAL OLN LN)) - (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM) - (SETQ OLN LN] - [(OR (INSIDE? (create REGION - LEFT _ (IDIFFERENCE (IMIN (MSCALE (ABS R) - UNIT) - (fetch XSIZE of IMAGEBOX) - (fetch (REGION WIDTH) - of (DSPCLIPPINGREGION NIL - SELWINDOW))) - 16) - BOTTOM _ 26 - WIDTH _ 16 - HEIGHT _ 32) - RELX RELY) - (AND (ZEROP (IABS (FIXR R))) - (INSIDE? (create REGION - LEFT _ (IDIFFERENCE (IMIN (fetch XSIZE of - IMAGEBOX - ) - (fetch (REGION WIDTH) - of (DSPCLIPPINGREGION - NIL SELWINDOW))) - 16) - BOTTOM _ 26 - WIDTH _ 16 - HEIGHT _ 32) - RELX RELY))) (* ; "Move the right margin") - (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) - (INSIDE? CLIP (LASTMOUSEX STREAM) - (LASTMOUSEY STREAM))) - do (SETQ R (MAX 0 (MDESCALE (LASTMOUSEX STREAM) - UNIT))) - [COND - ((\TEDIT.MOUSESTATE RIGHT) (* ; - "Right mouse button UNsets the margin.") - (SETQ R (MINUS R] - (COND - ((NOT (EQUAL OR R)) - (MARGINBAR STREAM L1 LN R TABS UNIT T RIGHTLIM) - (SETQ OR R] - ((INSIDE? (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch (REGION WIDTH) of CLIP) - HEIGHT _ 16) - RELX RELY) (* ; "We're in the tab ruler region") - (COND - ((MOUSESTATE LEFT) (* ; "MOVE a tab") - [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS - smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM] - (AND TAB (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB))) - [(MOUSESTATE MIDDLE) (* ; "ADD/CHANGE a tab") - (COND - ((EQ (fetch MARTABS of OBJDATUM) - 'NEUTRAL) (* ; - "The tabs used to be NEUTRAL. Clear the tab region, and start afresh.") - (replace MARTABS of OBJDATUM with NIL) - (* ; - "So we don't come this way again.") - (DSPFILL (create REGION - LEFT _ 2 - BOTTOM _ 1 - HEIGHT _ 8 - WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) - of (DSPCLIPPINGREGION NIL - SELWINDOW)) - 4)) - WHITESHADE - 'REPLACE SELWINDOW) (* ; - "Make the tab region look non-neutral, too, so that tabs look OK on it.") - )) - (COND - ((AND [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS - smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM] - (SETQ TABX (MSCALE (CAR TAB) - UNIT)) - (IGEQ (LASTMOUSEX STREAM) - (IDIFFERENCE TABX 2)) - (ILEQ (LASTMOUSEX STREAM) - (IPLUS TABX 2))) - (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'ERASE) - (replace TABKIND of TAB with (OR (fetch MARTABTYPE - of OBJDATUM) - 'LEFT)) - (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'PAINT) - (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB)) - ([OR (NOT TAB) - (NOT (EQP (fetch TABX of TAB) - (MDESCALE (LASTMOUSEX STREAM) - UNIT] (* ; "Really create a new tab") - [SETQ TAB (create TAB - TABX _ (MDESCALE (LASTMOUSEX STREAM) - UNIT) - TABKIND _ (OR (fetch MARTABTYPE of OBJDATUM) - 'LEFT] - (SETQ TABS (CONS TAB TABS)) - (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'PAINT) - (MB.MARGINBAR.TABTRACK STREAM OBJDATUM TAB] - ((MOUSESTATE RIGHT) (* ; "DELETE a tab.") - (COND - ((AND [SETQ TAB (for TABX in SCALEDTABS as TAB in TABS - smallest (ABS (IDIFFERENCE TABX (LASTMOUSEX STREAM] - (SETQ TABX (MSCALE (CAR TAB) - UNIT)) - (IGEQ (LASTMOUSEX STREAM) - (IDIFFERENCE TABX 2)) - (ILEQ (LASTMOUSEX STREAM) - (IPLUS TABX 2))) - (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT 'ERASE) - (SETQ TABS (LDIFFERENCE TABS (LIST TAB] - (replace MARL1 of OBJDATUM with L1) - (replace MARLN of OBJDATUM with LN) - (replace MARR of OBJDATUM with R) - (replace MARTABS of OBJDATUM with TABS))) - T]) - -(MB.MARGINBAR.SIZEFN - [LAMBDA (OBJ) (* jds " 5-Sep-84 14:10") - (PROG ((BOX (create IMAGEBOX - XSIZE _ 1008 - YSIZE _ 62 - YDESC _ 0 - XKERN _ 4))) - (IMAGEOBJPROP OBJ 'BOUNDBOX BOX) - (RETURN BOX]) - -(MB.MARGINBAR.DISPLAYFN - [LAMBDA (OBJ STREAM MODE) (* ; "Edited 12-Jun-90 18:59 by mitani") - (* Display the innards of a menu - button) - (PROG ((IMAGEBOX (OR (IMAGEOBJPROP OBJ 'BOUNDBOX) - (IMAGEBOX OBJ STREAM MODE))) - (OBJDATUM (IMAGEOBJPROP OBJ 'OBJECTDATUM)) - BITMAP - (DS (DSPCREATE)) - WASON) - (COND - [[SETQ WASON (SETQ BITMAP (IMAGEOBJPROP OBJ 'BITCACHE] - - (* The marginbar existed already as an image. - Don't bother re-creating it, and remember that we're allowed to MODIFY the old - image instead of creating a new one.) - - (SETQ DS (IMAGEOBJPROP OBJ 'DSPCACHE] - (T (* Have to create an image for the - margin bar) - (SETQ BITMAP (BITMAPCREATE (fetch XSIZE of IMAGEBOX) - (fetch YSIZE of IMAGEBOX))) - (* Create a cache bitmap) - (IMAGEOBJPROP OBJ 'BITCACHE BITMAP) - (SETQ DS (DSPCREATE BITMAP)) - (IMAGEOBJPROP OBJ 'DSPCACHE DS) - (DSPXOFFSET 0 DS) - (DSPYOFFSET 0 DS) - (DSPCLIPPINGREGION (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (fetch XSIZE of IMAGEBOX) - HEIGHT _ (fetch YSIZE of IMAGEBOX)) - DS))) - (MARGINBAR DS (fetch (MARGINBAR MARL1) of OBJDATUM) - (fetch (MARGINBAR MARLN) of OBJDATUM) - (fetch (MARGINBAR MARR) of OBJDATUM) - (fetch (MARGINBAR MARTABS) of OBJDATUM) - (fetch (MARGINBAR MARUNIT) of OBJDATUM) - (OR WASON (IMAGEOBJPROP OBJ 'NEEDSUPDATE NIL)) - (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL STREAM))) - (* Update the image, if it needs it) - (BITBLT BITMAP 0 0 STREAM (IDIFFERENCE (DSPXPOSITION NIL STREAM) - 4) - (IDIFFERENCE (DSPYPOSITION NIL STREAM) - (fetch YDESC of IMAGEBOX]) - -(MDESCALE - [LAMBDA (VAL UNIT) (* jds " 4-NOV-83 17:29") - - (* Convert a value from screen offset units to marginbar units) - - (COND - ((IEQP UNIT 12) - (QUOTIENT (IQUOTIENT (LLSH (IDIFFERENCE VAL 4) - 1) - UNIT) - 2.0)) - (T (QUOTIENT (DIFFERENCE VAL 4) - UNIT]) - -(MSCALE - [LAMBDA (VAL UNIT) (* jds " 4-NOV-83 17:31") - (* Convert from marginbar units to a - screen X offset) - (IPLUS 4 (FIXR (TIMES VAL (OR UNIT 1]) - -(MB.MARGINBAR.SHOWTAB - [LAMBDA (W TAB UNIT MODE) (* jds "22-Mar-85 17:36") - - (* Paint/erase/otherwise display the sign for a TAB in window WINDOW, using - units UNIT) - - (PROG ((TABX (MSCALE (fetch TABX of TAB) - UNIT))) - (SELECTQ (fetch TABKIND of TAB) - (LEFT (* Flush-left tab.) - (BITBLT \TEDIT.LEFTTAB 0 0 W (IDIFFERENCE TABX 2) - 1 NIL NIL 'INPUT MODE)) - (CENTERED (* Centered Tab) - (BITBLT \TEDIT.CENTERTAB 0 0 W (IDIFFERENCE TABX 5) - 1 NIL NIL 'INPUT MODE)) - (RIGHT (* Flush-right Tab) - (BITBLT \TEDIT.RIGHTTAB 0 0 W (IDIFFERENCE TABX 7) - 1 NIL NIL 'INPUT MODE)) - (DECIMAL (* Decimal aligned tab) - (BITBLT \TEDIT.DECIMALTAB 0 0 W (IDIFFERENCE TABX 7) - 1 NIL NIL 'INPUT MODE)) - (DOTTEDLEFT (* Decimal aligned tab) - (BITBLT \TEDIT.DOTTED.LEFTTAB 0 0 W (IDIFFERENCE TABX 7) - 1 NIL NIL 'INPUT MODE)) - (DOTTEDCENTERED (* Decimal aligned tab) - (BITBLT \TEDIT.DOTTED.CENTERTAB 0 0 W (IDIFFERENCE TABX 7) - 1 NIL NIL 'INPUT MODE)) - (DOTTEDRIGHT (* Decimal aligned tab) - (BITBLT \TEDIT.DOTTED.RIGHTTAB 0 0 W (IDIFFERENCE TABX 7) - 1 NIL NIL 'INPUT MODE)) - (DOTTEDDECIMAL (* Decimal aligned tab) - (BITBLT \TEDIT.DOTTED.DECIMALTAB 0 0 W (IDIFFERENCE TABX 7) - 1 NIL NIL 'INPUT MODE)) - NIL]) - -(MB.MARGINBAR.TABTRACK - [LAMBDA (STREAM OBJ TAB) (* jds " 8-Feb-84 20:38") - - (* Given that the mouse is down over a tab, track the tab as the mouse moves.) - - (PROG ((UNIT (fetch MARUNIT of OBJ)) - (CLIP (DSPCLIPPINGREGION NIL STREAM)) - (OLDX (MSCALE (fetch TABX of TAB) - (fetch MARUNIT of OBJ))) - X) - (while (AND (MOUSESTATE (OR LEFT MIDDLE RIGHT)) - (INSIDE? CLIP (LASTMOUSEX STREAM) - (LASTMOUSEY STREAM))) do (COND - ([NOT (IEQP OLDX (SETQ X (LASTMOUSEX STREAM] - (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT - 'ERASE) - (replace TABX of TAB - with (MDESCALE X UNIT)) - (MB.MARGINBAR.SHOWTAB STREAM TAB UNIT - 'PAINT) - (SETQ OLDX X]) - -(\TEDIT.TABTYPE.SET - [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:17 by jds") - (* Change the kind of TAB that will - be set in the succeeding marginbar.) - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - STATE DOTTEDBUTTON) - (SETQ STATE (IMAGEOBJPROP OBJ 'STATE)) (* Find out roughly what kind of TAB - this is to be.) - [SETQ STATE (U-CASE (COND - ((LISTP STATE) - (CAR STATE)) - (T STATE] (* Make sure it's upper case, and an - atom.) - (SETQ DOTTEDBUTTON (CAR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#))) - (* Find out if this is to be a tab - with a dotted leader.) - [COND - ((EQ (IMAGEOBJPROP DOTTEDBUTTON 'STATE) - 'ON) (* Yes. Make this a DOTTEDxxx tab.) - (SETQ STATE (PACK* 'DOTTED STATE] - (TEDIT.MAPPIECES TEXTOBJ [FUNCTION (LAMBDA (CH# PC PCNO FNARG) - - (* Now run thru the rest of the document until we find the margin bar. - Replace the tab type of that margin bar with the new type.) - - (COND - ((AND (IGREATERP CH# (CAR FNARG)) - (fetch (PIECE POBJ) of PC) - (type? MARGINBAR (fetch (PIECE POBJ) - of PC))) - (replace MARTABTYPE - of (IMAGEOBJPROP (fetch (PIECE POBJ) - of PC) - 'OBJECTDATUM) with - (CDR FNARG)) - 'STOP] - (CONS CH# STATE]) - -(MARGINBAR.INIT - [LAMBDA NIL (* jds " 9-Feb-86 15:18") - (SETQ MARGINBARIMAGEFNS (IMAGEFNSCREATE (FUNCTION MB.MARGINBAR.DISPLAYFN) - (FUNCTION MB.MARGINBAR.SIZEFN) - (FUNCTION MB.MARGINBAR.PUTFN) - (FUNCTION MB.MARGINBAR.GETFN) - (FUNCTION MB.COPYFN) - (FUNCTION MB.MARGINBAR.SELFN) - 'NILL - 'NILL - 'NILL - 'NILL - 'NILL - 'NILL - 'NILL - 'NILL - 'MarginRuler]) -) - -(RPAQQ \TEDIT.LEFTTAB #*(10 8)B@@@B@@@G@@@JH@@B@@@B@@@CN@@@@@@) - -(RPAQQ \TEDIT.CENTERTAB #*(10 8)@D@@@D@@@N@@AE@@@D@@@D@@AO@@@@@@) - -(RPAQQ \TEDIT.RIGHTTAB #*(10 8)@A@@@A@@@CH@@ED@@A@@@A@@AO@@@@@@) - -(RPAQQ \TEDIT.DECIMALTAB #*(10 8)@A@@@A@@@CH@@ED@@A@@@CH@@CH@@@@@) - -(RPAQQ \TEDIT.DOTTED.LEFTTAB #*(16 8)@@H@@@H@@AL@@BJ@@@H@CFH@CFOH@@@@) - -(RPAQQ \TEDIT.DOTTED.CENTERTAB #*(16 8)@@A@@@A@@@CH@@ED@@A@CFA@CFGL@@@@) - -(RPAQQ \TEDIT.DOTTED.RIGHTTAB #*(16 8)@@@D@@@D@@@N@@AE@@@DCF@DCFGL@@@@) - -(RPAQQ \TEDIT.DOTTED.DECIMALTAB #*(16 8)@@@D@@@D@@@N@@AE@@@D@MHN@MHN@@@@) - -(RPAQQ TEDIT.EXTENDEDRIGHTMARK #*(8 32)FF@@FF@@FF@@FF@@LL@@LL@@LL@@LL@@LL@@LL@@LL@@LL@@FF@@FF@@FF@@FF@@CC@@CC@@CC@@CC@@CC@@CC@@CC@@CC@@FF@@FF@@FF@@FF@@LL@@LL@@LL@@LL@@ -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS MARGINBARIMAGEFNS) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(MARGINBAR.INIT) - - -(ADDTOVAR IMAGEOBJTYPES (MarginRuler FILE TEDITMENU GETFN MB.GETFN)) -) - - - -(* ;; "Text menu creation and support") - -(DEFINEQ - -(\TEXTMENU.START - [LAMBDA (MENU MAINWINDOW TITLE HEIGHT) (* ; - "Edited 4-Jun-93 11:59 by sybalsky:mv:envos") - - (* ;; "Create a TEdit-based menu for a given main window.") - - (PROG ([WREG (COND - (MAINWINDOW (WINDOWPROP MAINWINDOW 'REGION)) - (T (GETREGION] - (CH#1 NIL) - MENUW MENUTEXT) - (COND - ((AND MAINWINDOW (WINDOWPROP MAINWINDOW 'TEDITMENU)) - (* ; - "This is a menu window. It can't have a menu, so bail out.") - (RETURN)) - ([AND MAINWINDOW (for WW in (ATTACHEDWINDOWS MAINWINDOW) - thereis (EQUAL (OR TITLE "TEdit Menu") - (WINDOWPROP WW 'TEDITMENU] - (* ; - "If this main window already has a menu, don't add another.") - (RETURN))) - (SETQ MENUW (CREATEW (SETQ WREG (COND - (MAINWINDOW (create REGION - LEFT _ (fetch (REGION LEFT) - of WREG) - BOTTOM _ (fetch (REGION TOP) - of WREG) - WIDTH _ (fetch (REGION WIDTH) - of WREG) - HEIGHT _ (OR HEIGHT 133))) - (T WREG))) - (OR TITLE "TEdit Menu"))) - (WINDOWADDPROP MENUW 'CLOSEFN 'TEXTMENU.CLOSEFN) - (WINDOWPROP MENUW 'TEDITMENU (OR TITLE "TEdit Menu")) - (* ; - "Mark this as a TEDIT MENU window") - (ATTACHWINDOW MENUW MAINWINDOW 'TOP 'JUSTIFY 'LOCALCLOSE) - (SETQ MENUTEXT MENU) - (replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - with T) - [AND MAINWINDOW (WINDOWPROP MENUW 'PROMPTWINDOW (WINDOWPROP MAINWINDOW 'PROMPTWINDOW] - [TEDIT MENUTEXT MENUW NIL (LIST 'TITLEMENUFN 'DON'T 'PROMPTWINDOW (fetch (TEXTOBJ - PROMPTWINDOW) - of (TEXTOBJ - MAINWINDOW - ] - (AND MAINWINDOW (TTY.PROCESS (WINDOWPROP MAINWINDOW 'PROCESS]) - -(\TEXTMENU.DOC.CREATE - [LAMBDA (MENUDESC MENUPROPS) (* ; "Edited 12-Jun-90 19:00 by mitani") - - (* Create the TEXTSTREAM for a menu, given a description. - That stream is passed to \TEXTMENU.START to get the menu up on screen) - - (PROG ((CH#1 NIL) - MENUW MENUTEXT) - [SETQ MENUTEXT (OPENTEXTSTREAM "" NIL NIL NIL (OR MENUPROPS '(FONT (MODERN 10] - (bind (CH# _ 1) - OBJ for DESC in MENUDESC - do (SELECTQ (CAR DESC) - (* (* This is a comment within a menu - description -- Ignore it.)) - (MB.BUTTON (* A menu button -- - hitting it calls a function) - (TEDIT.INSERT.OBJECT (MBUTTON.CREATE - (MKATOM (fetch (MB.BUTTON MBLABEL) - of DESC)) - (fetch (MB.BUTTON MBBUTTONEVENTFN) - of DESC) - (fetch (MB.BUTTON MBFONT) of DESC)) - MENUTEXT CH#) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED OFF) - CH# 1) - (add CH# 1)) - (MB.3STATE (* 3-state button; - hitting it changes state among ON, - OFF, and NEUTRAL.) - (TEDIT.INSERT.OBJECT (MB.CREATE.THREESTATEBUTTON - (MKATOM (fetch (MB.3STATE MBLABEL) - of DESC)) - (fetch (MB.3STATE MBFONT) of DESC) - (fetch (MB.3STATE MBCHANGESTATEFN) - of DESC) - (fetch (MB.3STATE MBINITSTATE) - of DESC)) - MENUTEXT CH#) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED OFF) - CH# 1) - (add CH# 1)) - (MB.TOGGLE (* TOGGLE button; hitting it - switches between ON and OFF.) - (TEDIT.INSERT.OBJECT (\TEXTMENU.TOGGLE.CREATE - (MKATOM (fetch (MB.TOGGLE MBTEXT) - of DESC)) - (fetch (MB.TOGGLE MBFONT) of DESC) - (fetch (MB.TOGGLE MBCHANGESTATEFN) - of DESC) - (fetch (MB.TOGGLE MBINITSTATE) - of DESC)) - MENUTEXT CH#) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED OFF) - CH# 1) - (add CH# 1)) - (MB.NWAY (* N-way buttons; choosing one turns - the others off.) - (SETQ OBJ (MB.CREATE.NWAYBUTTON (fetch (MB.NWAY MBBUTTONS) - of DESC) - (fetch (MB.NWAY MBFONT) of DESC) - (fetch (MB.NWAY MBCHANGESTATEFN) of DESC) - (fetch (MB.NWAY MBINITSTATE) of DESC) - (fetch (MB.NWAY MBMAXITEMSPERLINE) of - DESC))) - (TEDIT.INSERT.OBJECT OBJ MENUTEXT CH#) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED OFF) - CH# 1) - (add CH# 1)) - (MENU (* Real menu, except the selection - sticks) - (TEDIT.INSERT.OBJECT (MB.CREATE.FULLMENU (CADR DESC)) - MENUTEXT CH#) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED OFF) - CH# 1) - (add CH# 1)) - (MB.MARGINBAR (* Margin ruler for TEdit formatting) - (TEDIT.INSERT.OBJECT (MARGINBAR.CREATE -0.5 -0.5 -39.5 NIL - 12) - MENUTEXT CH#) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED OFF) - CH# 1) - (add CH# 1)) - (MB.TEXT (* Arbitrary text, which will be - protected from the user.) - (TEDIT.INSERT MENUTEXT (fetch (MB.TEXT MBSTRING) of DESC) - CH#) - [AND (fetch (MB.TEXT MBFONT) of DESC) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - (LIST 'MBFONT (fetch (MB.TEXT MBFONT) of DESC)) - CH# - (NCHARS (fetch (MB.TEXT MBSTRING) of DESC] - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED ON) - CH# - (NCHARS (fetch (MB.TEXT MBSTRING) of DESC))) - (add CH# (NCHARS (fetch (MB.TEXT MBSTRING) of DESC)))) - (MB.INSERT (* An insertion point, with optional - text to put there) - (TEDIT.INSERT MENUTEXT " {}" CH#) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED ON) - CH# 4) - (TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED ON SELECTPOINT ON) - (IPLUS CH# 2) - 1) - (OR CH#1 (SETQ CH#1 (IPLUS CH# 3))) - [COND - ((fetch (MB.INSERT MBINITENTRY) of DESC) - (* There is an initial entry to be - made. Make it) - [COND - ((IMAGEOBJP (fetch (MB.INSERT MBINITENTRY) of - DESC)) - (* It is an imageobj.) - (TEDIT.INSERT.OBJECT (fetch (MB.INSERT MBINITENTRY) - of DESC) - MENUTEXT - (IPLUS CH# 3))) - (T (* It's regular text.) - (TEDIT.INSERT MENUTEXT (MKSTRING (fetch (MB.INSERT - MBINITENTRY - ) - of DESC)) - (IPLUS CH# 3] - [TEDIT.LOOKS (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - '(PROTECTED OFF SELECTPOINT OFF) - (IPLUS CH# 3) - (NCHARS (MKSTRING (fetch (MB.INSERT MBINITENTRY) - of DESC] - (add CH# (NCHARS (fetch (MB.INSERT MBINITENTRY) - of DESC] - (add CH# 4)) - (\ILLEGAL.ARG DESC))) - (replace (TEXTOBJ MENUFLG) of (fetch (TEXTSTREAM TEXTOBJ) of MENUTEXT) - with T) (* Remember that this is a menu) - [COND - (CH#1 (* We actually inserted some text, - so it makes sense to put up a - selection) - (push (fetch (TEXTOBJ EDITPROPS) of (fetch (TEXTSTREAM TEXTOBJ) - of MENUTEXT)) - (LIST 'SEL CH#1] (* And where the first selection - should be.) - (RETURN MENUTEXT]) - -(TEXTMENU.CLOSEFN - [LAMBDA (W) (* ; "Edited 12-Jun-90 18:59 by mitani") - - (* ;; "CLOSE a TEdit menu window: Detach the menu, then reshape the remaining windows to take up the remaining space") - - (PROG ((MAINW (WINDOWPROP W 'MAINWINDOW)) - TEXTOBJ HEIGHT OHEIGHT OBOTTOM WBOTTOM WINDOWS) - (FREEATTACHEDWINDOW W) (* (DETACHWINDOW W) - (* ; "So detach this window.") - (COND ((IGREATERP (FLENGTH - (ATTACHEDWINDOWS MAINW)) 1) - (SETQ OHEIGHT (fetch - (REGION HEIGHT) of - (WINDOWPROP W (QUOTE REGION)))) - (SETQ OBOTTOM (fetch - (REGION BOTTOM) of - (WINDOWPROP W (QUOTE REGION)))) - (CLOSEW W) (SETQ WINDOWS - (SORT (ATTACHEDWINDOWS MAINW) - (FUNCTION (LAMBDA (WW) - (fetch (REGION BOTTOM) of - (WINDOWPROP WW (QUOTE REGION))))))) - (for WW in WINDOWS when - (IGEQ (SETQ WBOTTOM - (fetch (REGION BOTTOM) of - (WINDOWPROP WW (QUOTE REGION)))) - OBOTTOM) do (MOVEW WW - (fetch (REGION LEFT) of - (WINDOWPROP WW (QUOTE REGION))) - (IDIFFERENCE WBOTTOM OHEIGHT)))))) - (COND - ((SETQ TEXTOBJ (WINDOWPROP W 'TEXTOBJ)) (* ; - "Then, if this window still has a textobj under it, kill off that edit process.") - (TEDIT.KILL TEXTOBJ) - - (* ;; "This has to be TEDIT.KILL to avoid problems with the TTY being handed from main back to menu, causing main never to finish off; menu would quit and hand TTY to top level window.") - - ]) -) - -(RPAQQ TEXTMENUICON #*(16 24)@@@@@@@@@@@@H@@@L@@AK@@GHLAIHCFAJ@HAKFKIJJJAJBKIJBJAH@KIJDHAKDJIJLJIJDJIJDJIH@KIF@HFAHIH@FN@@@H@ -) - -(RPAQQ TEXTMENUICONMASK #*(16 24)@@@@@@@@@@@@H@@@L@@AO@@GOLAOOOGOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOGOONAOOH@GN@@@H@ -) - - - -(* ; "TEdit-specific support") - -(DEFINEQ - -(\TEDITMENU.CREATE - [LAMBDA NIL (* gbn "27-Sep-84 01:04") - (* Creates the TEdit Expanded Menu) - (SETQ TEDIT.EXPANDED.MENU (\TEXTMENU.DOC.CREATE TEDIT.EXPANDEDMENU.SPEC]) - -(\TEDIT.EXPANDED.MENU - [LAMBDA (STREAM) (* ; "Edited 20-Aug-87 16:51 by jds") - (* "27-Sep-84 01:04" gbn) - (PROG (CHARMENUTEXTSTREAM) - (\TEXTMENU.START (SETQ CHARMENUTEXTSTREAM (COPYTEXTSTREAM TEDIT.EXPANDED.MENU T)) - (\TEDIT.PRIMARYW (TEXTOBJ STREAM)) - "TEdit Menu" - (HEIGHTIFWINDOW 60 T)) - (COND - ((OR (TEXTPROP STREAM 'CLEARGET) - (TEXTPROP STREAM 'CLEARPUT)) (* initialise the button) - (\TEXTMENU.SET.TOGGLE "Unformatted" 'ON CHARMENUTEXTSTREAM]) - -(MB.DEFAULTBUTTON.FN - [LAMBDA (OBJ SEL W) (* ; "Edited 30-Mar-94 15:46 by jds") - (* ; - "MBFN for TEdit default menu item buttons.") - (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'TEXTOBJ)) - (MAINSEL (fetch (TEXTOBJ SEL) of MAINTEXT)) - OFILE CH PROC) - (COND - ((EQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) - T) - (TEDIT.PROMPTPRINT MAINTEXT "Edit operation in progress; please wait." T) - (RETURN)) - ((fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) - (TEDIT.PROMPTPRINT MAINTEXT (CONCAT (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) - " operation in progress; please wait.") - T) - [AND (NEQ (fetch (TEXTOBJ EDITOPACTIVE) of MAINTEXT) - (IMAGEOBJPROP OBJ 'MBTEXT] - (RETURN))) - [COND - ((AND (SETQ PROC (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'PROCESS)) - (PROCESSP PROC)) (* ; - "THE MAIN window has a live process behind it; go evaluate the button fn there.") - (PROCESS.EVAL PROC (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL - ))) - ((AND (SETQ PROC (WINDOWPROP W 'PROCESS)) - (PROCESSP PROC)) (* ; - "This window has a live process behind it; go evaluate the button fn there.") - (PROCESS.EVAL PROC (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL - ))) - (T (ADD.PROCESS (LIST 'MB.DEFAULTBUTTON.ACTIONFN OBJ SEL W TEXTOBJ MAINTEXT MAINSEL] - (COND - ((fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ) - (GIVE.TTY.PROCESS W) - (DISMISS 20))) - [COND - ((OR (fetch (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ) - (EQ (WINDOWPROP W 'PROCESS) - (TTY.PROCESS))) (* ; - "If the TEDIT MENU still has the tty, give it back to the real TEdit.") - (SETQ TEDIT.SELPENDING NIL) - (GIVE.TTY.PROCESS (WINDOWPROP W 'MAINWINDOW] - - (* ;; "Tell the menu button handler not to turn off this button--it's still active and will turn itself off.") - - (RETURN 'DON'T]) - -(\TEDITMENU.RECORD.UNFORMATTED - [LAMBDA (BUTTON NEWSTATE TEXTSTREAM) (* jds " 7-Feb-85 09:44") - (PROG ((FLG (COND - ((EQ NEWSTATE 'ON) - T) - (T NIL))) - (TEXTOBJ (TEXTOBJ TEXTSTREAM))) - (TEXTPROP TEXTOBJ 'UNFORMATTEDPUT/GET FLG]) - -(MB.DEFAULTBUTTON.ACTIONFN - [LAMBDA (OBJ SEL W TEXTOBJ MAINTEXT MAINSEL) (* ; "Edited 30-Mar-94 16:04 by jds") - (* ; - "MBFN for TEdit default menu item buttons.") - (PROG (OFILE CH %#COPIES PRINTHOST PRINTOPTIONS %#SIDES MSG) - [ERSETQ (RESETLST - [RESETSAVE (\TEDIT.MARKACTIVE MAINTEXT) - '(AND (\TEDIT.MARKINACTIVE OLDVALUE] - [RESETSAVE (\TEDIT.MARKACTIVE TEXTOBJ) - '(AND (\TEDIT.MARKINACTIVE OLDVALUE] - [RESETSAVE (PROG1 OBJ - (IMAGEOBJPROP OBJ 'MENUBUTTON.SELECTED T)) - '(AND (IMAGEOBJPROP OLDVALUE 'MENUBUTTON.SELECTED NIL] - (replace (TEXTOBJ EDITOPACTIVE) of MAINTEXT - with (OR (IMAGEOBJPROP OBJ 'MBTEXT) - T)) (* ; - "So we can tell the guy WHAT op is active.") - (SELECTQ (IMAGEOBJPROP OBJ 'MBTEXT) - (Put [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT - TEXTOBJ - (fetch (SELECTION CH#) - of SEL] - [COND - (OFILE (* ; - "Only try this if he really typed a file name") - (TEDIT.PUT MAINTEXT OFILE NIL (TEXTPROP TEXTOBJ - 'UNFORMATTEDPUT/GET]) - (Get [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT - TEXTOBJ - (fetch (SELECTION CH#) - of SEL] - [COND - (OFILE (* ; - "Only try this if he really typed a file name") - (TEDIT.GET MAINTEXT OFILE (TEXTPROP TEXTOBJ - 'UNFORMATTEDPUT/GET]) - (Include [SETQ OFILE (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT - TEXTOBJ - (fetch (SELECTION CH#) - of SEL] - (COND - (OFILE (TEDIT.INCLUDE MAINTEXT OFILE)))) - (Find (SETQ OFILE (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ - (fetch (SELECTION CH#) of SEL))) - [COND - ((ZEROP (NCHARS OFILE)) (* ; "NOTHING--HE HIT DEL.") - ) - (OFILE (* ; - "There's something to do. Go do it.") - (TEDIT.PROMPTPRINT MAINTEXT "Searching..." T) - [SETQ CH (CAR (ERSETQ (TEDIT.FIND MAINTEXT OFILE NIL NIL T] - (COND - (CH (* ; "We found the target text.") - (TEDIT.PROMPTPRINT MAINTEXT "Done.") - (\SHOWSEL MAINSEL NIL NIL) - (replace (SELECTION CH#) of MAINSEL - with (CAR CH)) - (* ; - "Set up SELECTION to be the found text") - (replace (SELECTION CHLIM) of MAINSEL - with (ADD1 (CADR CH))) - [replace (SELECTION DCH) of MAINSEL - with (ADD1 (IDIFFERENCE (CADR CH) - (CAR CH] - (replace (SELECTION POINT) of MAINSEL - with 'RIGHT) - (replace (TEXTOBJ CARETLOOKS) of MAINTEXT - with (\TEDIT.GET.INSERT.CHARLOOKS MAINTEXT - MAINSEL)) - (* ; - "Set the caret looks to match those of the new selection") - (TEDIT.RESET.EXTEND.PENDING.DELETE MAINSEL) - (* ; "And never pending a deletion.") - (\FIXSEL MAINSEL MAINTEXT) - (TEDIT.NORMALIZECARET MAINTEXT MAINSEL) - (\SHOWSEL MAINSEL NIL T)) - (T (TEDIT.PROMPTPRINT MAINTEXT "(Not found)"]) - (Substitute [PROG* ((SAVECH# (fetch (SELECTION CH#) of SEL)) - (REPLACEMENT (MBUTTON.NEXT.FIELD.AS.TEXT - TEXTOBJ - (fetch (SELECTION CH#) of SEL))) - [PATTERN (MBUTTON.NEXT.FIELD.AS.TEXT - TEXTOBJ - (fetch (SELECTION CHLIM) - of (fetch (TEXTOBJ SCRATCHSEL) - of TEXTOBJ] - CONFIRM? KEEPLOOKS? LOC) - [SETQ LOC (MBUTTON.FIND.NEXT.BUTTON - TEXTOBJ - (fetch (SELECTION CHLIM) - of (fetch (TEXTOBJ SCRATCHSEL) - of TEXTOBJ] - [SETQ CONFIRM? (EQ 'ON (IMAGEOBJPROP (CAR LOC) - 'STATE] - [SETQ LOC (MBUTTON.FIND.NEXT.BUTTON - TEXTOBJ - (ADD1 (CDR LOC] - [SETQ KEEPLOOKS? (EQ 'ON (IMAGEOBJPROP (CAR LOC) - 'STATE] - (COND - ((ZEROP (NCHARS PATTERN)) - (* ; "NOTHING--HE HIT DEL.") - ) - (PATTERN (* ; - "There's something to do. Go do it.") - [COND - (KEEPLOOKS? (SETQ REPLACEMENT - ( - MBUTTON.NEXT.FIELD.AS.PIECES - TEXTOBJ SAVECH#] - (RESETLST - (RESETSAVE (CURSOR WAITINGCURSOR)) - (TEDIT.SUBSTITUTE (fetch (TEXTOBJ - STREAMHINT) - of MAINTEXT) - PATTERN REPLACEMENT CONFIRM?))]) - (Quit (* ; "He wants to QUIT the edit.") - (COND - ((\TEDIT.QUIT (\TEDIT.PRIMARYW MAINTEXT) - T) - (replace (TEXTOBJ EDITFINISHEDFLG) of TEXTOBJ - with T)))) - (Page% Layout (* ; "Page layout menu") - (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.EXPANDED.PAGEMENU - T) - (\TEDIT.PRIMARYW MAINTEXT) - "Page Layout Menu" - (HEIGHTIFWINDOW 135 5))) - (Para% Looks (* ; "Page layout menu") - (\TEDIT.EXPANDEDPARA.MENU MAINTEXT)) - (Char% Looks (* ; "Page layout menu") - (\TEDIT.EXPANDEDCHARLOOKS.MENU MAINTEXT)) - (All (* ; "Select the entire document.") - (COND - ((NOT (ZEROP (fetch (TEXTOBJ TEXTLEN) of MAINTEXT))) - (\SHOWSEL MAINSEL NIL NIL) - (TEDIT.RESET.EXTEND.PENDING.DELETE MAINSEL) - (replace (SELECTION CH#) of MAINSEL with 1) - (replace (SELECTION CHLIM) of MAINSEL - with (ADD1 (fetch (TEXTOBJ TEXTLEN) of MAINTEXT))) - (replace (SELECTION DCH) of MAINSEL - with (fetch (TEXTOBJ TEXTLEN) of MAINTEXT)) - (replace (SELECTION POINT) of MAINSEL with - 'LEFT) - (replace (SELECTION SET) of MAINSEL with T) - (\FIXSEL MAINSEL MAINTEXT) - (\SHOWSEL MAINSEL NIL T)))) - (Hardcopy [SETQ PRINTHOST (\TEDIT.MAKEFILENAME ( - MBUTTON.NEXT.FIELD.AS.TEXT - TEXTOBJ - (fetch (SELECTION - CH#) - of SEL] - (COND - ((NOT PRINTHOST) (* ; - "If he didn't specify a particular host, defer to his defaults.") - (TEDIT.PROMPTPRINT MAINTEXT "Using default print server."))) - [SETQ %#COPIES (MBUTTON.NEXT.FIELD.AS.NUMBER - TEXTOBJ - (fetch (SELECTION CH#) - of (fetch (TEXTOBJ SCRATCHSEL) - of TEXTOBJ] - (* ; - "Grab the field that specifies number of copies.") - [COND - (%#COPIES (SETQ PRINTOPTIONS (LIST '%#COPIES %#COPIES] - (SETQ %#SIDES - (SELECTQ (IMAGEOBJPROP [CAR (MBUTTON.FIND.NEXT.BUTTON - TEXTOBJ - (fetch (SELECTION CHLIM) - of (fetch (TEXTOBJ - SCRATCHSEL) - of TEXTOBJ] - 'STATE) - (One% Side 1) - (Duplex 2) - NIL)) - [COND - (%#SIDES (push PRINTOPTIONS %#SIDES) - (push PRINTOPTIONS '%#SIDES] - [SETQ MSG (\TEDIT.MAKEFILENAME (MBUTTON.NEXT.FIELD.AS.TEXT - TEXTOBJ - (fetch (SELECTION CH#) - of (fetch (TEXTOBJ - SCRATCHSEL) - of TEXTOBJ] - [COND - (MSG (push PRINTOPTIONS MSG) - (push PRINTOPTIONS 'MESSAGE] - (TEDIT.HARDCOPY MAINTEXT NIL NIL NIL PRINTHOST PRINTOPTIONS)) - (ERROR)))] - (replace (SELECTION SET) of SEL with T)(* ; - "Now turn the menu button highlighting off.") - (replace (SELECTION ONFLG) of SEL with T) - (\SHOWSEL SEL NIL NIL) - (replace (SELECTION SET) of SEL with NIL) - (* ; - "And forget that anything is selected.") - ]) -) -(DEFINEQ - -(\TEDIT.CHARLOOKSMENU.CREATE - [LAMBDA NIL (* ; "Edited 20-Aug-87 16:50 by jds") - (* ; "Creates the TEdit Expanded Menu") - - (SETQ TEDIT.CHARLOOKS.MENU (\TEXTMENU.DOC.CREATE (APPEND (LIST (create MB.BUTTON - MBLABEL _ 'APPLY - MBBUTTONEVENTFN _ - '\TEDIT.APPLY.CHARLOOKS) - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ 'SHOW - MBBUTTONEVENTFN _ - '\TEDIT.SHOW.CHARLOOKS) - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ 'NEUTRAL - MBBUTTONEVENTFN _ - ' - \TEDIT.NEUTRALIZE.CHARLOOKS - ) - (create MB.TEXT - MBSTRING _ " -")) - TEDIT.CHARLOOKSMENU.SPEC]) - -(\TEDIT.EXPANDEDCHARLOOKS.MENU - [LAMBDA (STREAM) (* ; "Edited 20-Aug-87 16:49 by jds") - - (* ;; "Open a character-looks menu.") - - (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.CHARLOOKS.MENU T) - (\TEDIT.PRIMARYW STREAM) - "Character Looks Menu" - (HEIGHTIFWINDOW 68 T]) - -(\TEDIT.APPLY.BOLDNESS - [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:55") - (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (ON (CONS 'WEIGHT (CONS 'BOLD NEWLOOKS))) - (OFF (CONS 'WEIGHT (CONS 'MEDIUM NEWLOOKS))) - NEWLOOKS]) - -(\TEDIT.APPLY.CHARLOOKS - [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:17 by jds") - (* MBFN for TEdit default menu item - buttons.) - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'TEXTOBJ)) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - SCRATCHSEL OFILE CH NEWLOOKS SIZE SUPER SUB NEXTB BUTTON TEXT OFFSET) - [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] - (* Skip over the SHOW button) - [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] - (* And over the NEUTRAL button.) - (SETQ NEWLOOKS (\TEDIT.PARSE.CHARLOOKS.MENU TEXTOBJ CH#)) - (* Now Parse the menu, to give us a - looks spec.) - (TEDIT.LOOKS MAINTEXT NEWLOOKS (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL) - of MAINTEXT)) - (fetch (SELECTION DCH) of (fetch (TEXTOBJ SEL) of MAINTEXT))) - (* Make the change in looks) - (\SHOWSEL SEL NIL NIL) (* And turn off the APPLY button.) - (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'PROCESS)) (* Leave him typing in the real - document) - ]) - -(\TEDIT.APPLY.OLINE - [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:56") - (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (ON (CONS 'OVERLINE (CONS 'ON NEWLOOKS))) - (OFF (CONS 'OVERLINE (CONS 'OFF NEWLOOKS))) - NEWLOOKS]) - -(\TEDIT.SHOW.CHARLOOKS - [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:17 by jds") - - (* ;; "Set the CHARLOOKS menu from the looks of the currently selected character.") - - (LET* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'TEXTOBJ)) - (MAINCH# (fetch (SELECTION CH#) of (fetch (TEXTOBJ SEL) of MAINTEXT))) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - PC OFILE CH NEWLOOKS NEXTB BUTTON TEXT OFFSET) - (COND - ((<= MAINCH# (fetch (TEXTOBJ TEXTLEN) of MAINTEXT)) - [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] - (* ; "Skip over the NEUTRAL button.") - (\SHOWSEL SEL NIL NIL) - (replace (SELECTION SET) of SEL with NIL) - (SETQ PC (\CHTOPC MAINCH# (fetch (TEXTOBJ PCTB) of MAINTEXT))) - (* ; - "The PIECE containing the text to describe") - (SETQ NEWLOOKS (fetch (PIECE PLOOKS) of PC)) - (* ; - "Get the looks for those characters.") - (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (\TEDIT.FILL.IN.CHARLOOKS.MENU TEXTOBJ CH# - NEWLOOKS)) - (* ; - "Fill in the menu blanks with that info") - ]) - -(\TEDIT.NEUTRALIZE.CHARLOOKS - [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:18 by jds") - - (* Handle the NEUTRAL button on a character looks menu. - Sets all the menu settings neutral.) - - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'TEXTOBJ)) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - PC SCRATCHSEL OFILE CH NEWLOOKS NEXTB BUTTON TEXT OFFSET) - (\SHOWSEL SEL NIL NIL) - (replace (SELECTION SET) of SEL with NIL) - (\TEDIT.NEUTRALIZE.CHARLOOKS.MENU TEXTOBJ CH#) (* Fill in the menu blanks with that - info) - (TEDIT.UPDATE.SCREEN TEXTOBJ) (* And update the screen image.) - ]) - -(\TEDIT.FILL.IN.CHARLOOKS.MENU - [LAMBDA (TEXTOBJ CH# NEWLOOKS) (* ; "Edited 30-May-91 22:28 by jds") - - (* ;; "Given a TEXTOBJ describing a charlooks menu, the CH# of the start of the charlooks menu, and a set of looks, fill in the menu fields.") - - (PROG (PC SCRATCHSEL OFILE CH NEXTB BUTTON TEXT OFFSET) - (SETQ NEWLOOKS (\TEDIT.PARSE.CHARLOOKS.LIST NEWLOOKS NIL NIL)) - - (* ;; "Make sure the charlooks are in the proper internal format, so this fn can be called from every reasonable place.") - - (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - [for PROP in (LIST (fetch (CHARLOOKS CLBOLD) of NEWLOOKS) - (fetch (CHARLOOKS CLITAL) of NEWLOOKS) - (fetch (CHARLOOKS CLULINE) of NEWLOOKS) - (fetch (CHARLOOKS CLSTRIKE) of NEWLOOKS) - (fetch (CHARLOOKS CLOLINE) of NEWLOOKS)) - do (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - [COND - (PROP (* ; "Must set the property") - (IMAGEOBJPROP (CAR NEXTB) - 'STATE - 'ON)) - (T (* ; "Must reset it.") - (IMAGEOBJPROP (CAR NEXTB) - 'STATE - 'OFF] - (SETQ CH# (ADD1 (CDR NEXTB] - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (* ; "Get to the start of the text.") - (SETQ BUTTON (CAR NEXTB)) - [for ITEM in (IMAGEOBJPROP BUTTON 'BUTTONS) - do (* ; - "Loop thru the font FAMILY name button list, looking for one that matches this text's looks") - (COND - ((STRING-EQUAL [COND - ((AND (type? FONTCLASS (fetch (CHARLOOKS CLFONT) - of NEWLOOKS)) - (NEQ (fetch FONTCLASSNAME - of (fetch (CHARLOOKS CLFONT) - of NEWLOOKS)) - 'DEFAULTFONT)) - (CONCAT (fetch FONTCLASSNAME of (fetch - (CHARLOOKS CLFONT) - of NEWLOOKS)) - '-class)) - ((FONTP (fetch (CHARLOOKS CLFONT) of NEWLOOKS)) - (FONTPROP (fetch (CHARLOOKS CLFONT) of NEWLOOKS) - 'FAMILY] - ITEM) - (IMAGEOBJPROP BUTTON 'STATE ITEM) - (RETURN))) finally (* ; - "This font wasn't found in the list. Add it.") - [MB.NWAYBUTTON.ADDITEM - BUTTON - (COND - ((type? FONTCLASS (fetch (CHARLOOKS CLFONT) - of NEWLOOKS)) - (PACK* (fetch FONTCLASSNAME - of (fetch (CHARLOOKS CLFONT) - of NEWLOOKS)) - '-class)) - ((FONTP (fetch (CHARLOOKS CLFONT) of NEWLOOKS)) - (FONTPROP (fetch (CHARLOOKS CLFONT) of NEWLOOKS) - 'FAMILY] (* ; - "Add this family to the list of items") - (IMAGEOBJPROP BUTTON 'STATE (U-CASE - (FONTPROP (fetch - (CHARLOOKS CLFONT) - of NEWLOOKS) - 'FAMILY] - (* ; - "Now find which text button was 'on'") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) - NIL) (* ; - "Clean out the 'other font' field") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (fetch (CHARLOOKS CLSIZE) of NEWLOOKS)) - (* ; "Set the value in the SIZE field") - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - (* ; - "Move forward to the SUPERSCRIPT/SUBSCRIPT button") - (SETQ BUTTON (CAR NEXTB)) - (SETQ OFFSET (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS)) - (* ; - "Remember the offset value for later") - [COND - ((OR (NOT (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS)) - (ZEROP (fetch (CHARLOOKS CLOFFSET) of NEWLOOKS))) - (* ; - "There is no subscript or superscript. Mark the text NORMAL.") - (IMAGEOBJPROP BUTTON 'STATE 'Normal) - (SETQ OFFSET NIL) (* ; - "Mark there as being no offset value") - ) - ((ILESSP OFFSET 0) (* ; "SUBSCRIPTING") - (IMAGEOBJPROP BUTTON 'STATE 'Subscript)) - ((IGREATERP OFFSET 0) (* ; "SUBSCRIPTING") - (IMAGEOBJPROP BUTTON 'STATE 'Superscript] - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) - (AND OFFSET (IABS OFFSET))) (* ; - "Now move up to the offset distance fill-in field.") - (\SHOWSEL SCRATCHSEL NIL NIL) - (replace (SELECTION SET) of SCRATCHSEL with NIL) - (\TEDIT.MARK.LINES.DIRTY TEXTOBJ CH# (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL]) - -(\TEDIT.NEUTRALIZE.CHARLOOKS.MENU - [LAMBDA (TEXTOBJ CH#) (* ; "Edited 30-May-91 22:18 by jds") - - (* ;; -"Set all the fields in the CHARLOOKS menu specified by TEXTOBJ, starting at CH# to neutral values.") - - (PROG ((SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - PC OFILE CH NEXTB BUTTON TEXT OFFSET) - (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL [for PROP - in '(BOLD ITAL ULINE STRIKE OLINE) - do (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON - TEXTOBJ CH#)) - (IMAGEOBJPROP (CAR NEXTB) - 'STATE - 'NEUTRAL) - (SETQ CH# (ADD1 (CDR NEXTB] - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (* ; "Get to the start of the text.") - (SETQ BUTTON (CAR NEXTB)) - (IMAGEOBJPROP BUTTON 'STATE NIL) (* ; - "Now find which text button was 'on'") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) - NIL) (* ; - "Clean out the 'other font' field") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - )) - NIL) (* ; "Set the value in the SIZE field") - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - (* ; - "Move forward to the SUPERSCRIPT/SUBSCRIPT button") - (SETQ BUTTON (CAR NEXTB)) (* ; - "Remember the offset value for later") - (IMAGEOBJPROP BUTTON 'STATE NIL) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) - NIL) (* ; - "Now move up to the offset distance fill-in field.") - ]) - -(\TEDIT.PARSE.CHARLOOKS.MENU - [LAMBDA (TEXTOBJ CH#) (* ; "Edited 30-May-91 22:18 by jds") - (* MBFN for TEdit default menu item - buttons.) - (PROG (SCRATCHSEL CH NEWLOOKS SIZE SUPER SUB NEXTB BUTTON TEXT OFFSET) - (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - [for BUTTON in '(BOLD ITALIC UNDERLINE STRIKEOUT OVERSCORE) - do (* Set the character properties - which are independent) - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SELECTQ BUTTON - (BOLD (SETQ NEWLOOKS (\TEDIT.APPLY.BOLDNESS (CAR NEXTB) - NEWLOOKS))) - (ITALIC (SETQ NEWLOOKS (\TEDIT.APPLY.SLOPE (CAR NEXTB) - NEWLOOKS))) - (UNDERLINE (SETQ NEWLOOKS (\TEDIT.APPLY.ULINE (CAR NEXTB) - NEWLOOKS))) - (STRIKEOUT (SETQ NEWLOOKS (\TEDIT.APPLY.STRIKEOUT (CAR NEXTB) - NEWLOOKS))) - (OVERSCORE (SETQ NEWLOOKS (\TEDIT.APPLY.OLINE (CAR NEXTB) - NEWLOOKS))) - NIL) - (SETQ CH# (ADD1 (CDR NEXTB] - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (* Get to the start of the text.) - (SETQ BUTTON (CAR NEXTB)) - [AND BUTTON - (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (Other (* Have to get and add in a new - font.) - (COND - ([SETQ TEXT (MBUTTON.NEXT.FIELD.AS.ATOM TEXTOBJ (ADD1 (CDR NEXTB] - (* He wants some font not on the - list. Add it to the list.) - (SETQ NEWLOOKS (CONS 'FAMILY (CONS (U-CASE TEXT) - NEWLOOKS))) - (COND - ([NOT (FMEMB (U-CASE TEXT) - (U-CASE (IMAGEOBJPROP BUTTON 'BUTTONS] - (* This font name isn't in the list - already; add it.) - (MB.NWAYBUTTON.ADDITEM BUTTON TEXT) - (IMAGEOBJPROP BUTTON 'STATE TEXT)) - (T [IMAGEOBJPROP BUTTON 'STATE (for NAME - in (IMAGEOBJPROP BUTTON - 'BUTTONS) - suchthat (EQ (U-CASE TEXT) - (U-CASE NAME] - (* Select the newly-specified font.) - )) - (TEDIT.DELETE TEXTOBJ SCRATCHSEL) - (* Delete the new font's name from - the fill-in field.) - (TEDIT.OBJECT.CHANGED TEXTOBJ BUTTON)) - (T (* He didn't specify a font. - Complain but keep on.) - (TEDIT.PROMPTPRINT TEXTOBJ - "'Other' font not specified; no change made." T)))) - (COND - ((STRPOS '-class (IMAGEOBJPROP BUTTON 'STATE)) - (* It's a font class. - Grab the name and evaluate it.) - (SETQ NEWLOOKS - (CONS 'FONT (CONS [EVAL (MKATOM (SUBSTRING (IMAGEOBJPROP BUTTON 'STATE) - 1 - (SUB1 (STRPOS '-class - (IMAGEOBJPROP - BUTTON - 'STATE] - NEWLOOKS))) - (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#)) - (T (SETQ NEWLOOKS (CONS 'FAMILY (CONS (U-CASE (IMAGEOBJPROP BUTTON 'STATE)) - NEWLOOKS))) - (MBUTTON.FIND.NEXT.FIELD TEXTOBJ CH#) - (* Skip over the "other text" - fill-in.) - ] (* Now find which text button was "on") - [SETQ SIZE (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - (* Read the contents of the SIZE - menu field) - [COND - (SIZE (* He specified one. - Set it.) - (SETQ NEWLOOKS (CONS 'SIZE (CONS SIZE NEWLOOKS] - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - (* Get a handle on the - SUPERSCRIPT/SUBSCRIPT button) - (SETQ BUTTON (CAR NEXTB)) - (SETQ SUPER (IMAGEOBJPROP BUTTON 'STATE)) (* Decide which kind it is) - [SETQ OFFSET (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (CDR NEXTB] - (* And get the offset distance, in - points.) - (SELECTQ SUPER - (Superscript - - (* He called for SUPERSCRIPTing. Offset the characters by either the distance - he gave, or 2 pts.) - - (SETQ NEWLOOKS (CONS 'SUPERSCRIPT (CONS (OR OFFSET 2) - NEWLOOKS)))) - (Subscript - - (* He called for SUBSCRIPTING. Offset the characters by either the distance he - gave, or 2 pts if he gave no distance.) - - (SETQ NEWLOOKS (CONS 'SUBSCRIPT (CONS (OR OFFSET 2) - NEWLOOKS)))) - (Normal (* NORMAL => Turn off all super and - subscripting) - (SETQ NEWLOOKS (CONS 'SUPERSCRIPT (CONS 0 NEWLOOKS)))) - NIL) - (RETURN NEWLOOKS]) - -(\TEDIT.APPLY.SLOPE - [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:56") - (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (ON (CONS 'SLOPE (CONS 'ITALIC NEWLOOKS))) - (OFF (CONS 'SLOPE (CONS 'REGULAR NEWLOOKS))) - NEWLOOKS]) - -(\TEDIT.APPLY.STRIKEOUT - [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:56") - (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (ON (CONS 'STRIKEOUT (CONS 'ON NEWLOOKS))) - (OFF (CONS 'STRIKEOUT (CONS 'OFF NEWLOOKS))) - NEWLOOKS]) - -(\TEDIT.APPLY.ULINE - [LAMBDA (BUTTON NEWLOOKS) (* jds "30-Aug-84 13:56") - (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (ON (CONS 'UNDERLINE (CONS 'ON NEWLOOKS))) - (OFF (CONS 'UNDERLINE (CONS 'OFF NEWLOOKS))) - NEWLOOKS]) -) -(DEFINEQ - -(\TEDITPARAMENU.CREATE - [LAMBDA NIL (* jds " 2-Aug-84 15:32") - (* Creates the TEdit Expanded - Paragraph Menu) - (SETQ TEDIT.EXPANDEDPARA.MENU (\TEXTMENU.DOC.CREATE TEDIT.PARAMENU.SPEC]) - -(\TEDIT.EXPANDEDPARA.MENU - [LAMBDA (STREAM) (* ; "Edited 20-Aug-87 16:51 by jds") - - (\TEXTMENU.START (COPYTEXTSTREAM TEDIT.EXPANDEDPARA.MENU T) - (\TEDIT.PRIMARYW (TEXTOBJ STREAM)) - "Paragraph-Looks Menu" - (HEIGHTIFWINDOW 141 T]) - -(\TEDIT.APPLY.PARALOOKS - [LAMBDA (OBJ SEL W) (* ; "Edited 22-Apr-93 16:45 by jds") - - (* ;; "Handler for the Paragraph Menu's APPLY button. Collects the specs from the paragraph menu and calls TEDIT.PARALOOKS to effect the change.") - - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'TEXTOBJ)) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - SCRATCHSEL QUAD OFILE CH NEWLOOKS SIZE SUPER SUB LINELEAD PARALEAD DEFAULTTAB BUTTON NEXTB - BUTTONDATA L1 LN R PARATYPE SPECIALX SPECIALY) - [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] - (* ; "Skip the SHOW button") - [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] - (* ; "and the NEUTRAL button.") - (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - (SETQ NEWLOOKS NIL) (* ; - "The list we'll be collecting the looks changes in.") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (* ; - "Get the JUSTIFICATION button: Left/Right/Centered/Justified") - (SETQ BUTTON (CAR NEXTB)) - [COND - ((AND (SETQ QUAD (IMAGEOBJPROP BUTTON 'STATE)) - (NEQ QUAD 'OFF)) (* ; "A justification was specified") - (SETQ NEWLOOKS (CONS 'QUAD (CONS (U-CASE (MKATOM QUAD)) - NEWLOOKS] - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (* ; "Go to the 'Page Heading' button") - (SETQ BUTTON (CAR NEXTB)) - [COND - ((EQ (IMAGEOBJPROP BUTTON 'STATE) - 'ON) (* ; - "This paragraph IS a page heading.") - (SETQ NEWLOOKS (CONS 'TYPE (CONS 'PAGEHEADING NEWLOOKS))) - (* ; "Tell him that it's a heading.") - (SETQ NEWLOOKS (CONS 'SUBTYPE (CONS [MKATOM (MBUTTON.NEXT.FIELD.AS.TEXT - TEXTOBJ - (ADD1 (CDR NEXTB] - NEWLOOKS)))(* ; "And say what kind.") - ) - ((EQ (IMAGEOBJPROP BUTTON 'STATE) - 'OFF) (* ; - "This paragraph IS NOT a page heading.") - (SETQ NEWLOOKS (CONS 'TYPE (CONS NIL NEWLOOKS))) - (* ; - "Tell him that it's NOT a heading.") - (SETQ NEWLOOKS (CONS 'SUBTYPE (CONS NIL NEWLOOKS))) - (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (CDR NEXTB))) - (* ; "And say what kind.") - ) - (T (* ; - "No change specified. Skip over the heading-type fill-in.") - (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (CDR NEXTB] - [COND - ((SETQ LINELEAD (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (fetch (SELECTION CH#) - of SCRATCHSEL))) - (* ; "Get any line leading") - (SETQ NEWLOOKS (CONS 'LINELEADING (CONS LINELEAD NEWLOOKS] - [COND - ([SETQ PARALEAD (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION - CH#) - of SCRATCHSEL] - (* ; "Get any paragraph leading") - (SETQ NEWLOOKS (CONS 'PARALEADING (CONS PARALEAD NEWLOOKS] - [COND - ([SETQ SPECIALX (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION - CH#) - of SCRATCHSEL] - (* ; - "Get any special X position for the paragraph") - (SETQ NEWLOOKS (CONS 'SPECIALX (CONS (FIXR (TIMES 12 SPECIALX)) - NEWLOOKS] - [COND - ([SETQ SPECIALY (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION - CH#) - of SCRATCHSEL] - (* ; - "Get special Y positioning for the paragraph") - (SETQ NEWLOOKS (CONS 'SPECIALY (CONS (FIXR (TIMES 12 SPECIALY)) - NEWLOOKS] - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) of - SCRATCHSEL - ))) - (SETQ BUTTON (CAR NEXTB)) - [COND - [(EQ (IMAGEOBJPROP BUTTON 'STATE) - 'ON) (* ; - "This paragraph starts on a new page (or col or box, as apprpopriate)") - (SETQ NEWLOOKS (CONS 'NEWPAGEBEFORE (CONS T NEWLOOKS] - ((EQ (IMAGEOBJPROP BUTTON 'STATE) - 'OFF) (* ; - "This paragraph IS NOT a page heading.") - (SETQ NEWLOOKS (CONS 'NEWPAGEBEFORE (CONS NIL NEWLOOKS] - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (SETQ BUTTON (CAR NEXTB)) - [COND - [(EQ (IMAGEOBJPROP BUTTON 'STATE) - 'ON) (* ; - "The next paragraph starts on a new page....") - (SETQ NEWLOOKS (CONS 'NEWPAGEAFTER (CONS T NEWLOOKS] - ((EQ (IMAGEOBJPROP BUTTON 'STATE) - 'OFF) (* ; - "The next paragraph DOESN'T START on a new page....") - (SETQ NEWLOOKS (CONS 'NEWPAGEAFTER (CONS NIL NEWLOOKS] - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (SETQ BUTTON (CAR NEXTB)) - (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (ON (push NEWLOOKS T) - (push NEWLOOKS 'HARDCOPY)) - (OFF (push NEWLOOKS NIL) - (push NEWLOOKS 'HARDCOPY)) - NIL) - -(* ;;; "THE VARIOUS KINDS OF KEEP PROPERTIES (ONLY HEADING-KEEP FOR NOW THO)") - - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (SETQ BUTTON (CAR NEXTB)) - (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (ON (push NEWLOOKS 'ON) - (push NEWLOOKS 'HEADINGKEEP)) - (OFF (push NEWLOOKS 'OFF) - (push NEWLOOKS 'HEADINGKEEP)) - NIL) - -(* ;;; "THE DEFAULT TAB WIDTH") - - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) of - SCRATCHSEL - ))) - (SETQ BUTTON (CAR NEXTB)) - (SETQ DEFAULTTAB (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (CDR NEXTB))) - (while (NOT (type? MARGINBAR BUTTON)) do (SETQ NEXTB ( - MBUTTON.FIND.NEXT.BUTTON - TEXTOBJ - (fetch (SELECTION - CH#) - of SCRATCHSEL))) - (SETQ BUTTON (CAR NEXTB))) - (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM)) - [COND - ((IGEQ [SETQ L1 (FIXR (TIMES (fetch MARL1 of BUTTONDATA) - (fetch MARUNIT of BUTTONDATA] - 0) (* ; - "The 1stleftmargin is set, and non-neutral.") - (SETQ NEWLOOKS (CONS '1STLEFTMARGIN (CONS L1 NEWLOOKS] - [COND - ((IGEQ [SETQ LN (FIXR (TIMES (fetch MARLN of BUTTONDATA) - (fetch MARUNIT of BUTTONDATA] - 0) (* ; - "The LEFTMARGIN is set, and non-neutral.") - (SETQ NEWLOOKS (CONS 'LEFTMARGIN (CONS LN NEWLOOKS] - [COND - ((IGEQ [SETQ R (FIXR (TIMES (fetch MARR of BUTTONDATA) - (fetch MARUNIT of BUTTONDATA] - 0) (* ; - "The RIGHTMARGIN is set, and non-neutral.") - (SETQ NEWLOOKS (CONS 'RIGHTMARGIN (CONS R NEWLOOKS] - [COND - ((NEQ (fetch MARTABS of BUTTONDATA) - 'NEUTRAL) (* ; - "If the tab settings are neutral, don't change anything.") - (SETQ NEWLOOKS - (CONS 'TABS - (CONS [CONS DEFAULTTAB - (SORT (for TAB in (fetch MARTABS of BUTTONDATA) - collect (CONS (FIXR (TIMES (CAR TAB) - (fetch MARUNIT - of BUTTONDATA))) - (CDR TAB))) - (FUNCTION (LAMBDA (A B) - (ILEQ (CAR A) - (CAR B] - NEWLOOKS] - (TEDIT.PARALOOKS MAINTEXT NEWLOOKS (fetch (SELECTION CH#) of (fetch - (TEXTOBJ SEL) - of MAINTEXT)) - (fetch (SELECTION DCH) of (fetch (TEXTOBJ SEL) of MAINTEXT))) - (\SHOWSEL SEL NIL NIL) - (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'PROCESS]) - -(\TEDIT.SHOW.PARALOOKS - [LAMBDA (OBJ SEL W) (* ; "Edited 6-Jul-92 09:42 by jds") - - (* ;; "Fill in the PARAGRAPH LOOKS menu from the para looks for a selected character") - - (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'TEXTOBJ)) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - (OLDUPDATEFLG (fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ)) - FMTSPEC BUTTON NEXTB ARB BUTTONDATA) - (\SHOWSEL SEL NIL NIL) - (replace (SELECTION SET) of SEL with NIL) - (COND - ((ZEROP (fetch (TEXTOBJ TEXTLEN) of MAINTEXT)) - (* ; - "If there is no text to take the formatting from, don't bother") - (RETURN))) - (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL - [SETQ FMTSPEC (fetch (PIECE PPARALOOKS) - of (\CHTOPC [IMAX 1 (IMIN (fetch (TEXTOBJ TEXTLEN) - of MAINTEXT) - (fetch (SELECTION CH#) - of (fetch (TEXTOBJ SEL) - of MAINTEXT] - (fetch (TEXTOBJ PCTB) of MAINTEXT] - (* ; "Get to the start of the text.") - [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] - (* ; "Skip the NEUTRAL button.") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (* ; "Grab the justification button") - (SETQ BUTTON (CAR NEXTB)) - [for ITEM in (IMAGEOBJPROP BUTTON 'BUTTONS) - do (COND - ([EQ (fetch (FMTSPEC QUAD) of FMTSPEC) - (U-CASE (COND - ((LISTP ITEM) - (CAR ITEM)) - (T ITEM] (* ; "Turn this button on.") - (IMAGEOBJPROP BUTTON 'STATE ITEM) - (RETURN] (* ; - "Now find which text button was 'on'") - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (* ; "Find the 'Page Heading' button") - (SETQ BUTTON (CAR NEXTB)) - (COND - ((EQ (fetch (FMTSPEC FMTPARATYPE) of FMTSPEC) - 'PAGEHEADING) (* ; - "This IS a page heading. Turn the button ON and set the heading type field") - (IMAGEOBJPROP BUTTON 'STATE 'ON) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL)) - (fetch (FMTSPEC FMTPARASUBTYPE) of FMTSPEC))) - (T (* ; - "This isn't a page heading; make sure the type field is empty.") - (IMAGEOBJPROP BUTTON 'STATE 'OFF) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL)) - NIL))) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - )) - (fetch (FMTSPEC LINELEAD) of FMTSPEC)) - (* ; "Update the LINE LEADING field") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - )) - (fetch (FMTSPEC LEADBEFORE) of FMTSPEC)) - (* ; "Update the PARA LEADING field") - [MBUTTON.SET.NEXT.FIELD - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (LET ((VAL (/ (FIXR (IQUOTIENT (OR (fetch (FMTSPEC FMTSPECIALX) of FMTSPEC - ) - 0) - 3)) - 4))) - (COND - ((FIXP VAL) - VAL) - (T (FLOAT VAL] - [MBUTTON.SET.NEXT.FIELD - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (LET ((VAL (/ (FIXR (IQUOTIENT (OR (fetch (FMTSPEC FMTSPECIALY) of FMTSPEC - ) - 0) - 3)) - 4))) - (COND - ((FIXP VAL) - VAL) - (T (FLOAT VAL] - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION - CH#) - of SCRATCHSEL] - (SETQ BUTTON (CAR NEXTB)) - [COND - ((fetch (FMTSPEC FMTNEWPAGEBEFORE) of FMTSPEC) - (IMAGEOBJPROP BUTTON 'STATE 'ON) (* ; "This para starts on a new page") - ) - (T (IMAGEOBJPROP BUTTON 'STATE 'OFF] - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (SETQ BUTTON (CAR NEXTB)) - [COND - ((fetch (FMTSPEC FMTNEWPAGEAFTER) of FMTSPEC) - (IMAGEOBJPROP BUTTON 'STATE 'ON) (* ; "This para starts on a new page") - ) - (T (IMAGEOBJPROP BUTTON 'STATE 'OFF] - - (* ;; "HARDCOPY-DISPLAY MODE") - - [SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ (ADD1 (CDR NEXTB)) - (COND - ((fetch (FMTSPEC FMTHARDCOPY) of FMTSPEC) - (* ; - "This para is to be formatted for hardcopy on the display") - 'ON) - (T 'OFF] - - (* ;; "HEADING KEEP") - - [SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB - (COND - ((fetch (FMTSPEC FMTHEADINGKEEP) of FMTSPEC) - (* ; - "This para is to be formatted for hardcopy on the display") - 'ON) - (T 'OFF] - - (* ;; "DEFAULT TAB WIDTH") - - (MBUTTON.SET.NEXT.FIELD TEXTOBJ NEXTB (CAR (fetch (FMTSPEC TABSPEC) - of FMTSPEC))) - (* ; - "Update the DEFAULT TAB SPACING field") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) - of SCRATCHSEL))) - (SETQ BUTTON (CAR NEXTB)) - (while (NOT (type? MARGINBAR BUTTON)) - do [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (SETQ BUTTON (CAR NEXTB))) - (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM)) - (* ; - "(IMAGEOBJPROP BUTTON (QUOTE IMAGECACHE) NIL)") - (* ; "Tell it to reformat itself.") - (replace MARL1 of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC - 1STLEFTMAR - ) - of FMTSPEC) - (fetch MARUNIT - of BUTTONDATA))) - (replace MARLN of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC - LEFTMAR) - of FMTSPEC) - (fetch MARUNIT - of BUTTONDATA))) - (replace MARR of BUTTONDATA with (FQUOTIENT (fetch (FMTSPEC - RIGHTMAR) - of FMTSPEC) - (fetch MARUNIT of - BUTTONDATA)) - ) - (replace MARTABS of BUTTONDATA - with (for TAB in (CDR (fetch (FMTSPEC TABSPEC) of FMTSPEC)) - collect (CONS (FQUOTIENT (CAR TAB) - (fetch MARUNIT of BUTTONDATA)) - (CDR TAB]) - -(\TEDIT.NEUTRALIZE.PARALOOKS.MENU - [LAMBDA (OBJ SEL W) (* ; "Edited 30-May-91 22:18 by jds") - - (* ;; "Set all the fields of a PARAGRAPH LOOKS menu to neutral settings.") - - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - SCRATCHSEL FMTSPEC BUTTON NEXTB ARB BUTTONDATA) - (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - (* ; "Get to the start of the text.") - (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE - TEXTOBJ CH# 'NIL)) - (* ; - "Neutralize the justification N-Way button") - (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL)) - (* ; "Find the 'Page Heading' button") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - )) - NIL) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - )) - NIL) (* ; "Update the LINE LEADING field") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - )) - NIL) (* ; "Update the PARA LEADING field") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - )) - NIL) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - )) - NIL) - (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ (ADD1 (fetch (SELECTION - CH#) - of SCRATCHSEL)) - 'NEUTRAL)) (* ; "New page before") - (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL)) - (* ; "New page after") - (SETQ NEXTB (MBUTTON.SET.NEXT.BUTTON.STATE TEXTOBJ NEXTB 'NEUTRAL)) - (* ; "Hardcopy formatting mode") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ NEXTB NIL) - (* ; - "Update the DEFAULT TAB SPACING field") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (fetch (SELECTION CH#) - of SCRATCHSEL))) - (SETQ BUTTON (CAR NEXTB)) - (while (NOT (type? MARGINBAR BUTTON)) - do [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (SETQ BUTTON (CAR NEXTB))) - (SETQ BUTTONDATA (IMAGEOBJPROP BUTTON 'OBJECTDATUM)) - (* ; - "(IMAGEOBJPROP BUTTON (QUOTE IMAGECACHE) NIL)") - (* ; "Tell it to reformat itself.") - [replace MARL1 of BUTTONDATA - with (COND - ((ILESSP (fetch MARL1 of BUTTONDATA) - 0) - (fetch MARL1 of BUTTONDATA)) - (T (IMIN -0.5 (IMINUS (fetch MARL1 of BUTTONDATA] - [replace MARLN of BUTTONDATA - with (COND - ((ILESSP (fetch MARLN of BUTTONDATA) - 0) - (fetch MARLN of BUTTONDATA)) - (T (IMIN -0.5 (IMINUS (fetch MARLN of BUTTONDATA] - [replace MARR of BUTTONDATA - with (COND - ((ILESSP (fetch MARR of BUTTONDATA) - 0) - (fetch MARR of BUTTONDATA)) - ((ZEROP (fetch MARR of BUTTONDATA)) - (IMINUS (IQUOTIENT (IDIFFERENCE (fetch (TEXTOBJ WRIGHT) - of TEXTOBJ) - 20) - 12))) - (T (IMIN -0.5 (IMINUS (fetch MARR of BUTTONDATA] - (replace MARTABS of BUTTONDATA with 'NEUTRAL]) - -(\TEDIT.RECORD.TABLEADERS - [LAMBDA (BUTTON NEWSTATE TEXTSTREAM SEL) (* ; "Edited 30-May-91 22:18 by jds") - - (* Toggle the dotted-leader state of the margin bar tab-setter. - This is called when the user hits the "dotted leader" toggle button in the menu) - - (PROG* [(FLG (COND - ((EQ NEWSTATE 'ON) - T) - (T NIL))) - (TEXTOBJ (TEXTOBJ TEXTSTREAM)) - (MARGINBAR (CAR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION - CH#) - of SEL] - (replace MARTABTYPE of (IMAGEOBJPROP MARGINBAR 'OBJECTDATUM) - with (SELECTQ (OR (fetch MARTABTYPE of (IMAGEOBJPROP MARGINBAR - 'OBJECTDATUM)) - 'LEFT) - (LEFT 'DOTTEDLEFT) - (DOTTEDLEFT 'LEFT) - (CENTERED 'DOTTEDCENTERED) - (DOTTEDCENTERED - 'CENTERED) - (RIGHT 'DOTTEDRIGHT) - (DOTTEDRIGHT 'RIGHT) - (DECIMAL 'DOTTEDDECIMAL) - (DOTTEDDECIMAL 'DECIMAL) - (SHOULDNT]) -) -(DEFINEQ - -(\TEDIT.SHOW.PAGEFORMATTING - [LAMBDA (OBJ SEL W) (* ; "Edited 4-Feb-92 16:38 by jds") - -(* ;;; "Take a document's page formatting, and display it in the menu.") - - (PROG* ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'TEXTOBJ)) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - (SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - (OLDUPDATEFLG (fetch (TEXTOBJ TXTDON'TUPDATE) of TEXTOBJ)) - FOLIOINFO NEWLOOKS NEXTB BUTTON PAGEID OPAGEFRAMES FIRST REST PFONT HEADING HEADINGS - PAGEPROPS STARTINGPAGE# PAPERSIZE) - - (* ;; "Start by turning off the selection--and leaving it off afterward.") - - (\SHOWSEL SEL NIL NIL) - (replace (SELECTION SET) of SEL with NIL) - - (* ;; "What kind of page are we looking at the specs for?") - - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ BUTTON (CAR NEXTB)) - (SELECTQ (IMAGEOBJPROP (CAR NEXTB) - 'STATE) - (|First(&Default)| - (SETQ PAGEID 'FIRST)) - (Other% Left (SETQ PAGEID 'LEFT)) - (Other% Right (SETQ PAGEID 'RIGHT)) - (PROGN (TEDIT.PROMPTPRINT MAINTEXT "First specify which kind of page you want to see." - T) - (SETQ PAGEID NIL))) - - (* ;; "Now mark the menu for NO SCREEN UPDATES during the button-setting process.") - - (AND PAGEID (WITHOUT-UPDATES TEXTOBJ SCRATCHSEL (replace (TEXTOBJ TXTDON'TUPDATE) - of TEXTOBJ with T) - - (* ;; "Now replace the button values, fill-in fields, etc.") - - (SETQ OPAGEFRAMES (OR (fetch (TEXTOBJ TXTPAGEFRAMES) of - MAINTEXT - ) - TEDIT.PAGE.FRAMES)) - [COND - ((LISTP OPAGEFRAMES) (* ; - "No problem, this is already just a list of first-recto-verso frames") - ) - (T (* ; - "This is probably a parsed-up version of the thing. Fix it to a list.") - (COND - [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of - OPAGEFRAMES - ) - 'SEQUENCE) - (SETQ FIRST (CAR (fetch (PAGEREGION REGIONSUBBOXES) - of OPAGEFRAMES))) - (SETQ REST (CADR (fetch (PAGEREGION REGIONSUBBOXES) - of OPAGEFRAMES))) - (COND - [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of - REST) - 'ALTERNATE) - (SETQ OPAGEFRAMES (CONS FIRST (fetch (PAGEREGION - REGIONSUBBOXES) - of REST] - (T (SETQ OPAGEFRAMES NIL] - (T (SETQ OPAGEFRAMES NIL] - (COND - ((NOT OPAGEFRAMES) (* ; - "If the formatting isn't in our simplified 3-way format, punt out of this.") - (TEDIT.PROMPTPRINT MAINTEXT "Format too complex to edit." T) - (SETQ PAGEID NIL))) - (SELECTQ PAGEID - (FIRST (SETQ NEWLOOKS (CAR OPAGEFRAMES))) - (LEFT (SETQ NEWLOOKS (CADR OPAGEFRAMES)) - (SETQ PAPERSIZE (LISTGET [CAR (FLAST ( - TEDIT.UNPARSE.PAGEFORMAT - (CAR OPAGEFRAMES) - 'PICAS] - 'PAPERSIZE))) - (RIGHT (SETQ NEWLOOKS (CADDR OPAGEFRAMES)) - (SETQ PAPERSIZE (LISTGET [CAR (FLAST ( - TEDIT.UNPARSE.PAGEFORMAT - (CAR OPAGEFRAMES) - 'PICAS] - 'PAPERSIZE))) - NIL) - (COND - (PAGEID (SETQ NEWLOOKS (TEDIT.UNPARSE.PAGEFORMAT NEWLOOKS - 'PICAS)) - (SETQ PAGEPROPS (CAR (FLAST NEWLOOKS))) - [COND - ((EQ PAGEID 'FIRST) - (SETQ PAPERSIZE (LISTGET PAGEPROPS 'PAPERSIZE] - (SETQ CH# (ADD1 (CDR NEXTB))) - (* ; - "Move past the kind-of-page button") - (SETQ STARTINGPAGE# (LISTGET PAGEPROPS 'STARTINGPAGE#)) - (* ; - "Grab a potential starting page number.") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ CH# STARTINGPAGE#) - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ CH# (ADD1 (CDR NEXTB))) - (IMAGEOBJPROP (CAR NEXTB) - 'STATE - (OR PAPERSIZE 'Letter)) - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ CH# (ADD1 (CDR NEXTB))) - [IMAGEOBJPROP (CAR NEXTB) - 'STATE - (COND - ((LISTGET PAGEPROPS 'LANDSCAPE?) - 'ON) - (T 'OFF] (* ; - "Tell whether the page is to be landscape or not.") - (SETQ FOLIOINFO (LISTGET PAGEPROPS 'FOLIOINFO)) - (* ; "Page number fomratting info") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ CH# (ADD1 (CDR NEXTB))) - [IMAGEOBJPROP (CAR NEXTB) - 'STATE - (COND - ((pop NEWLOOKS) - 'Yes) - (T 'No] - (SETQ BUTTON (CAR NEXTB)) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ (ADD1 (CDR NEXTB)) - (pop NEWLOOKS)) - (* ; "Page # X location") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop NEWLOOKS)) - (* ; "Page # Y location") - (SETQ PFONT (pop NEWLOOKS)) - (* ; "Skip the font info for now.") - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of - SCRATCHSEL - ] - (SETQ CH# (ADD1 (CDR NEXTB))) - (SETQ BUTTON (CAR NEXTB)) - (IMAGEOBJPROP BUTTON 'STATE (SELECTQ (pop FOLIOINFO) - (ARABIC 123) - (LOWERROMAN 'xiv) - (UPPERROMAN 'XIV) - 123)) - (* ; "The format for the page number") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ CH# (ADD1 (CDR NEXTB))) - (SETQ BUTTON (CAR NEXTB)) - (* ; "How to align the page number") - (IMAGEOBJPROP BUTTON 'STATE (SELECTQ (pop NEWLOOKS) - (LEFT 'Left) - (RIGHT 'Right) - (CENTERED 'Centered) - 'Centered)) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ CH# (pop FOLIOINFO)) - (* ; - "The text to surround the page number") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop FOLIOINFO)) - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop NEWLOOKS)) - (* ; "Left Margin") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop NEWLOOKS)) - (* ; "Right Margin") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop NEWLOOKS)) - (* ; "Top margin") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop NEWLOOKS)) - (* ; "Bottom Margin") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop NEWLOOKS)) - (* ; "# of columns") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop NEWLOOKS)) - (* ; "Column width") - (MBUTTON.SET.NEXT.FIELD TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (pop NEWLOOKS)) - (* ; "Intercolumn spacing") - (SETQ HEADINGS (pop NEWLOOKS)) - (for HEADING# from 1 to 8 - do - - (* ;; - "Insert info about up to 8 headings (the # of spots in the menu)") - - (SETQ HEADING (pop HEADINGS)) - (MBUTTON.SET.NEXT.FIELD - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL) - ) - (pop HEADING)) - (MBUTTON.SET.NEXT.FIELD - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL) - ) - (pop HEADING)) - (MBUTTON.SET.NEXT.FIELD - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL) - ) - (pop HEADING))) - (COND - (HEADINGS - - (* ;; - "There were headings left over, so warn user.") - - (PROMPTPRINT "WARNING: This document has more kinds of page heading than the menu has room for. Some will be lost if you APPLY this menu." - ))) - (\TEDIT.FILL.IN.CHARLOOKS.MENU TEXTOBJ - (ADD1 (fetch (SELECTION CH#) of SCRATCHSEL)) - (OR PFONT TEDIT.DEFAULT.FOLIO.LOOKS)) - (* ; - "The font for the page numbers to appear in.") - ]) - -(\TEDITPAGEMENU.CREATE - [LAMBDA NIL (* gbn " 8-Oct-84 18:25") - (* Creates the TEdit Expanded Menu) - (SETQ TEDIT.EXPANDED.PAGEMENU (\TEXTMENU.DOC.CREATE (APPEND TEDIT.PAGEMENU.SPEC - TEDIT.MENUDIVIDER.SPEC - [LIST (create MB.TEXT - MBSTRING _ - "Character Looks for Page Numbers: " - MBFONT _ - (FONTCREATE 'HELVETICA 10 - 'BOLD] - TEDIT.CHARLOOKSMENU.SPEC]) - -(\TEDIT.APPLY.PAGEFORMATTING - [LAMBDA (OBJ SEL W) (* ; - "Edited 4-Jun-93 12:04 by sybalsky:mv:envos") - -(* ;;; "Change the page formatting for this document") - - (PROG ((TEXTOBJ (fetch (SELECTION \TEXTOBJ) of SEL)) - (MAINTEXT (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'TEXTOBJ)) - (CH# (ADD1 (fetch (SELECTION CH#) of SEL))) - SCRATCHSEL NEXTB BUTTON OPAGEFRAMES PAGEID PX PY LEFT BOTTOM TOP RIGHT ALIGNMENT PAGENOS - COLS COLWIDTH INTERCOL PFONT NPAGEFORMAT HEADINGTYPE HEADINGX HEADINGY HEADINGS - HEADINGINVALID STARTINGPAGE# FOLIOFORMAT FOLIOPRETEXT FOLIOPOSTTEXT PAGEOPTIONS - NFPAGEFORMAT PAPERSIZE LANDSCAPE?) - (SETQ SCRATCHSEL (fetch (TEXTOBJ SCRATCHSEL) of TEXTOBJ)) - [SETQ CH# (ADD1 (CDR (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#] - (* ; "Skip the SHOW button.") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ CH# (ADD1 (CDR NEXTB))) - (SELECTQ (IMAGEOBJPROP (CAR NEXTB) - 'STATE) - (|First(&Default)| - (SETQ PAGEID 'FIRST)) - (Other% Left (SETQ PAGEID 'LEFT)) - (Other% Right (SETQ PAGEID 'RIGHT)) - (PROGN (TEDIT.PROMPTPRINT MAINTEXT "Set KIND OF PAGE before APPLYing." T) - (RETURN))) (* ; "Find which page, for later.") - (SETQ STARTINGPAGE# (AND (EQ PAGEID 'FIRST) - (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ CH#))) - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ CH# (ADD1 (CDR NEXTB))) - (SETQ PAPERSIZE (OR (IMAGEOBJPROP (CAR NEXTB) - 'STATE) - 'Letter)) (* ; - "Get the size of paper this is to be formatted for") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ CH# (ADD1 (CDR NEXTB))) - (SETQ LANDSCAPE? (EQ (IMAGEOBJPROP (CAR NEXTB) - 'STATE) - 'ON)) (* ; - "Decide if this kind of page is to be printed landscape....") - (SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ CH#)) - (SETQ CH# (ADD1 (CDR NEXTB))) - (SELECTQ (IMAGEOBJPROP (CAR NEXTB) - 'STATE) - (No (SETQ PAGENOS NIL)) - (Yes (SETQ PAGENOS T)) - NIL) (* ; "Find about page numbers") - (SETQ PX (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ CH#)) - [SETQ PY (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - [COND - (PAGENOS (* ; - "If he wants page numbers, make sure he said WHERE to put them.") - (COND - ((AND PX PY)) - (T (TEDIT.PROMPTPRINT MAINTEXT - "Please set the X and Y location for page numbers before APPLYing." - T) - (TEDIT.PROMPTFLASH MAINTEXT) - (RETURN] - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - (* ; - "Get to the numbering-format button") - (SETQ BUTTON (CAR NEXTB)) - (SETQ FOLIOFORMAT (SELECTQ (IMAGEOBJPROP BUTTON 'STATE) - (123 (* ; "arabic numbers") - 'ARABIC) - (xiv (* ; "lower-case roman numerals") - 'LOWERROMAN) - (XIV (* ; "Upper-case roman numerals") - 'UPPERROMAN) - 'ARABIC)) - [SETQ NEXTB (MBUTTON.FIND.NEXT.BUTTON TEXTOBJ (ADD1 (CDR NEXTB] - (* ; - "Get to the number alignment button") - (SETQ BUTTON (CAR NEXTB)) - [SETQ ALIGNMENT (U-CASE (IMAGEOBJPROP BUTTON 'STATE] - (* ; "PX PY PFONT ALIGNMENT") - (* ; - "Margins: LEFT, RIGHT, TOP, BOTTOM") - (SETQ CH# (ADD1 (CDR NEXTB))) - (SETQ FOLIOPRETEXT (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ CH#)) - [SETQ FOLIOPOSTTEXT (MBUTTON.NEXT.FIELD.AS.TEXT TEXTOBJ (ADD1 (fetch (SELECTION - CH#) - of SCRATCHSEL] - -(* ;;; "Now get the margins on the paper") - - [SETQ LEFT (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - [SETQ RIGHT (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - [SETQ TOP (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - [SETQ BOTTOM (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - (COND - [(SETQ COLS (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - (T (TEDIT.PROMPTPRINT MAINTEXT "Please specify how many columns there should be." T) - (TEDIT.PROMPTFLASH MAINTEXT))) - [SETQ COLWIDTH (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - [SETQ INTERCOL (MBUTTON.NEXT.FIELD.AS.NUMBER TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - (* ; "Col count, width, spacing") - (SETQ HEADINGS (for HEADING# from 1 to 8 - when (PROG1 [SETQ HEADINGTYPE (MBUTTON.NEXT.FIELD.AS.ATOM - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - [SETQ HEADINGX (MBUTTON.NEXT.FIELD.AS.NUMBER - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - [SETQ HEADINGY (MBUTTON.NEXT.FIELD.AS.NUMBER - TEXTOBJ - (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL]) - collect (COND - ((AND HEADINGX HEADINGY)) - (T (TEDIT.PROMPTPRINT MAINTEXT (CONCAT - "You need to say WHERE " - HEADINGTYPE - " headings go.") - T) - (TEDIT.PROMPTFLASH MAINTEXT) - (SETQ HEADINGINVALID T))) - (LIST HEADINGTYPE HEADINGX HEADINGY))) - (COND - (HEADINGINVALID (* ; "Headings invalid.") - (RETURN))) - [SETQ PFONT (\TEDIT.PARSE.CHARLOOKS.MENU TEXTOBJ (ADD1 (fetch (SELECTION CH#) - of SCRATCHSEL] - -(* ;;; "Glom all the oddball options (starting page, folio format &c) together") - - (SETQ PAGEOPTIONS (AND STARTINGPAGE# (LIST 'STARTINGPAGE# STARTINGPAGE#))) - (push PAGEOPTIONS (LIST FOLIOFORMAT FOLIOPRETEXT FOLIOPOSTTEXT)) - (push PAGEOPTIONS 'FOLIOINFO) - [COND - (LANDSCAPE? (* ; - "The pages are to be printed landscape. Remember that fact.") - (push PAGEOPTIONS T) - (push PAGEOPTIONS 'LANDSCAPE?] - (SETQ NPAGEFORMAT (TEDIT.SINGLE.PAGEFORMAT PAGENOS PX PY PFONT (AND (NEQ ALIGNMENT - 'OFF) - ALIGNMENT) - LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS 'PICAS - PAGEOPTIONS PAPERSIZE)) - (SETQ OPAGEFRAMES (fetch (TEXTOBJ TXTPAGEFRAMES) of MAINTEXT)) - [COND - ((NOT (LISTP OPAGEFRAMES)) - (COND - ((EQ PAGEID 'FIRST) (* ; - "Setting the first page sets them all") - (SETQ PAGEOPTIONS (COPY PAGEOPTIONS)) - (LISTPUT PAGEOPTIONS 'STARTINGPAGE# NIL) (* ; - "Starting page nubmer makes no sense on other than first pages.") - (SETQ NFPAGEFORMAT (TEDIT.SINGLE.PAGEFORMAT PAGENOS PX PY PFONT - (AND (NEQ ALIGNMENT 'OFF) - ALIGNMENT) - LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS - 'PICAS PAGEOPTIONS PAPERSIZE)) - (SETQ OPAGEFRAMES (LIST NPAGEFORMAT NFPAGEFORMAT NFPAGEFORMAT))) - (T (* ; - "Otherwise, start from the default page layout") - (SETQ OPAGEFRAMES (COPY TEDIT.PAGE.FRAMES] - (SELECTQ PAGEID - (FIRST (RPLACA OPAGEFRAMES NPAGEFORMAT)) - (LEFT (RPLACA (CDR OPAGEFRAMES) - NPAGEFORMAT)) - (RIGHT (RPLACA (CDDR OPAGEFRAMES) - NPAGEFORMAT)) - NIL) - (TEDIT.PAGEFORMAT MAINTEXT OPAGEFRAMES) - (replace (TEXTOBJ \DIRTY) of MAINTEXT with T) - (* ; - "Mark the document as having changed.") - (TTY.PROCESS (WINDOWPROP (WINDOWPROP W 'MAINWINDOW) - 'PROCESS]) - -(TEDIT.UNPARSE.PAGEFORMAT - [LAMBDA (PAGEREGION UNITS) (* ; "Edited 12-Jun-90 18:59 by mitani") - -(* ;;; "Take a page layout and unparse it into a PList of specs.") - - (LET* ((PAPER (fetch (PAGEREGION REGIONSPEC) of PAGEREGION)) - (PAPERWIDTH (fetch (REGION WIDTH) of PAPER)) - (PAPERHEIGHT (fetch (REGION HEIGHT) of PAPER)) - (REGIONS (fetch (PAGEREGION REGIONSUBBOXES) of PAGEREGION)) - PX PY PFONT PQUAD PINFO LEFT RIGHT TOP BOTTOM (COLS 0) - COLWIDTH - (INTERCOL 0) - SPECS PAGENOS (OLDRIGHT NIL) - SCALEFACTOR HEADINGS) - [for REGION in REGIONS - do - - (* ;; - "Run thru the regions on the page, calculating information about the page as a whole.") - - (COND - ((EQ (fetch (PAGEREGION REGIONFILLMETHOD) of REGION) - 'FOLIO) (* ; - "A page-number (%"Folio%") region") - (SETQ PAGENOS T) - (SETQ PX (fetch (REGION LEFT) of (fetch REGIONSPEC of REGION)) - ) - (SETQ PY (fetch (REGION BOTTOM) of (fetch REGIONSPEC of REGION - ))) - (SETQ SPECS (fetch REGIONLOCALINFO of REGION)) - (SETQ PFONT (LISTGET SPECS 'CHARLOOKS)) - [SETQ PQUAD (CADR (LISTGET SPECS 'PARALOOKS] - (SELECTQ PQUAD - (LEFT) - (RIGHT (SETQ PX (IPLUS PX 288))) - (CENTERED (SETQ PX (IPLUS PX 144))) - NIL)) - [(EQ (fetch (PAGEREGION REGIONFILLMETHOD) of REGION) - 'HEADING) (* ; "A page-heading region") - (SETQ HEADINGS (NCONC1 HEADINGS (LIST (LISTGET (fetch REGIONLOCALINFO - of REGION) - 'HEADINGTYPE) - (fetch (REGION LEFT) - of (fetch REGIONSPEC - of REGION)) - (fetch (REGION BOTTOM) - of (fetch REGIONSPEC - of REGION] - (T (* ; "A regular-text region.") - (add COLS 1) (* ; "Count columns") - (SETQ COLWIDTH (fetch (REGION WIDTH) of (fetch REGIONSPEC - of REGION))) - [SETQ RIGHT (IDIFFERENCE PAPERWIDTH (ADD1 (fetch (REGION RIGHT) - of (fetch REGIONSPEC - of REGION] - (COND - ((EQ OLDRIGHT T)) - (OLDRIGHT (SETQ INTERCOL (IDIFFERENCE (fetch (REGION LEFT) - of (fetch REGIONSPEC - of REGION)) - OLDRIGHT)) - (SETQ OLDRIGHT T)) - (T (SETQ OLDRIGHT (fetch (REGION RIGHT) of (fetch REGIONSPEC - of REGION))) - (SETQ LEFT (fetch (REGION LEFT) of (fetch REGIONSPEC - of REGION))) - [SETQ TOP (IDIFFERENCE PAPERHEIGHT (fetch (REGION PTOP) - of (fetch REGIONSPEC - of REGION] - (SETQ BOTTOM (fetch (REGION BOTTOM) of (fetch REGIONSPEC - of REGION] - (SELECTQ UNITS - ((POINTS NIL) (* If units are in printers points, - the default, do no scaling) - ) - (PICAS (* The units are in picas--12pts - per. Scale all values.) - (SETQ SCALEFACTOR 0.12)) - (INCHES (* The units are in inches, at - 72.27pts per. Set the scale factor) - (SETQ SCALEFACTOR 0.7227)) - (CM (* Units are in CM, at 72.27/2.54pts - per.) - (SETQ SCALEFACTOR (CONSTANT (FQUOTIENT 0.7227 2.54)))) - (\ILLEGAL.ARG UNITS)) - [COND - (SCALEFACTOR (* We need to do the scaling.) - (AND PX (SETQ PX (FQUOTIENT (FIXR (FQUOTIENT PX SCALEFACTOR)) - 100))) - (AND PY (SETQ PY (FQUOTIENT (FIXR (FQUOTIENT PY SCALEFACTOR)) - 100))) - (AND LEFT (SETQ LEFT (FQUOTIENT (FIXR (FQUOTIENT LEFT SCALEFACTOR)) - 100))) - (AND RIGHT (SETQ RIGHT (FQUOTIENT (FIXR (FQUOTIENT RIGHT SCALEFACTOR)) - 100))) - (AND TOP (SETQ TOP (FQUOTIENT (FIXR (FQUOTIENT TOP SCALEFACTOR)) - 100))) - (AND BOTTOM (SETQ BOTTOM (FQUOTIENT (FIXR (FQUOTIENT BOTTOM SCALEFACTOR)) - 100))) - (AND COLWIDTH (SETQ COLWIDTH (FQUOTIENT (FIXR (FQUOTIENT COLWIDTH SCALEFACTOR)) - 100))) - (AND INTERCOL (SETQ INTERCOL (FQUOTIENT (FIXR (FQUOTIENT INTERCOL SCALEFACTOR)) - 100))) - (SETQ HEADINGS (for HDG in HEADINGS - collect (LIST (CAR HDG) - (FQUOTIENT (FIXR (FQUOTIENT (CADR HDG) - SCALEFACTOR)) - 100) - (FQUOTIENT (FIXR (FQUOTIENT (CADDR HDG) - SCALEFACTOR)) - 100] - (LIST PAGENOS PX PY PFONT PQUAD LEFT RIGHT TOP BOTTOM COLS COLWIDTH INTERCOL HEADINGS - (fetch (PAGEREGION REGIONLOCALINFO) of PAGEREGION]) -) - - - -(* ; "Initialization Code") - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS TEDIT.EXPANDED.MENU TEDIT.EXPANDEDPARA.MENU TEDIT.CHARLOOKS.MENU TEDIT.MENUDIVIDER.SPEC - TEDIT.EXPANDEDMENU.SPEC TEDIT.CHARLOOKSMENU.SPEC TEDIT.PARAMENU.SPEC TEDIT.PAGEMENU.SPEC - TEDIT.EXPANDED.PAGEMENU) -) -(DEFINEQ - -(\TEDIT.MENU.INIT - [LAMBDA NIL (* ; "Edited 30-Mar-94 15:53 by jds") - -(* ;;; "Initialize the descriptions for all TEdit menus") - -(* ;;; "Divides between the main page layout menu and page-# font submenu") - - (SETQ TEDIT.MENUDIVIDER.SPEC (LIST (create MB.TEXT - MBSTRING _ " - -"))) - -(* ;;; "The principal expanded menu") - - (SETQ TEDIT.EXPANDEDMENU.SPEC (LIST (create MB.BUTTON - MBLABEL _ "Quit") - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ "Page Layout") - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ "Char Looks") - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ "Para Looks") - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ "All") - (create MB.TEXT - MBSTRING _ " ") - (create MB.TOGGLE - MBTEXT _ "Unformatted" - MBCHANGESTATEFN _ (FUNCTION - \TEDITMENU.RECORD.UNFORMATTED)) - (create MB.TEXT - MBSTRING _ " -") - (create MB.BUTTON - MBLABEL _ "Get") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ "Put") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ "Include") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " -") - (create MB.BUTTON - MBLABEL _ "Find") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ "Substitute") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " for") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " ") - (create MB.TOGGLE - MBTEXT _ "Confirm") - (create MB.TEXT - MBSTRING _ " ") - (create MB.TOGGLE - MBTEXT _ "Use New Looks") - (create MB.TEXT - MBSTRING _ " -") - (create MB.BUTTON - MBLABEL _ "Hardcopy") - (create MB.TEXT - MBSTRING _ " server:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " copies:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " -") - (create MB.TEXT - MBSTRING _ "Print ") - (create MB.NWAY - MBBUTTONS _ '(One% Side Duplex) - MBMAXITEMSPERLINE _ 5) - (create MB.TEXT - MBSTRING _ " Message/Phone#:") - (create MB.INSERT))) - -(* ;;; "The character-looks (font, etc.) menu") - - (SETQ TEDIT.CHARLOOKSMENU.SPEC (LIST (create MB.TEXT - MBSTRING _ "Props: " - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.3STATE - MBLABEL _ 'Bold) - (create MB.TEXT - MBSTRING _ " ") - (create MB.3STATE - MBLABEL _ 'Italic) - (create MB.TEXT - MBSTRING _ " ") - (create MB.3STATE - MBLABEL _ 'Underline) - (create MB.TEXT - MBSTRING _ " ") - (create MB.3STATE - MBLABEL _ 'StrikeThru) - (create MB.TEXT - MBSTRING _ " ") - (create MB.3STATE - MBLABEL _ 'Overbar) - (create MB.TEXT - MBSTRING _ " -") - (create MB.NWAY - MBBUTTONS _ - '(TimesRoman Helvetica Gacha Modern Classic Terminal - Other) - MBMAXITEMSPERLINE _ 5) - (create MB.TEXT - MBSTRING _ "other font:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " -") - (create MB.TEXT - MBSTRING _ "Size: " - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " ") - (create MB.NWAY - MBBUTTONS _ '(Normal Superscript Subscript)) - (create MB.TEXT - MBSTRING _ " distance: " - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.INSERT))) - -(* ;;; "The paragraph-formatting menu (margins, etc.)") - - (SETQ TEDIT.PARAMENU.SPEC (LIST (create MB.BUTTON - MBLABEL _ 'APPLY - MBBUTTONEVENTFN _ (FUNCTION \TEDIT.APPLY.PARALOOKS)) - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ 'SHOW - MBBUTTONEVENTFN _ (FUNCTION \TEDIT.SHOW.PARALOOKS)) - (create MB.TEXT - MBSTRING _ " ") - (create MB.BUTTON - MBLABEL _ 'NEUTRAL - MBBUTTONEVENTFN _ (FUNCTION - \TEDIT.NEUTRALIZE.PARALOOKS.MENU)) - (create MB.TEXT - MBSTRING _ " -") - (create MB.NWAY - MBBUTTONS _ '(Left Right Centered Justified)) - (create MB.TEXT - MBSTRING _ " ") - (create MB.3STATE - MBLABEL _ "Page Heading") - (create MB.TEXT - MBSTRING _ " type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " -Line leading:" - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ "pts Para Leading:" - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ "pts Special Locn: X" - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ "picas, Y" - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ "picas -New Page: " - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.3STATE - MBLABEL _ "Before") - (create MB.TEXT - MBSTRING _ " ") - (create MB.3STATE - MBLABEL _ "After") - (create MB.TEXT - MBSTRING _ " Display mode: " - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.3STATE - MBLABEL _ "Hardcopy") - (create MB.TEXT - MBSTRING _ " Keep: " - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.3STATE - MBLABEL _ "Heading") - (create MB.TEXT - MBSTRING _ " -Tab Type: " - MBFONT _ (FONTCREATE 'HELVETICA 8)) - [create MB.NWAY - MBBUTTONS _ '((Left \TEDIT.TABTYPE.SET) - (Right \TEDIT.TABTYPE.SET) - (Centered \TEDIT.TABTYPE.SET) - (Decimal \TEDIT.TABTYPE.SET] - (create MB.TEXT - MBSTRING _ " ") - (create MB.TOGGLE - MBTEXT _ "Dotted Leader" - MBCHANGESTATEFN _ (FUNCTION \TEDIT.RECORD.TABLEADERS)) - (create MB.TEXT - MBSTRING _ " Default Tab Size:" - MBFONT _ (FONTCREATE 'HELVETICA 8)) - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " -") - (create MB.MARGINBAR) - (create MB.TEXT - MBSTRING _ " -"))) - -(* ;;; "Page-layout menu for columns, page headings, page numbers, etc.") - - (SETQ TEDIT.PAGEMENU.SPEC (APPEND (LIST (create MB.BUTTON - MBLABEL _ 'APPLY - MBBUTTONEVENTFN _ '\TEDIT.APPLY.PAGEFORMATTING) - (create MB.TEXT - MBSTRING _ " " - MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD)) - (create MB.BUTTON - MBLABEL _ 'SHOW - MBBUTTONEVENTFN _ '\TEDIT.SHOW.PAGEFORMATTING) - (create MB.TEXT - MBSTRING _ " -") - (create MB.TEXT - MBSTRING _ "For page: ") - (create MB.NWAY - MBBUTTONS _ '(|First(&Default)| Other% Left - Other% Right)) - (create MB.TEXT - MBSTRING _ " - Starting Page #: ") - (create MB.INSERT - MBINITENTRY _ 1) - (create MB.TEXT - MBSTRING _ " Paper Size: ") - (create MB.NWAY - MBBUTTONS _ '(Letter Legal A4) - MBINITSTATE _ 'Letter) - (create MB.TEXT - MBSTRING _ " ") - (create MB.TOGGLE - MBTEXT _ "Landscape") - (create MB.TEXT - MBSTRING _ " - -") - (create MB.TEXT - MBSTRING _ "Page numbers: ") - (create MB.TEXT - MBSTRING _ " " - MBFONT _ (FONTCREATE 'HELVETICA 8 'BOLD)) - (create MB.NWAY - MBBUTTONS _ '(No Yes) - MBINITSTATE _ 'Yes) - (create MB.TEXT - MBSTRING _ " ") - (create MB.TEXT - MBSTRING _ "X: ") - (create MB.INSERT - MBINITENTRY _ 25.5) - (create MB.TEXT - MBSTRING _ " ") - (create MB.TEXT - MBSTRING _ "Y: ") - (create MB.INSERT - MBINITENTRY _ 3) - (create MB.TEXT - MBSTRING _ " Format: ") - (create MB.NWAY - MBBUTTONS _ '(123 xiv XIV) - MBINITSTATE _ '123) - (create MB.TEXT - MBSTRING _ " - ") - (create MB.TEXT - MBSTRING _ "Alignment: ") - (create MB.NWAY - MBBUTTONS _ '(Left Centered Right) - MBINITSTATE _ 'Centered) - (create MB.TEXT - MBSTRING _ " -") - (create MB.TEXT - MBSTRING _ " Text before number: ") - (create MB.INSERT - MBINITENTRY _ "") - (create MB.TEXT - MBSTRING _ " Text after number: ") - (create MB.INSERT - MBINITENTRY _ "") - (create MB.TEXT - MBSTRING _ " -")) - (LIST (create MB.TEXT - MBSTRING _ "Margins: Left") - (create MB.INSERT - MBINITENTRY _ 6) - (create MB.TEXT - MBSTRING _ " Right") - (create MB.INSERT - MBINITENTRY _ 6) - (create MB.TEXT - MBSTRING _ " Top") - (create MB.INSERT - MBINITENTRY _ 6) - (create MB.TEXT - MBSTRING _ " Bottom") - (create MB.INSERT - MBINITENTRY _ 6) - (create MB.TEXT - MBSTRING _ " -") - (create MB.TEXT - MBSTRING _ "Columns: ") - (create MB.INSERT - MBINITENTRY _ 1) - (create MB.TEXT - MBSTRING _ " Col Width: ") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Space between cols: ") - (create MB.INSERT - MBINITENTRY _ 1) - (create MB.TEXT - MBSTRING _ " -") - (create MB.TEXT - MBSTRING _ "Page Headings:" - MBFONT _ (FONTCREATE 'HELVETICA 10 'BOLD)) - (create MB.TEXT - MBSTRING _ " - Heading Type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " X:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Y:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Heading Type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " X:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Y:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " - Heading Type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " X:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Y:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Heading Type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " X:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Y:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " - Heading Type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " X:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Y:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Heading Type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " X:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Y:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " - Heading Type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " X:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Y:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Heading Type:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " X:") - (create MB.INSERT) - (create MB.TEXT - MBSTRING _ " Y:") - (create MB.INSERT]) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(\TEDIT.MENU.INIT) - -(\TEDITMENU.CREATE) - -(\TEDIT.CHARLOOKSMENU.CREATE) - -(\TEDITPARAMENU.CREATE) - -(\TEDITPAGEMENU.CREATE) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA ) -) -(PUTPROPS TEDITMENU COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 -1991 1992 1993 1994 1995)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (6299 33141 (MB.BUTTONEVENTINFN 6309 . 7640) (MB.DISPLAY 7642 . 10010) (MB.SETIMAGE -10012 . 10970) (MB.SELFN 10972 . 12387) (MB.SIZEFN 12389 . 13406) (MB.WHENOPERATEDFN 13408 . 13740) ( -MB.COPYFN 13742 . 14204) (MB.GETFN 14206 . 14814) (MB.PUTFN 14816 . 15593) (MB.SHOWSELFN 15595 . 16567 -) (MBUTTON.CREATE 16569 . 17853) (MBUTTON.CHANGENAME 17855 . 18250) (MBUTTON.FIND.BUTTON 18252 . 19268 -) (MBUTTON.FIND.NEXT.BUTTON 19270 . 20665) (MBUTTON.FIND.NEXT.FIELD 20667 . 24381) (MBUTTON.INIT 24383 - . 25173) (MBUTTON.NEXT.FIELD.AS.NUMBER 25175 . 25528) (MBUTTON.NEXT.FIELD.AS.PIECES 25530 . 25960) ( -MBUTTON.NEXT.FIELD.AS.TEXT 25962 . 26384) (MBUTTON.NEXT.FIELD.AS.ATOM 26386 . 27259) ( -MBUTTON.SET.FIELD 27261 . 29317) (MBUTTON.SET.NEXT.FIELD 29319 . 30536) (MBUTTON.SET.NEXT.BUTTON.STATE - 30538 . 31034) (TEDITMENU.STREAM 31036 . 31645) (\TEDITMENU.SELSCREENER 31647 . 33139)) (33445 43868 -(MB.CREATE.THREESTATEBUTTON 33455 . 34626) (MB.THREESTATE.DISPLAY 34628 . 37218) ( -MB.THREESTATE.SHOWSELFN 37220 . 40322) (MB.THREESTATE.WHENOPERATEDFN 40324 . 41703) ( -MB.THREESTATEBUTTON.FN 41705 . 42802) (THREESTATE.INIT 42804 . 43866)) (43969 63205 ( -MB.CREATE.NWAYBUTTON 43979 . 47947) (MB.NB.DISPLAYFN 47949 . 50221) (MB.NB.WHENOPERATEDFN 50223 . -51255) (MB.NB.SIZEFN 51257 . 54796) (MB.NWAYBUTTON.SELFN 54798 . 56742) (MB.NWAYMENU.NEWBUTTON 56744 - . 57330) (NWAYBUTTON.INIT 57332 . 58185) (MB.NB.PACKITEMS 58187 . 60184) (MB.NWAYBUTTON.ADDITEM 60186 - . 63203)) (63459 74107 (\TEXTMENU.TOGGLE.CREATE 63469 . 64870) (\TEXTMENU.TOGGLE.DISPLAY 64872 . -67224) (\TEXTMENU.TOGGLE.SHOWSELFN 67226 . 69588) (\TEXTMENU.TOGGLE.WHENOPERATEDFN 69590 . 70978) ( -\TEXTMENU.TOGGLEFN 70980 . 72060) (\TEXTMENU.TOGGLE.INIT 72062 . 72897) (\TEXTMENU.SET.TOGGLE 72899 . -74105)) (74359 111675 (DRAWMARGINSCALE 74369 . 77913) (MARGINBAR 77915 . 85285) (MARGINBAR.CREATE -85287 . 88197) (MB.MARGINBAR.SELFN 88199 . 100793) (MB.MARGINBAR.SIZEFN 100795 . 101157) ( -MB.MARGINBAR.DISPLAYFN 101159 . 103844) (MDESCALE 103846 . 104285) (MSCALE 104287 . 104621) ( -MB.MARGINBAR.SHOWTAB 104623 . 106794) (MB.MARGINBAR.TABTRACK 106796 . 108131) (\TEDIT.TABTYPE.SET -108133 . 110784) (MARGINBAR.INIT 110786 . 111673)) (112692 130294 (\TEXTMENU.START 112702 . 115894) ( -\TEXTMENU.DOC.CREATE 115896 . 127420) (TEXTMENU.CLOSEFN 127422 . 130292)) (130604 150668 ( -\TEDITMENU.CREATE 130614 . 130914) (\TEDIT.EXPANDED.MENU 130916 . 131620) (MB.DEFAULTBUTTON.FN 131622 - . 134494) (\TEDITMENU.RECORD.UNFORMATTED 134496 . 134834) (MB.DEFAULTBUTTON.ACTIONFN 134836 . 150666) -) (150669 178052 (\TEDIT.CHARLOOKSMENU.CREATE 150679 . 152819) (\TEDIT.EXPANDEDCHARLOOKS.MENU 152821 - . 153195) (\TEDIT.APPLY.BOLDNESS 153197 . 153482) (\TEDIT.APPLY.CHARLOOKS 153484 . 155415) ( -\TEDIT.APPLY.OLINE 155417 . 155698) (\TEDIT.SHOW.CHARLOOKS 155700 . 157613) ( -\TEDIT.NEUTRALIZE.CHARLOOKS 157615 . 158541) (\TEDIT.FILL.IN.CHARLOOKS.MENU 158543 . 166196) ( -\TEDIT.NEUTRALIZE.CHARLOOKS.MENU 166198 . 169081) (\TEDIT.PARSE.CHARLOOKS.MENU 169083 . 177191) ( -\TEDIT.APPLY.SLOPE 177193 . 177476) (\TEDIT.APPLY.STRIKEOUT 177478 . 177765) (\TEDIT.APPLY.ULINE -177767 . 178050)) (178053 210119 (\TEDITPARAMENU.CREATE 178063 . 178443) (\TEDIT.EXPANDEDPARA.MENU -178445 . 178765) (\TEDIT.APPLY.PARALOOKS 178767 . 190997) (\TEDIT.SHOW.PARALOOKS 190999 . 202526) ( -\TEDIT.NEUTRALIZE.PARALOOKS.MENU 202528 . 208599) (\TEDIT.RECORD.TABLEADERS 208601 . 210117)) (210120 -248122 (\TEDIT.SHOW.PAGEFORMATTING 210130 . 226670) (\TEDITPAGEMENU.CREATE 226672 . 227715) ( -\TEDIT.APPLY.PAGEFORMATTING 227717 . 240088) (TEDIT.UNPARSE.PAGEFORMAT 240090 . 248120)) (248427 -275166 (\TEDIT.MENU.INIT 248437 . 275164))))) -STOP diff --git a/obsolete/library/new/TEDITMENU.LCOM b/obsolete/library/new/TEDITMENU.LCOM deleted file mode 100644 index 71e6d330..00000000 Binary files a/obsolete/library/new/TEDITMENU.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITPAGE.LCOM b/obsolete/library/new/TEDITPAGE.LCOM deleted file mode 100644 index 96cfdc66..00000000 Binary files a/obsolete/library/new/TEDITPAGE.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITSCREEN.LCOM b/obsolete/library/new/TEDITSCREEN.LCOM deleted file mode 100644 index e149404f..00000000 Binary files a/obsolete/library/new/TEDITSCREEN.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITSELECTION.LCOM b/obsolete/library/new/TEDITSELECTION.LCOM deleted file mode 100644 index 17e5bd16..00000000 Binary files a/obsolete/library/new/TEDITSELECTION.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEDITWINDOW.LCOM b/obsolete/library/new/TEDITWINDOW.LCOM deleted file mode 100644 index ffe17150..00000000 Binary files a/obsolete/library/new/TEDITWINDOW.LCOM and /dev/null differ diff --git a/obsolete/library/new/TEXTOFD b/obsolete/library/new/TEXTOFD deleted file mode 100644 index cfd036b0..00000000 --- a/obsolete/library/new/TEXTOFD +++ /dev/null @@ -1,2637 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Apr-95 15:12:29" {DSK}library>new>TEXTOFD.;2 172919 - - changes to%: (FNS COPYTEXTSTREAM \DELETECH \INSERTCH) - - previous date%: "22-Mar-95 18:08:35" {DSK}library>new>TEXTOFD.;1) - - -(* ; " -Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1995 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 31-May-91 13:57 by jds") - - (* ;; "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 22-Mar-95 16:32 by sybalsky:mv:envos") - - (* ;; "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 _ PCLST))) - (* ; - "Add this event to the history list") - (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))) - (COND - (PC1 (replace (PIECE NEXTPIECE) of PC1 with HIPC))) - (COND - (HIPC (replace (PIECE PREVPIECE) of HIPC with PC1))) - (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 14-Apr-93 17:14 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] - (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 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)) - (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 22-Mar-95 16:44 by sybalsky:mv:envos") - - (* ;; "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 _ (LIST \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 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)) - (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] - (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 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 (DSPXPOSITION NIL WINDOW) - ELSE (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) - (CHARWIDTH CHARCODE (DSPFONT NIL STREAM]) - -(\TEXTDSPSTRINGWIDTH - [LAMBDA (STREAM STRING) - (STRINGWIDTH STRING (DSPFONT NIL STREAM]) - -(\TEXTDSPLINEFEED - [LAMBDA (STREAM VALUE) - (FONTPROP (DSPFONT NIL STREAM) - 'HEIGHT]) -) -(DEFINEQ - -(\TEXTBIN - [LAMBDA (STREAM) (* ; "Edited 28-Mar-94 15:33 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 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 (SELECTQ OPERATION - (PEEKBIN (\PEEKBIN PF NOERRORFLG)) - (BIN (\BIN PF)) - (\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 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) - '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 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) - '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)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3000 52200 (COPYTEXTSTREAM 3010 . 6076) (OPENTEXTSTREAM 6078 . 20955) (REOPENTEXTSTREAM - 20957 . 21379) (TEDIT.STREAMCHANGEDP 21381 . 21679) (TEXTSTREAMP 21681 . 21995) (TXTFILE 21997 . -22442) (\DELETECH 22444 . 33252) (\SETUPGETCH 33254 . 40533) (\TEDIT.REOPEN.STREAM 40535 . 42045) ( -\TEDIT.COPYTEXTSTREAM.PIECEMAPFN 42047 . 44485) (\TEXTINIT 44487 . 50093) (\TEXTMARK 50095 . 50843) ( -\TEXTTTYBOUT 50845 . 52198)) (52201 77694 (\INSERTCH 52211 . 75998) (\INSERTCR 76000 . 77692)) (77760 -97944 (\CHTOPC 77770 . 78959) (\CHTOPCNO 78961 . 80223) (\CLEARPCTB 80225 . 81021) ( -\CREATEPIECEORSTREAM 81023 . 83865) (\DELETEPIECE 83867 . 84780) (\FINDPIECE 84782 . 85148) ( -\INSERTPIECE 85150 . 88160) (\MAKEPCTB 88162 . 90077) (\SPLITPIECE 90079 . 97038) (\INSERT.FIRST.PIECE - 97040 . 97942)) (97996 121422 (\TEXTCLOSEF 98006 . 99233) (\TEXTCLOSEF-SUBTREE 99235 . 99941) ( -\TEXTDSPFONT 99943 . 100935) (\TEXTEOFP 100937 . 102296) (\TEXTGETEOFPTR 102298 . 102508) ( -\TEXTGETFILEPTR 102510 . 104573) (\TEXTOPENF 104575 . 105405) (\TEXTOPENF-SUBTREE 105407 . 106208) ( -\TEXTOUTCHARFN 106210 . 106558) (\TEXTBACKFILEPTR 106560 . 112461) (\TEXTBOUT 112463 . 115811) ( -\TEDITOUTCHARFN 115813 . 117059) (\TEXTSETEOF 117061 . 117570) (\TEXTSETFILEPTR 117572 . 118797) ( -\TEXTDSPXPOSITION 118799 . 119250) (\TEXTDSPYPOSITION 119252 . 119797) (\TEXTLEFTMARGIN 119799 . -120282) (\TEXTRIGHTMARGIN 120284 . 121120) (\TEXTDSPCHARWIDTH 121122 . 121218) (\TEXTDSPSTRINGWIDTH -121220 . 121316) (\TEXTDSPLINEFEED 121318 . 121420)) (121423 153726 (\TEXTBIN 121433 . 138219) ( -\TEDIT.TEXTBIN.STRINGSETUP 138221 . 143934) (\TEDIT.TEXTBIN.FILESETUP 143936 . 149438) ( -\TEDIT.TEXTBIN.NEW.PAGE 149440 . 153724)) (153727 167010 (\TEXTPEEKBIN 153737 . 162876) ( -\TEDIT.PEEKBIN.NEW.PAGE 162878 . 167008)) (167048 172266 (CGETTEXTPROP 167058 . 167534) (CTEXTPROP -167536 . 169880) (GETTEXTPROP 169882 . 170477) (PUTTEXTPROP 170479 . 171804) (TEXTPROP 171806 . 172264 -))))) -STOP diff --git a/obsolete/library/new/TEXTOFD.LCOM b/obsolete/library/new/TEXTOFD.LCOM deleted file mode 100644 index 563ba393..00000000 Binary files a/obsolete/library/new/TEXTOFD.LCOM and /dev/null differ diff --git a/obsolete/library/patches/NEW-SKETCH-COLOR b/obsolete/library/patches/NEW-SKETCH-COLOR deleted file mode 100644 index 794a62e0..00000000 --- a/obsolete/library/patches/NEW-SKETCH-COLOR +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "23-Jul-90 18:28:51" {DSK}peach>matsuda>NEW-SKETCH-COLOR.;2 32679 previous date%: "23-Jul-90 17:49:19" {DSK}peach>matsuda>NEW-SKETCH-COLOR.;1) (* ; " Copyright (c) 1990 by Fuji Xerox Co., Ltd. All rights reserved. ") (PRETTYCOMPRINT NEW-SKETCH-COLORCOMS) (RPAQQ NEW-SKETCH-COLORCOMS [(P (MOVD 'CIRCLE.DRAWFN 'ORG.CIRCLE.DRAWFN) (MOVD 'CLOSED.WIRE.DRAWFN 'ORG.CLOSED.WIRE.DRAWFN) (MOVD 'BOX.DRAWFN1 'ORG.BOX.DRAWFN1) (SETQ SKETCHINCOLORFLG T)) (FNS \BBTCURVEPT BMOBJ.DISPLAYFN BITMAPOBJ.SNAPW OPPOSITECOLOR \SCALEDBITBLT.DISPLAY BITMAPELT.INPUTFN GET.BITMAP.POSITION BOX.DRAWFN1 CIRCLE.DRAWFN CLOSED.WIRE.DRAWFN SKETCHINCOLORP NEW.READCOLOR1 SK.FIGUREIMAGE) (P (MOVD 'READCOLOR1 'ORG.READCOLOR1) (MOVD 'NEW.READCOLOR1 'READCOLOR1) (REPLACE (IMAGEOPS IMFILLPOLYGON) OF \8DISPLAYIMAGEOPS WITH (FUNCTION POLYSHADE.DISPLAY)) (REPLACE (IMAGEOPS IMSCALEDBITBLT) OF \8DISPLAYIMAGEOPS WITH (FUNCTION \SCALEDBITBLT.DISPLAY]) (MOVD 'CIRCLE.DRAWFN 'ORG.CIRCLE.DRAWFN) (MOVD 'CLOSED.WIRE.DRAWFN 'ORG.CLOSED.WIRE.DRAWFN) (MOVD 'BOX.DRAWFN1 'ORG.BOX.DRAWFN1) (SETQ SKETCHINCOLORFLG T) (DEFINEQ (\BBTCURVEPT [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA) (* ; "Edited 24-May-90 10:03 by matsuda") (* ;; "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] (COND ((NEQ (ffetch DDOPERATION of DISPLAYDATA) 'INVERT) (* ;  "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) (ffetch DDOPERATION of DISPLAYDATA))) (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]) (BMOBJ.DISPLAYFN [LAMBDA (IMAGEOBJ IMAGE.STREAM) (* ; "Edited 18-Apr-90 16:28 by matsuda") (* ;; "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") (SCALEDBITBLT BITMAP 0 0 IMAGE.STREAM (DSPXPOSITION NIL IMAGE.STREAM) (DSPYPOSITION NIL IMAGE.STREAM) (BITMAPWIDTH BITMAP) (BITMAPHEIGHT BITMAP) 'INPUT 'PAINT NIL NIL FACTOR]) (BITMAPOBJ.SNAPW [LAMBDA NIL (* ; "Edited 12-Apr-90 09:09 by matsuda") (* * makes an image object of a prompted for region of the screen.) (PROG ((REG (GETREGION)) BM) [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG) (BITSPERPIXEL (SCREENBITMAP \CURSORSCREEN] (BITBLT (SCREENBITMAP \CURSORSCREEN) (fetch (REGION LEFT) of REG) (fetch (REGION BOTTOM) of REG) BM 0 0 NIL NIL 'INPUT 'REPLACE) (COPYINSERT (BITMAPTEDITOBJ BM 1 0)) (RETURN]) (OPPOSITECOLOR [LAMBDA (COLOR BITSPERPIXEL) (* ; "Edited 23-May-90 15:05 by matsuda") (IDIFFERENCE (MAXIMUMCOLOR BITSPERPIXEL) (COLORNUMBERP COLOR BITSPERPIXEL]) (\SCALEDBITBLT.DISPLAY [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM SCALE) (* ; "Edited 22-May-90 15:02 by matsuda") (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)) (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT (FETCH SCBITSPERPIXEL OF \CURSORSCREEN))) (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]) (BITMAPELT.INPUTFN [LAMBDA (WINDOW) (* ; "Edited 22-May-90 12:56 by matsuda") (* gets a region of the screen and  makes it a scalable bitmap.) (PROG ((REGION (GETREGION 4 4)) BM POS) (OR (REGIONP REGION) (RETURN)) (SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) (FETCH SCBITSPERPIXEL OF \CURSORSCREEN))) (BITBLT (SCREENBITMAP \CURSORSCREEN) (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) BM 0 0 (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION)) (OR (SETQ POS (GET.BITMAP.POSITION WINDOW BM NIL "Place the bitmap image.")) (RETURN)) (RETURN (SK.BITMAP.CREATE BM (SK.MAP.INPUT.PT.TO.GLOBAL POS WINDOW) (VIEWER.SCALE WINDOW]) (GET.BITMAP.POSITION [LAMBDA (WINDOW BITMAP OPERATION MSG XOFFSET YOFFSET)(* ; "Edited 22-May-90 12:53 by matsuda") (* gets a position by tracking with a bitmap The spec returns is actually  (ONGRID? position) so that caller can tell whether it was placed on grid or  not.) (PROG (BUFFER.BITMAP WIDTH HEIGHT) (SETQ WIDTH (BITMAPWIDTH BITMAP)) (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) (SETQ BUFFER.BITMAP (BITMAPCREATE WIDTH HEIGHT (FETCH SCBITSPERPIXEL OF \CURSORSCREEN ))) (STATUSPRINT WINDOW " " MSG) (RETURN (SK.TRACK.BITMAP1 WINDOW BITMAP BUFFER.BITMAP WIDTH HEIGHT (OR OPERATION 'PAINT) XOFFSET YOFFSET]) (BOX.DRAWFN1 [LAMBDA (REG SIZE WIN WINREG OPERATION DASHING TEXTURE OUTLINECOLOR FILLINGCOLOR) (* ; "Edited 25-May-90 14:18 by matsuda") (* draws a box. Used by both box and  text box elements.) (COND ((OR (NULL WINREG) (REGIONSINTERSECTP WINREG REG)) (COND ((AND (SKETCHINCOLORP) (OR FILLINGCOLOR TEXTURE)) (* call the filling routine that  does color.) (FILLPOLYGON (KNOTS.OF.REGION REG SIZE) 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]) (CIRCLE.DRAWFN [LAMBDA (CIRCLEELT WINDOW REGION) (* ; "Edited 25-May-90 15:36 by matsuda") (* 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) (fetch (SKFILLING FILLING.COLOR) of 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]) (CLOSED.WIRE.DRAWFN [LAMBDA (CLOSEDWIREELT WIN REG OPERATION) (* ; "Edited 25-May-90 15:26 by matsuda") (* 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 ((fetch (SKFILLING FILLING.COLOR) of VARX)) ((SKETCHINCOLORP) 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]) (SKETCHINCOLORP [LAMBDA NIL (* ; "Edited 25-May-90 14:00 by matsuda") (* hook to determine if sketch  should allow color.) (AND SKETCHINCOLORFLG (IGREATERP (FETCH SCBITSPERPIXEL OF \CURSORSCREEN) 1]) (NEW.READCOLOR1 [LAMBDA (MSG ALLOWNONEFLG NOWCOLOR) (* ; "Edited 25-May-90 10:05 by matsuda") (LET ((INITCOLOR (AND NOWCOLOR (INSURE.RGB.COLOR NOWCOLOR T))) COLORINDEX) (SETQ COLORINDEX (PAINTW.READBRUSHTEXTURE)) (COND ((NULL COLORINDEX) INITCOLOR) ((INSURE.RGB.COLOR (ELT (SCREENCOLORMAP NIL) COLORINDEX))) (T INITCOLOR]) (SK.FIGUREIMAGE [LAMBDA (SCRITEMS LIMITREGION REGIONOFINTEREST) (* ; "Edited 22-May-90 13:23 by matsuda") (* returns a bitmap which contains the image of the elements on SCRITEMS.  And a lower left corner.) (RESETFORM (CURSOR WAITINGCURSOR) (PROG (REGION DSPSTREAM BITMAP LEFT BOTTOM LIMITDIM) (COND ((NULL SCRITEMS) (RETURN))) [COND ((SCREENELEMENTP SCRITEMS) (* single item case.) (SETQ REGION (SK.ITEM.REGION SCRITEMS))) (T (SETQ REGION (SK.ITEM.REGION (CAR SCRITEMS))) [for SCITEM in (CDR SCRITEMS) do (SETQ REGION (SK.UNIONREGIONS REGION (SK.ITEM.REGION SCITEM] (* order the elements by priority) (SETQ SCRITEMS (REVERSE (SK.SORT.ELTS.BY.PRIORITY SCRITEMS] (* only some of the points are being  moved, reduce the region to those.) (AND REGIONOFINTEREST (SETQ REGION (OR (INTERSECTREGIONS REGION REGIONOFINTEREST) REGION))) [COND (LIMITREGION (* limit the size of the bitmap. This is used by copy insert functions that do  not know how big the thing coming in is.) (COND ((GREATERP (fetch (REGION WIDTH) of REGION) (SETQ LIMITDIM (fetch (REGION WIDTH) of LIMITREGION))) (* reduce the width picking out the  middle of the region) (replace (REGION LEFT) of REGION with (PLUS (fetch (REGION LEFT) of REGION) (QUOTIENT (DIFFERENCE LIMITDIM (fetch (REGION WIDTH) of REGION)) 2))) (replace (REGION WIDTH) of REGION with LIMITDIM))) (COND ((GREATERP (fetch (REGION HEIGHT) of REGION) (SETQ LIMITDIM (fetch (REGION HEIGHT) of LIMITREGION))) (* reduce the height picking out the  middle of the region) (replace (REGION BOTTOM) of REGION with (PLUS (fetch (REGION BOTTOM) of REGION) (QUOTIENT (DIFFERENCE LIMITDIM (fetch (REGION HEIGHT) of REGION)) 2))) (replace (REGION HEIGHT) of REGION with LIMITDIM] (* ADD1 is used to convert the  possibly floating region coordinates  into fixed.) [SETQ DSPSTREAM (DSPCREATE (SETQ BITMAP (BITMAPCREATE (ADD1 (fetch (REGION WIDTH) of REGION)) (ADD1 (fetch (REGION HEIGHT) of REGION)) (FETCH SCBITSPERPIXEL OF \CURSORSCREEN] (DSPXOFFSET [IMINUS (SETQ LEFT (FIXR (fetch (REGION LEFT) of REGION] DSPSTREAM) (DSPYOFFSET [IMINUS (SETQ BOTTOM (FIXR (fetch (REGION BOTTOM) of REGION] DSPSTREAM) (* this is because the default clipping region is smaller than the clipping  region of the figure in extreme cases.) (DSPCLIPPINGREGION REGION DSPSTREAM) (DSPOPERATION 'PAINT DSPSTREAM) (* to avoid carriage returns.) (DSPRIGHTMARGIN (PLUS 100 (fetch (REGION RIGHT) of REGION)) DSPSTREAM) (DRAW.LOCAL.SKETCH SCRITEMS DSPSTREAM REGION) (RETURN (create SKFIGUREIMAGE SKFIGURE.LOWERLEFT _ (create POSITION XCOORD _ LEFT YCOORD _ BOTTOM) SKFIGURE.BITMAP _ BITMAP]) ) (MOVD 'READCOLOR1 'ORG.READCOLOR1) (MOVD 'NEW.READCOLOR1 'READCOLOR1) (REPLACE (IMAGEOPS IMFILLPOLYGON) OF \8DISPLAYIMAGEOPS WITH (FUNCTION POLYSHADE.DISPLAY)) (REPLACE (IMAGEOPS IMSCALEDBITBLT) OF \8DISPLAYIMAGEOPS WITH (FUNCTION \SCALEDBITBLT.DISPLAY)) (PUTPROPS NEW-SKETCH-COLOR COPYRIGHT ("Fuji Xerox Co., Ltd" 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1340 32231 (\BBTCURVEPT 1350 . 9560) (BMOBJ.DISPLAYFN 9562 . 12391) (BITMAPOBJ.SNAPW 12393 . 13123) (OPPOSITECOLOR 13125 . 13339) (\SCALEDBITBLT.DISPLAY 13341 . 14836) (BITMAPELT.INPUTFN 14838 . 16015) (GET.BITMAP.POSITION 16017 . 16992) (BOX.DRAWFN1 16994 . 19884) (CIRCLE.DRAWFN 19886 . 23179) (CLOSED.WIRE.DRAWFN 23181 . 25493) (SKETCHINCOLORP 25495 . 25922) (NEW.READCOLOR1 25924 . 26394 ) (SK.FIGUREIMAGE 26396 . 32229))))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/ARCHIVEBROWSER b/obsolete/lispusers/ARCHIVEBROWSER deleted file mode 100644 index c4554d8f..00000000 --- a/obsolete/lispusers/ARCHIVEBROWSER +++ /dev/null @@ -1,506 +0,0 @@ -(FILECREATED " 4-Mar-87 17:04:08" {PHYLUM}KOTO>ARCHIVEBROWSER.;3 28150 - - changes to: (VARS ARCHIVEBROWSERCOMS) (FNS AB.Delete.Command AB.Retrieve.Command -AB.Retrieve.Directory.Command AB.Retrieve.Renamed.Aux AB.Undelete.Command AB ARCHIVEBROWSER -AB.Make.Cedar.Filename AB.Retrieve.Renamed.Command) - - previous date: "22-Sep-86 13:12:01" {QV}LISP>ARCHIVEBROWSER.;4) - - -(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT ARCHIVEBROWSERCOMS) - -(RPAQQ ARCHIVEBROWSERCOMS ((* * the user's interface to the archive browser) (FNS ARCHIVEBROWSER AB) - (* * command processing functions) (FNS AB.When.Selected.Fn AB.Command.Fn AB.Delete.Command -AB.Expunge.Command AB.Filter.Command AB.Recompute.Command AB.Retrieve.Command -AB.Retrieve.Directory.Command AB.Retrieve.Renamed.Command AB.Retrieve.Renamed.Aux AB.Sort.Command -AB.Undelete.Command) (* * miscellaneous functions) (FNS AB.Set.Browser.Title AB.Iconfn AB.Closefn -AB.Printfn AB.Prompt.For.Input AB.Read.Directory AB.Subitemp AB.Make.Cedar.Filename) (* * the user -that gets retrieval requests) (INITVARS (AB.archivist "Archivist")) (* * the structure for an archive -entry) (RECORDS AB.item) (* * the icon) (BITMAPS AB.icon AB.icon.mask) (INITVARS (AB.titled.icon ( -create TITLEDICON ICON _ AB.icon MASK _ AB.icon.mask TITLEREG _ (CREATEREGION 7 8 60 24)))) (* * the -font for the browser, which must be a fixed pitch font for now) (VARS (AB.browser.font (FONTCREATE ( -QUOTE TERMINAL) 10))) (* * based on the TableBrowser package) (FILES TABLEBROWSER) (DECLARE: -EVAL@COMPILE DONTCOPY (FILES TABLEBROWSERDECLS)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY -COMPILERVARS (ADDVARS (NLAMA AB) (NLAML) (LAMA))))) - (* * the user's interface to the archive browser) - -(DEFINEQ - -(ARCHIVEBROWSER -(LAMBDA (archivefilespec filter) (* N.H.Briggs " 2-Mar-87 16:56") (LET* ((menu (create MENU ITEMS _ ( -QUOTE ((Retrieve AB.Retrieve.Command "Retrieve selected files" (SUBITEMS ("Retrieve selected files" -AB.Retrieve.Command "Retrieve selected files") ("Retrieve to directory" AB.Retrieve.Directory.Command -"Retrieve selected files to a different directory") ("Retrieve renamed" AB.Retrieve.Renamed.Command -"Retrieve selected files specifying new name for each file"))) (Filter AB.Filter.Command -"Set filter for displayed file names") (Sort AB.Sort.Command "Sort entries by file name" (SUBITEMS ( -"Sort by file name" AB.Sort.Command "Sort entries by file name") ("Sort by creation date" ( -AB.Sort.Command CreationDate) "Sort entries by creation date of the file") ("Sort by archive date" ( -AB.Sort.Command Archive) "Sort entries by date that the file was archived") (Reverse (AB.Sort.Command -Reverse) "Reverse the order of the entries"))) (Recompute AB.Recompute.Command -"Redisplay browser items after re-reading archive directory" (SUBITEMS ("Same directory" -AB.Recompute.Command "Redisplay browser items after re-reading archive directory") ("New directory" ( -AB.Recompute.Command T) "Browse a different archive directory"))) ("" NIL "do nothing - a separator") -(Delete AB.Delete.Command "Delete selected items") (Undelete AB.Undelete.Command -"Undelete selected items" (SUBITEMS ("Undelete selected items" AB.Undelete.Command -"Undelete selected items") ("Undelete ALL items" (AB.Undelete.Command T) "Undelete all deleted items") -)) ("" NIL "do nothing - a separator so you don't accidentally Expunge") (Expunge AB.Expunge.Command -"Expunge deleted items and rewrite the archive directory"))) CENTERFLG _ T TITLE _ " Commands " -WHENSELECTEDFN _ (QUOTE AB.When.Selected.Fn))) (promptfont (FONTCREATE (QUOTE HELVETICA) 10)) ( -promptheight (HEIGHTIFWINDOW (TIMES 2 (FONTPROP promptfont (QUOTE HEIGHT))) T)) (promptwindow) ( -windowregion (GETREGION (PLUS (fetch IMAGEWIDTH of menu) 144) (PLUS (fetch IMAGEHEIGHT of menu) -promptheight))) (window (CREATEW (CREATEREGION (fetch LEFT of windowregion) (fetch BOTTOM of -windowregion) (DIFFERENCE (fetch WIDTH of windowregion) (fetch IMAGEWIDTH of menu)) (DIFFERENCE (fetch - HEIGHT of windowregion) promptheight)) "")) (browser (TB.MAKE.BROWSER NIL window (BQUOTE (PRINTFN -AB.Printfn FONT (\, AB.browser.font)))))) (ATTACHMENU menu window (QUOTE RIGHT) (QUOTE TOP)) ( -TB.USERDATA browser (LIST (QUOTE ARCHIVE) (PACKFILENAME.STRING (QUOTE HOST) (OR (FILENAMEFIELD -archivefilespec (QUOTE HOST)) (FILENAMEFIELD (DIRECTORYNAME) (QUOTE HOST))) (QUOTE DIRECTORY) (OR ( -FILENAMEFIELD archivefilespec (QUOTE DIRECTORY)) (CAR (FULLUSERNAME T))) (QUOTE NAME) (OR ( -FILENAMEFIELD archivefilespec (QUOTE NAME)) (QUOTE Archive)) (QUOTE EXTENSION) (OR (FILENAMEFIELD -archivefilespec (QUOTE EXTENSION)) (QUOTE directory)) (QUOTE BODY) archivefilespec) (QUOTE FILTER) (OR - filter "*.*"))) (* (use something like this if the "attic" is used) L-CASE (OR filter (CONCAT (CAR ( -FULLUSERNAME T)) ">*.*"))) (SETQ promptwindow (GETPROMPTWINDOW window 2 (FONTCREATE (QUOTE HELVETICA) -10))) (AB.Set.Browser.Title browser) (WINDOWPROP promptwindow (QUOTE MINSIZE) (CONS 0 (fetch (REGION -HEIGHT) of (WINDOWPROP promptwindow (QUOTE REGION))))) (WINDOWPROP promptwindow (QUOTE MAXSIZE) (CONS -64000 (fetch (REGION HEIGHT) of (WINDOWPROP promptwindow (QUOTE REGION))))) (LINELENGTH MAX.SMALLP -promptwindow) (WINDOWPROP window (QUOTE ICONFN) (FUNCTION AB.Iconfn)) (WINDOWADDPROP window (QUOTE -CLOSEFN) (FUNCTION AB.Closefn) T) (AB.Command.Fn (SASSOC (QUOTE Recompute) (fetch (MENU ITEMS) of menu -)) menu (QUOTE LEFT))))) - -(AB -(NLAMBDA filespec% filter (* N.H.Briggs " 4-Mar-87 12:11") (LET ((patternandfilter (NLAMBDA.ARGS -filespec% filter))) (ARCHIVEBROWSER (CAR patternandfilter) (CADR patternandfilter)) NIL))) -) - (* * command processing functions) - -(DEFINEQ - -(AB.When.Selected.Fn -(LAMBDA (Item Menu Key) (* N.H.Briggs "25-Jun-86 11:48") (if (AND (LISTP Item) (CADR Item)) then ( -TB.PROCESS (LIST (FUNCTION AB.Command.Fn) (KWOTE Item) (KWOTE Menu) (KWOTE Key)) (PACK* (QUOTE AB-) ( -CAR Item)))))) - -(AB.Command.Fn -(LAMBDA (item menu key) (* N.H.Briggs "18-Jun-86 13:09") (RESETLST (LET* ((realitem item) (window ( -WINDOWPROP (WFROMMENU menu) (QUOTE MAINWINDOW))) (browser (WINDOWPROP window (QUOTE TABLEBROWSER)))) ( -if (NOT (MEMBER item (fetch (MENU ITEMS) of menu))) then (* A subitem -- fetch main item) (SETQ item ( -for I in (fetch (MENU ITEMS) of menu) thereis (AB.Subitemp item I)))) (if (OBTAIN.MONITORLOCK (fetch ( -TABLEBROWSER TBLOCK) of browser) T T) then (RESETSAVE (SHADEITEM item menu MENUSELECTSHADE) (LIST ( -FUNCTION SHADEITEM) item menu WHITESHADE)) (LET ((function (CADR realitem)) (promptwindow ( -GETPROMPTWINDOW window)) extra) (if (OPENWP promptwindow) then (CLEARW promptwindow)) (if (LISTP -function) then (SETQ extra (CADR function)) (SETQ function (CAR function))) (APPLY* function browser -extra)) else (TB.BROWSER.BUSY browser)))))) - -(AB.Delete.Command -(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 17:01") (LET ((count 0) (browserpromptwindow ( -GETPROMPTWINDOW (TB.WINDOW browser)))) (DECLARE (SPECVARS count)) (TB.MAP.SELECTED.ITEMS browser ( -FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS count)) (TB.DELETE.ITEM browser item) (add count 1) -))) (if (EQ count 0) then (printout browserpromptwindow "No items marked for deletion.") else ( -printout browserpromptwindow count " item" (if (IGREATERP count 1) then "s" else "") -" marked for deletion."))))) - -(AB.Expunge.Command -(LAMBDA (browser) (* N.H.Briggs "18-Jun-86 12:23") (if (EQ (fetch (TABLEBROWSER TB#DELETED) of browser -) 0) then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to expunge!") else (LET (( -directorystream (OPENSTREAM (PACKFILENAME (QUOTE VERSION) NIL (QUOTE BODY) (LISTGET (TB.USERDATA -browser) (QUOTE ARCHIVE))) (QUOTE OUTPUT)))) (if (NOT directorystream) then (printout (GETPROMPTWINDOW - (TB.WINDOW browser)) "Error opening (new version of) archive directory " (LISTGET (TB.USERDATA -browser) (QUOTE ARCHIVE)) " ...aborted.") else (LINELENGTH MAX.SMALLP directorystream) (* ensure -nothing wraps around) (LISTPUT (TB.USERDATA browser) (QUOTE ALLITEMS) (for item in (LISTGET ( -TB.USERDATA browser) (QUOTE ALLITEMS)) when (NOT (TB.ITEM.DELETED? browser item)) collect (printout -directorystream (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) , (fetch (AB.item -AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of item))) (for media on (fetch (AB.item AB.Media) of ( -fetch (TABLEITEM TIDATA) of item)) by (CDDR media) do (printout directorystream ,, (CAR media)) ( -printout directorystream , (CADR media)) finally (printout directorystream T)) item)) (LISTPUT ( -TB.USERDATA browser) (QUOTE ARCHIVE) (L-CASE (FULLNAME directorystream))) (CLOSEF directorystream) ( -AB.Set.Browser.Title browser) (TB.MAP.DELETED.ITEMS browser (FUNCTION TB.REMOVE.ITEM))))))) - -(AB.Filter.Command -(LAMBDA (browser) (* N.H.Briggs "18-Jun-86 12:28") (LET ((pattern (AB.Prompt.For.Input -"Files matching what? " (LISTGET (TB.USERDATA browser) (QUOTE FILTER)) browser T))) (if pattern then ( -LISTPUT (TB.USERDATA browser) (QUOTE FILTER) (L-CASE pattern)) (AB.Set.Browser.Title browser) ( -AB.Recompute.Command browser))))) - -(AB.Recompute.Command -(LAMBDA (browser newdirectory?) (* N.H.Briggs "19-Sep-86 12:34") (LET* ((window (TB.WINDOW browser)) ( -windowregion (WINDOWPROP window (QUOTE REGION))) (region (CREATEREGION 0 0 (fetch (REGION WIDTH) of -windowregion) (fetch (REGION HEIGHT) of windowregion))) (namewidth 0) (userdata (TB.USERDATA browser)) - (filter (DIRECTORY.MATCH.SETUP (PACKFILENAME (QUOTE BODY) (LISTGET userdata (QUOTE FILTER))))) result -) (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser))) then (if (MENU (create MENU ITEMS _ ( -QUOTE (("Expunge" (QUOTE Expunge) "Expunge items marked for deletion") ("Don't Expunge" NIL -"Don't expunge items marked for deletion"))) TITLE _ "Expunge deleted items?" CENTERFLG _ T)) then ( -AB.Expunge.Command browser))) (if (AND newdirectory? (SETQ result (AB.Prompt.For.Input -"New archive directory? " NIL browser T))) then (LISTPUT userdata (QUOTE ARCHIVE) (PACKFILENAME.STRING - (QUOTE NAME) (OR (FILENAMEFIELD result (QUOTE NAME)) (QUOTE Archive)) (QUOTE EXTENSION) (OR ( -FILENAMEFIELD result (QUOTE EXTENSION)) (QUOTE directory)) (QUOTE BODY) result))) (if (OR (NOT -newdirectory?) (AND newdirectory? result)) then (TB.REPLACE.ITEMS browser) (LISTPUT userdata (QUOTE -ALLITEMS) (for item in (AB.Read.Directory browser) bind tableitem eachtime (SETQ tableitem (create -TABLEITEM TIDATA _ item)) collect (if (DIRECTORY.MATCH filter (PACKFILENAME (QUOTE BODY) (fetch ( -AB.item AB.Filename) of item))) then (SETQ namewidth (MAX namewidth (STRINGWIDTH (fetch (AB.item -AB.Filename) of item) AB.browser.font))) (TB.INSERT.ITEM browser tableitem)) tableitem)) (LISTPUT -userdata (QUOTE NAMEWIDTH) namewidth) (TB.DISPLAY.LINES browser (TB.FIRST.VISIBLE.ITEM# browser region -) (TB.LAST.VISIBLE.ITEM# browser region)))))) - -(AB.Retrieve.Command -(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 16:54") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0 -) registry corestream) (DECLARE (SPECVARS corestream count)) (SETQ registry (SELECTQ (OR (LAFITEMODE) -(\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser)) -"Can't retrieve -- Lafite mode must be set to GV or NS")))) (SETQ corestream (OPENSTREAM (QUOTE -{NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP corestream) (printout corestream -"Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " (FULLUSERNAME) T T) ( -TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS corestream count)) ( -printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) -" of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of item)) " from " (CAR (fetch ( -AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " or " (CADR (fetch (AB.item AB.Media) of ( -fetch (TABLEITEM TIDATA) of item))) T) (add count 1)))) (if (EQ count 0) then (printout ( -GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF corestream) (RETURN)) (SETQ -corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW (TB.WINDOW browser)) -"Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ count 1) then "s: " -else ": ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout (GETPROMPTWINDOW ( -TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) " failed."))))) - -(AB.Retrieve.Directory.Command -(LAMBDA (browser) (* N.H.Briggs " 4-Mar-87 16:53") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0 -) registry corestream newdirectory) (DECLARE (SPECVARS corestream count newdirectory)) (SETQ registry -(SELECTQ (OR (LAFITEMODE) (\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout ( -GETPROMPTWINDOW (TB.WINDOW browser)) "Can't retrieve -- Lafite mode must be set to GV or NS")))) (if ( -NOT (SETQ newdirectory (AB.Prompt.For.Input "Directory to retrieve into? " NIL browser T))) then ( -RETURN)) (SETQ corestream (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP -corestream) (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " ( -FULLUSERNAME) T T) (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS -corestream count newdirectory)) (printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of ( -fetch (TABLEITEM TIDATA) of item)) " of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM -TIDATA) of item)) " from " (CAR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) -" or " (CADR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " as " ( -AB.Make.Cedar.Filename (PACKFILENAME.STRING (QUOTE DIRECTORY) newdirectory (QUOTE VERSION) NIL (QUOTE -BODY) (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)))) T) (add count 1)))) (if ( -EQ count 0) then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF -corestream) (RETURN)) (SETQ corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW ( -TB.WINDOW browser)) "Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ -count 1) then "s: " else ": ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout ( -GETPROMPTWINDOW (TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) -" failed."))))) - -(AB.Retrieve.Renamed.Command -(LAMBDA (browser) (* N.H.Briggs " 3-Mar-87 12:34") (DECLARE (GLOBALVARS AB.archivist)) (PROG ((count 0 -) registry corestream) (DECLARE (SPECVARS corestream count)) (SETQ registry (SELECTQ (OR (LAFITEMODE) -(\LAFITE.INFER.MODE)) (GV ".pa") (NS ":PA") (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser)) -"Can't retrieve -- Lafite mode must be set to GV or NS")))) (SETQ corestream (OPENSTREAM (QUOTE -{NODIRCORE}) (QUOTE BOTH))) (LINELENGTH MAX.SMALLP corestream) (printout corestream -"Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " (FULLUSERNAME) T T) ( -TB.MAP.SELECTED.ITEMS browser (FUNCTION AB.Retrieve.Renamed.Aux)) (if (EQ count 0) then (printout ( -GETPROMPTWINDOW (TB.WINDOW browser)) "Nothing to retrieve.") (CLOSEF corestream) (RETURN)) (SETQ -corestream (OPENTEXTSTREAM corestream)) (printout (GETPROMPTWINDOW (TB.WINDOW browser)) -"Sending mail to " AB.archivist registry " requesting " count " file" (if (NEQ count 1) then "s: " -else ": ")) (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) then (printout (GETPROMPTWINDOW ( -TB.WINDOW browser)) " done.") else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) " failed."))))) - -(AB.Retrieve.Renamed.Aux -(LAMBDA (browser item) (* N.H.Briggs " 4-Mar-87 16:52") (DECLARE (SPECVARS corestream count)) (LET (( -newname (AB.Prompt.For.Input (CONCAT "Retrieve " (fetch (AB.item AB.Filename) of (fetch (TABLEITEM -TIDATA) of item)) " as ?") (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) browser - "... skipped"))) (if newname then (printout corestream "Retrieve: " (fetch (AB.item AB.Filename) of ( -fetch (TABLEITEM TIDATA) of item)) " of " (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM -TIDATA) of item)) " from " (CAR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) -" or " (CADR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) " as " ( -AB.Make.Cedar.Filename (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE BODY) newname)) T) (add count 1 -))))) - -(AB.Sort.Command -(LAMBDA (browser sorttype) (* N.H.Briggs "17-Jun-86 12:47") (LET ((items (fetch (TABLEBROWSER TBITEMS) - of browser))) (if (EQ sorttype (QUOTE Reverse)) then (SETQ items (DREVERSE items)) else (SORT items ( -SELECTQ sorttype (CreationDate (FUNCTION (LAMBDA (x y) (IGREATERP (IDATE (fetch (AB.item -AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of x))) (IDATE (fetch (AB.item AB.Creation.Date) of ( -fetch (TABLEITEM TIDATA) of y))))))) (Archive (FUNCTION (LAMBDA (x y) (ILESSP (fetch (AB.item -AB.Sequence.Number) of (fetch (TABLEITEM TIDATA) of x)) (fetch (AB.item AB.Sequence.Number) of (fetch -(TABLEITEM TIDATA) of y)))))) (FUNCTION (LAMBDA (x y) (ALPHORDER (fetch (AB.item AB.Filename) of ( -fetch (TABLEITEM TIDATA) of x)) (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of y)) ( -UPPERCASEARRAY))))))) (for item in items as i from 1 do (replace TI# of item with i)) ( -TB.REPLACE.ITEMS browser items) (TB.REDISPLAY.ITEMS browser)))) - -(AB.Undelete.Command -(LAMBDA (browser all?) (* N.H.Briggs " 4-Mar-87 17:00") (LET ((count 0) (browserpromptwindow ( -GETPROMPTWINDOW (TB.WINDOW browser)))) (DECLARE (SPECVARS count)) (if all? then (TB.MAP.DELETED.ITEMS -browser (FUNCTION (LAMBDA (browser item) (DECLARE (SPECVARS count)) (TB.UNDELETE.ITEM browser item) ( -add count 1)))) else (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) (DECLARE ( -SPECVARS count)) (TB.UNDELETE.ITEM browser item) (add count 1))))) (if (EQ count 0) then (printout -browserpromptwindow "No items were undeleted.") else (printout browserpromptwindow count " item" (if ( -NEQ count 1) then "s" else "") " undeleted."))))) -) - (* * miscellaneous functions) - -(DEFINEQ - -(AB.Set.Browser.Title -(LAMBDA (browser) (* N.H.Briggs "17-Jun-86 15:45") (LET ((archive (LISTGET (TB.USERDATA browser) ( -QUOTE ARCHIVE))) (filter (LISTGET (TB.USERDATA browser) (QUOTE FILTER)))) (WINDOWPROP (GETPROMPTWINDOW - (TB.WINDOW browser)) (QUOTE TITLE) (CONCAT "Archive Browser" (OR (AND archive (CONCAT " " archive)) -"") (OR (AND filter (CONCAT " - files " filter)) "")))))) - -(AB.Iconfn -(LAMBDA (window icon) (* N.H.Briggs "19-Sep-86 18:58") (DECLARE (GLOBALVARS AB.titled.icon)) (LET* (( -browser (WINDOWPROP window (QUOTE TABLEBROWSER))) (archive (LISTGET (TB.USERDATA browser) (QUOTE -ARCHIVE))) (directory (UNPACKFILENAME.STRING archive (QUOTE DIRECTORY))) (host (UNPACKFILENAME.STRING -archive (QUOTE HOST))) (title (PACKFILENAME.STRING (QUOTE HOST) host (QUOTE DIRECTORY) (SUBSTRING -directory 1 (STRPOS directory ">"))))) (if icon then (ICONW.TITLE icon title) icon else (TITLEDICONW -AB.titled.icon title (FONTCREATE (QUOTE MODERN) 8) NIL NIL NIL (CHARCODE (}))))))) - -(AB.Closefn -(LAMBDA (window) (* edited: "20-Jun-86 12:42") (LET ((browser (WINDOWPROP window (QUOTE TABLEBROWSER)) -)) (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser))) then (if (MENU (create MENU ITEMS _ -(QUOTE (("Expunge" (QUOTE Expunge) "Expunge items marked for deletion") ("Don't Expunge" NIL -"Don't expunge items marked for deletion"))) TITLE _ "Expunge deleted items?" CENTERFLG _ T)) then ( -AB.Expunge.Command browser))) NIL))) - -(AB.Printfn -(LAMBDA (browser item window) (* N.H.Briggs "22-Sep-86 13:09") (LET* ((entry (fetch TIDATA of item)) ( -namewidth (OR (LISTGET (TB.USERDATA browser) (QUOTE NAMEWIDTH)) 0)) (offset (DSPXPOSITION NIL window)) - (datestart (IPLUS offset namewidth 10))) (* if this is to work for variable spaced fonts it has to be - smart about the widths of date and media fields too) (PRIN1 (fetch (AB.item AB.Filename) of entry) -window) (if (ZEROP namewidth) then (PRIN1 " " window) else (BLTSHADE WHITESHADE window (DSPXPOSITION -NIL window) (IDIFFERENCE (DSPYPOSITION NIL window) (FONTPROP AB.browser.font (QUOTE DESCENT))) ( -IDIFFERENCE datestart (DSPXPOSITION NIL window)) (FONTPROP AB.browser.font (QUOTE HEIGHT))) ( -DSPXPOSITION datestart window)) (PRIN1 (fetch (AB.item AB.Creation.Date) of entry) window) (PRIN1 -" " window) (for media in (fetch (AB.item AB.Media) of entry) do (PRIN1 media window) (PRIN1 " " -window))))) - -(AB.Prompt.For.Input -(LAMBDA (prompt default browser abortflag) (* N.H.Briggs "22-Apr-86 17:32") (* * Prompt for input for -browser browser with question prompt offering default answer DEFAULT. If abortflag is true and -response is NIL, prints "... aborted" or abortflag (should be a text string)) (LET* ((promptwindow ( -GETPROMPTWINDOW (TB.WINDOW browser))) (promptwidth (STRINGWIDTH prompt promptwindow)) (windowwidth ( -WINDOWPROP promptwindow (QUOTE WIDTH))) result) (CLEARW promptwindow) (if (IGREATERP (IPLUS -promptwidth (STRINGWIDTH (OR default "XXX") promptwindow)) windowwidth) then (* Prompt plus default -response will overflow the width of the window, so be a nice guy and break it up) (for i from ( -IDIFFERENCE (NCHARS prompt) 4) to 10 by -1 bind (excesswidth _ (IDIFFERENCE promptwidth windowwidth)) -when (AND (EQ (NTHCHARCODE prompt i) (CHARCODE SPACE)) (IGREATERP (STRINGWIDTH (SUBSTRING prompt i) -promptwindow) excesswidth)) do (RETURN (SETQ prompt (CONCAT (SUBSTRING prompt 1 (IPLUS i -1)) " -" (SUBSTRING prompt (IPLUS i 1))))))) (SETQ result (CAR (NLSETQ (PROMPTFORWORD prompt default NIL -promptwindow NIL (QUOTE TTY) (CHARCODE (CR ESC)))))) (if (AND (EQ result NIL) abortflag) then ( -PRINTOUT promptwindow (if (EQ abortflag T) then "... aborted" else abortflag))) (TERPRI promptwindow) -result))) - -(AB.Read.Directory -(LAMBDA (browser) (* N.H.Briggs "22-Sep-86 12:53") (LET ((directorystream (AND (LISTGET (TB.USERDATA -browser) (QUOTE ARCHIVE)) (CAR (NLSETQ (OPENSTREAM (LISTGET (TB.USERDATA browser) (QUOTE ARCHIVE)) ( -QUOTE INPUT)))))) (linerdtable (COPYREADTABLE (QUOTE ORIG))) (promptwindow (GETPROMPTWINDOW (TB.WINDOW - browser))) items) (if (NOT directorystream) then (printout promptwindow -"Can't find archive directory " (LISTGET (TB.USERDATA browser) (QUOTE ARCHIVE))) (LISTPUT (TB.USERDATA - browser) (QUOTE ARCHIVE) NIL) (AB.Set.Browser.Title browser) NIL else (LISTPUT (TB.USERDATA browser) -(QUOTE ARCHIVE) (L-CASE (FULLNAME directorystream))) (AB.Set.Browser.Title browser) (SETSEPR (LIST ( -CONSTANT (CHARCODE EOL))) NIL linerdtable) (SETBRK NIL NIL linerdtable) (bind start end inputline -repeatuntil (EOFP directorystream) eachtime (SETQ inputline (RSTRING directorystream linerdtable)) ( -READC directorystream) as i from 1 collect (create AB.item AB.Filename _ (L-CASE (SUBSTRING inputline -1 (SUB1 (SETQ end (STRPOS " " inputline))))) AB.Creation.Date _ (SUBSTRING inputline (ADD1 end) (SUB1 -(SETQ end (STRPOS " " inputline (ADD1 end))))) AB.Media _ (first (SETQ end (ADD1 end)) repeatwhile -end eachtime (SETQ start (ADD1 end)) (while (EQUAL (SUBSTRING inputline start start) " ") do (SETQ -start (ADD1 start))) (SETQ end (STRPOS " " inputline start)) collect (SUBSTRING inputline start (AND -end (SUB1 end)))) AB.Sequence.Number _ i) finally (CLOSEF directorystream)))))) - -(AB.Subitemp -(LAMBDA (subitem item) (* N.H.Briggs "16-Apr-86 18:32") (* * 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 (AB.Subitemp subitem i))))))) - -(AB.Make.Cedar.Filename -(LAMBDA (filename) (* N.H.Briggs " 3-Mar-87 12:08") (LET ((unpackedfilename (UNPACK filename))) (PACK -(SUBLIS (QUOTE (({ . %[) (} . %]) (; . !))) unpackedfilename))))) -) - (* * the user that gets retrieval requests) - - -(RPAQ? AB.archivist "Archivist") - (* * the structure for an archive entry) - -[DECLARE: EVAL@COMPILE - -(RECORD AB.item (AB.Filename AB.Creation.Date AB.Media AB.Sequence.Number)) -] - (* * the icon) - - -(RPAQ AB.icon (READBITMAP)) -(73 73 -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"O@@@@@@AN@@@@@@@@AH@" -"ML@@@@@CK@@@@@@@@AH@" -"LOOOOOOOOOOOOOOOOIH@" -"LJ@@@@@DHG@@@@@@AIH@" -"LK@@@@AHHAL@@@@@FIH@" -"LIH@@@A@H@GH@@@@LIH@" -"LHF@@@G@H@@OL@@GHIH@" -"LHC@@COOOOOOGOOO@IH@" -"LHAH@C@CN@@A@@@F@IH@" -"LH@LON@FK@@A@@AL@IH@" -"LH@FNBAOOOOA@@CL@IH@" -"LH@CLBCHHL@A@@FH@IH@" -"LH@AKOOOOOOI@@MH@IH@" -"LH@ADB@@L@LA@AI@@IH@" -"LH@ANB@@L@CA@FA@@IH@" -"LH@@KCOOOOOOMOC@@IH@" -"LH@@IH@CL@@@CJB@@IH@" -"LH@@HH@FF@@@GBB@@IH@" -"LH@@HDALG@@@LFC@@IH@" -"LH@@HCOOOOOOHDA@@IH@" -"LH@@HCL@F@@G@DA@@IH@" -"LH@@HAOOOOOO@DAH@IH@" -"OH@AHAOOOOOO@D@H@IH@" -"LO@C@AOOOOOO@D@L@IH@" -"LION@CAHC@FA@D@GHIH@" -"LH@N@F@HA@LA@D@AOIH@" -"LH@GNL@DAAHAHBAO@IH@" -"LH@BGO@CAB@@LCOB@IH@" -"LH@B@MNAIFAOOO@F@IH@" -"LH@B@DCLOMNCHB@D@IH@" -"LH@B@D@COO@F@B@D@IH@" -"LH@B@D@@FGLB@B@D@IH@" -"LH@B@L@GL@CO@C@F@IH@" -"LH@B@HCL@@@GNAHC@IH@" -"LH@FAKL@@@@@AOLAHIH@" -"LH@DAL@@@@@@@AN@LIH@" -"LH@OO@@@@@@@@@CNFIH@" -"LHCL@@@@@@@@@@@CNIH@" -"OOO@@@@@@@@@@@@@AIH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LH@@@@@@@@@@@@@@@IH@" -"LOOOOOOOOOOOOOOOOIH@" -"L@@@@@@@@@@@@@@@@AH@" -"L@@@@@@@@@@@@@@@@AH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@") - -(RPAQ AB.icon.mask (READBITMAP)) -(73 73 -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@" -"OOOOOOOOOOOOOOOOOOH@") - -(RPAQ? AB.titled.icon (create TITLEDICON ICON _ AB.icon MASK _ AB.icon.mask TITLEREG _ (CREATEREGION - 7 8 60 24))) - (* * the font for the browser, which must be a fixed pitch font for now) - - -(RPAQ AB.browser.font (FONTCREATE (QUOTE TERMINAL) 10)) - (* * based on the TableBrowser package) - -(FILESLOAD TABLEBROWSER) -(DECLARE: EVAL@COMPILE DONTCOPY -(FILESLOAD TABLEBROWSERDECLS) -) -(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA AB) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA ) -) -(PUTPROPS ARCHIVEBROWSER COPYRIGHT ("Xerox Corporation" 1986 1987)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (1797 5673 (ARCHIVEBROWSER 1807 . 5473) (AB 5475 . 5671)) (5715 18075 ( -AB.When.Selected.Fn 5725 . 5965) (AB.Command.Fn 5967 . 6830) (AB.Delete.Command 6832 . 7357) ( -AB.Expunge.Command 7359 . 8764) (AB.Filter.Command 8766 . 9109) (AB.Recompute.Command 9111 . 10870) ( -AB.Retrieve.Command 10872 . 12460) (AB.Retrieve.Directory.Command 12462 . 14401) ( -AB.Retrieve.Renamed.Command 14403 . 15599) (AB.Retrieve.Renamed.Aux 15601 . 16431) (AB.Sort.Command -16433 . 17398) (AB.Undelete.Command 17400 . 18073)) (18112 23830 (AB.Set.Browser.Title 18122 . 18509) -(AB.Iconfn 18511 . 19112) (AB.Closefn 19114 . 19567) (AB.Printfn 19569 . 20498) (AB.Prompt.For.Input -20500 . 21823) (AB.Read.Directory 21825 . 23323) (AB.Subitemp 23325 . 23630) (AB.Make.Cedar.Filename -23632 . 23828))))) -STOP diff --git a/obsolete/lispusers/ARCHIVEBROWSER.LCOM b/obsolete/lispusers/ARCHIVEBROWSER.LCOM deleted file mode 100644 index 2677a0ed..00000000 Binary files a/obsolete/lispusers/ARCHIVEBROWSER.LCOM and /dev/null differ diff --git a/obsolete/lispusers/ARCHIVETOOL b/obsolete/lispusers/ARCHIVETOOL deleted file mode 100644 index a9dbc1e4..00000000 --- a/obsolete/lispusers/ARCHIVETOOL +++ /dev/null @@ -1,1321 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "10-Mar-89 17:03:42" {POOH/N}BURWELL>LISP>ARCHIVETOOL;4 77278 - - changes to%: (FNS FB.DoArchiveCommands) - (VARS ARCHIVETOOLCOMS) - - previous date%: " 1-Dec-88 14:12:21" {POOH/N}BURWELL>LISP>ARCHIVETOOL;2) - - -(* " -Copyright (c) 1985, 1986, 1988, 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT ARCHIVETOOLCOMS) - -(RPAQQ ARCHIVETOOLCOMS - [(COMS - -(* ;;; "the user's interface to the archive browser") - - (FNS ARCHIVEBROWSER AB) - - -(* ;;; "command processing functions") - - (FNS AB.When.Selected.Fn AB.Command.Fn AB.Delete.Command AB.Expunge.Command - AB.Filter.Command AB.Recompute.Command AB.Retrieve.Command - AB.Retrieve.Directory.Command AB.Retrieve.Renamed.Command AB.Retrieve.Renamed.Aux - AB.Sort.Command AB.Undelete.Command) - - -(* ;;; "miscellaneous functions") - - (FNS AB.Set.Browser.Title AB.Iconfn AB.Closefn AB.Printfn AB.Prompt.For.Input - AB.Read.Directory AB.Subitemp AB.Make.Cedar.Filename) - - -(* ;;; "the user that gets retrieval requests") - - (INITVARS (AB.archivist "Archivist")) - - -(* ;;; "the structure for an archive entry") - - (RECORDS AB.item) - - -(* ;;; "the icon") - - (BITMAPS AB.icon AB.icon.mask) - [INITVARS (AB.titled.icon (create TITLEDICON ICON _ AB.icon MASK _ AB.icon.mask - TITLEREG _ (CREATEREGION 7 8 60 24] - - -(* ;;; "the font for the browser, which must be a fixed pitch font for now") - - (VARS (AB.browser.font (FONTCREATE 'TERMINAL 10))) - - -(* ;;; "based on the TableBrowser package") - - - -(* ;;; " took out WORDFNS") - - (FILES TABLEBROWSER)) - (COMS (* LOAD the FILEBROWSER first) - (FILES FILEBROWSER)) - [COMS (* ArchiveTool File Browser Interface Functions) - (FNS Arch.ConvertToCedarFileName FB.ArchiveCommand FB.ArchiveAllCommand - FB.ArchiveAndDeleteCommand FB.ArchiveAndDeleteAllCommand FB.DoArchiveCommands) - (GLOBALVARS Arch.CcToSelfFlg Arch.VerifyNotArchivedFlg OKCedarCharBitTable) - [VARS (OKCedarCharBitTable (MAKEBITTABLE (APPEND (CHARCODE (%. $ - + * < > { })) - (for i from (CHARCODE a) - to - (CHARCODE z) - collect i) - (for i from (CHARCODE A) - to - (CHARCODE Z) - collect i) - (CHARCODE (0 1 2 3 4 5 6 7 8 9] - (INITVARS (Arch.CcToSelfFlg T) - (Arch.VerifyNotArchivedFlg NIL)) - (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (BackgroundMenuCommands (ArchiveBrowser - '(ARCHIVEBROWSER) - - "Brings up an archive browser" - ))) - (P (SETQ BackgroundMenu))) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) - TABLEBROWSERDECLS) - (FILES (LOADCOMP) - FILEBROWSER)) - (DECLARE%: DONTEVAL@LOAD DOCOPY - (P (if (NOT (SASSOC "Archive" FB.MENU.ITEMS)) - then - (PUTASSOC "Archive" '(FB.ArchiveCommand - "Archives selected files by sending mail to Archivist.pa" - (SUBITEMS ("Archive" FB.ArchiveCommand - "Archives selected files by sending mail to Archivist.pa" - ) - ("Archive ALL Files" - FB.ArchiveAllCommand - "Archives ALL files in the browser by sending mail to Archivist.pa" - ) - ("Archive and Delete" - FB.ArchiveAndDeleteCommand - "Archives selected files by sending an Archive and Delete request to Archivist.pa" - ) - ("Archive and Delete ALL Files" - FB.ArchiveAndDeleteAllCommand - "Archives ALL files in the browser by sending an Archive and Delete request to Archivist.pa" - ))) - FB.MENU.ITEMS) - else - (RPLACD (SASSOC "Archive" FB.MENU.ITEMS) - '(FB.ArchiveCommand - "Archives selected files by sending mail to Archivist.pa" - (SUBITEMS ("Archive" FB.ArchiveCommand - "Archives selected files by sending mail to Archivist.pa" - ) - ("Archive ALL Files" FB.ArchiveAllCommand - "Archives ALL files in the browser by sending mail to Archivist.pa" - ) - ("Archive and Delete" FB.ArchiveAndDeleteCommand - "Archives selected files by sending an Archive and Delete request to Archivist.pa" - ) - ("Archive and Delete ALL Files" - FB.ArchiveAndDeleteAllCommand - "Archives ALL files in the browser by sending an Archive and Delete request to Archivist.pa" - ] - (COMS (* Functions that aren't used any more) - (FNS Arch.ParseReturnMsg Arch.BackgroundMenuFn)) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA AB) - (NLAML) - (LAMA]) - - - -(* ;;; "the user's interface to the archive browser") - -(DEFINEQ - -(ARCHIVEBROWSER - [LAMBDA (archivefilespec filter) (* N.H.Briggs " 2-Mar-87 16:56") - (LET* [(menu (create MENU - ITEMS _ '((Retrieve AB.Retrieve.Command "Retrieve selected files" - (SUBITEMS ("Retrieve selected files" AB.Retrieve.Command - "Retrieve selected files") - ("Retrieve to directory" - AB.Retrieve.Directory.Command - "Retrieve selected files to a different directory" - ) - ("Retrieve renamed" AB.Retrieve.Renamed.Command - "Retrieve selected files specifying new name for each file" - ))) - (Filter AB.Filter.Command "Set filter for displayed file names") - (Sort AB.Sort.Command "Sort entries by file name" - (SUBITEMS ("Sort by file name" AB.Sort.Command - "Sort entries by file name") - ("Sort by creation date" (AB.Sort.Command CreationDate - ) - "Sort entries by creation date of the file") - ("Sort by archive date" (AB.Sort.Command Archive) - - "Sort entries by date that the file was archived" - ) - (Reverse (AB.Sort.Command Reverse) - "Reverse the order of the entries"))) - (Recompute AB.Recompute.Command - "Redisplay browser items after re-reading archive directory" - (SUBITEMS ("Same directory" AB.Recompute.Command - "Redisplay browser items after re-reading archive directory" - ) - ("New directory" (AB.Recompute.Command T) - "Browse a different archive directory"))) - ("" NIL "do nothing - a separator") - (Delete AB.Delete.Command "Delete selected items") - (Undelete AB.Undelete.Command "Undelete selected items" - (SUBITEMS ("Undelete selected items" AB.Undelete.Command - "Undelete selected items") - ("Undelete ALL items" (AB.Undelete.Command T) - "Undelete all deleted items"))) - ("" NIL - "do nothing - a separator so you don't accidentally Expunge") - (Expunge AB.Expunge.Command - "Expunge deleted items and rewrite the archive directory")) - CENTERFLG _ T - TITLE _ " Commands " - WHENSELECTEDFN _ 'AB.When.Selected.Fn)) - (promptfont (FONTCREATE 'HELVETICA 10)) - (promptheight (HEIGHTIFWINDOW (TIMES 2 (FONTPROP promptfont 'HEIGHT)) - T)) - (promptwindow) - (windowregion (GETREGION (PLUS (fetch IMAGEWIDTH of menu) - 144) - (PLUS (fetch IMAGEHEIGHT of menu) - promptheight))) - (window (CREATEW (CREATEREGION (fetch LEFT of windowregion) - (fetch BOTTOM of windowregion) - (DIFFERENCE (fetch WIDTH of windowregion) - (fetch IMAGEWIDTH of menu)) - (DIFFERENCE (fetch HEIGHT of windowregion) - promptheight)) - "")) - (browser (TB.MAKE.BROWSER NIL window `(PRINTFN AB.Printfn FONT ,AB.browser.font] - (ATTACHMENU menu window 'RIGHT 'TOP) - (TB.USERDATA browser (LIST 'ARCHIVE (PACKFILENAME.STRING 'HOST (OR (FILENAMEFIELD - archivefilespec - 'HOST) - (FILENAMEFIELD - (DIRECTORYNAME) - 'HOST)) - 'DIRECTORY - (OR (FILENAMEFIELD archivefilespec 'DIRECTORY) - (CAR (FULLUSERNAME T))) - 'NAME - (OR (FILENAMEFIELD archivefilespec 'NAME) - 'Archive) - 'EXTENSION - (OR (FILENAMEFIELD archivefilespec 'EXTENSION) - 'directory) - 'BODY archivefilespec) - 'FILTER - (OR filter "*.*"))) (* (use something like this if the - "attic" is used) L-CASE - (OR filter (CONCAT (CAR - (FULLUSERNAME T)) ">*.*"))) - (SETQ promptwindow (GETPROMPTWINDOW window 2 (FONTCREATE 'HELVETICA 10))) - (AB.Set.Browser.Title browser) - [WINDOWPROP promptwindow 'MINSIZE (CONS 0 (fetch (REGION HEIGHT) of (WINDOWPROP - promptwindow - 'REGION] - [WINDOWPROP promptwindow 'MAXSIZE (CONS 64000 (fetch (REGION HEIGHT) - of (WINDOWPROP promptwindow 'REGION] - (LINELENGTH MAX.SMALLP promptwindow) - (WINDOWPROP window 'ICONFN (FUNCTION AB.Iconfn)) - (WINDOWADDPROP window 'CLOSEFN (FUNCTION AB.Closefn) - T) - (AB.Command.Fn (SASSOC 'Recompute (fetch (MENU ITEMS) of menu)) - menu - 'LEFT]) - -(AB - [NLAMBDA filespec% filter (* N.H.Briggs " 4-Mar-87 12:11") - (LET ((patternandfilter (NLAMBDA.ARGS filespec% filter))) - (ARCHIVEBROWSER (CAR patternandfilter) - (CADR patternandfilter)) - NIL]) -) - - - -(* ;;; "command processing functions") - -(DEFINEQ - -(AB.When.Selected.Fn - [LAMBDA (Item Menu Key) (* N.H.Briggs "25-Jun-86 11:48") - (if (AND (LISTP Item) - (CADR Item)) - then (TB.PROCESS (LIST (FUNCTION AB.Command.Fn) - (KWOTE Item) - (KWOTE Menu) - (KWOTE Key)) - (PACK* 'AB- (CAR Item]) - -(AB.Command.Fn - [LAMBDA (item menu key) (* N.H.Briggs "18-Jun-86 13:09") - (RESETLST - (LET* [(realitem item) - (window (WINDOWPROP (WFROMMENU menu) - 'MAINWINDOW)) - (browser (WINDOWPROP window 'TABLEBROWSER] - [if (NOT (MEMBER item (fetch (MENU ITEMS) of menu))) - then (* A subitem -- fetch main item) - (SETQ item (for I in (fetch (MENU ITEMS) of menu) - thereis (AB.Subitemp item I] - (if (OBTAIN.MONITORLOCK (fetch (TABLEBROWSER TBLOCK) of browser) - T T) - then (RESETSAVE (SHADEITEM item menu MENUSELECTSHADE) - (LIST (FUNCTION SHADEITEM) - item menu WHITESHADE)) - (LET ((function (CADR realitem)) - (promptwindow (GETPROMPTWINDOW window)) - extra) - (if (OPENWP promptwindow) - then (CLEARW promptwindow)) - (if (LISTP function) - then (SETQ extra (CADR function)) - (SETQ function (CAR function))) - (APPLY* function browser extra)) - else (TB.BROWSER.BUSY browser))))]) - -(AB.Delete.Command - [LAMBDA (browser) (* N.H.Briggs "16-Apr-86 20:56") - (LET ((count 0)) - [TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) - (TB.DELETE.ITEM browser item) - (add count 1] - (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - count " item" (if (IGREATERP count 1) - then "s" - else "") - " marked for deletion."]) - -(AB.Expunge.Command - [LAMBDA (browser) (* N.H.Briggs "18-Jun-86 12:23") - (if (EQ (fetch (TABLEBROWSER TB#DELETED) of browser) - 0) - then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Nothing to expunge!") - else (LET [(directorystream (OPENSTREAM (PACKFILENAME 'VERSION NIL 'BODY (LISTGET (TB.USERDATA - browser) - 'ARCHIVE)) - 'OUTPUT] - (if (NOT directorystream) - then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Error opening (new version of) archive directory " - (LISTGET (TB.USERDATA browser) - 'ARCHIVE) - " ...aborted.") - else (LINELENGTH MAX.SMALLP directorystream) - (* ensure nothing wraps around) - (LISTPUT (TB.USERDATA browser) - 'ALLITEMS - (for item in (LISTGET (TB.USERDATA browser) - 'ALLITEMS) when (NOT (TB.ITEM.DELETED? browser item - )) - collect (printout directorystream (fetch (AB.item AB.Filename) - of (fetch (TABLEITEM TIDATA) - of item)) - %, - (fetch (AB.item AB.Creation.Date) - of (fetch (TABLEITEM TIDATA) of item))) - (for media on (fetch (AB.item AB.Media) - of (fetch (TABLEITEM TIDATA) of item)) - by (CDDR media) do (printout directorystream %,, - (CAR media)) - (printout directorystream %, - (CADR media)) - finally (printout directorystream T)) - item)) - (LISTPUT (TB.USERDATA browser) - 'ARCHIVE - (L-CASE (FULLNAME directorystream))) - (CLOSEF directorystream) - (AB.Set.Browser.Title browser) - (TB.MAP.DELETED.ITEMS browser (FUNCTION TB.REMOVE.ITEM]) - -(AB.Filter.Command - [LAMBDA (browser) (* N.H.Briggs "18-Jun-86 12:28") - (LET ((pattern (AB.Prompt.For.Input "Files matching what? " (LISTGET (TB.USERDATA browser) - 'FILTER) - browser T))) - (if pattern - then (LISTPUT (TB.USERDATA browser) - 'FILTER - (L-CASE pattern)) - (AB.Set.Browser.Title browser) - (AB.Recompute.Command browser]) - -(AB.Recompute.Command - [LAMBDA (browser newdirectory?) (* N.H.Briggs "19-Sep-86 12:34") - (LET* ((window (TB.WINDOW browser)) - (windowregion (WINDOWPROP window 'REGION)) - (region (CREATEREGION 0 0 (fetch (REGION WIDTH) of windowregion) - (fetch (REGION HEIGHT) of windowregion))) - (namewidth 0) - (userdata (TB.USERDATA browser)) - [filter (DIRECTORY.MATCH.SETUP (PACKFILENAME 'BODY (LISTGET userdata 'FILTER] - result) - (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser))) - then (if (MENU (create MENU - ITEMS _ '(("Expunge" 'Expunge "Expunge items marked for deletion" - ) - ("Don't Expunge" NIL - "Don't expunge items marked for deletion")) - TITLE _ "Expunge deleted items?" - CENTERFLG _ T)) - then (AB.Expunge.Command browser))) - (if (AND newdirectory? (SETQ result (AB.Prompt.For.Input "New archive directory? " NIL - browser T))) - then (LISTPUT userdata 'ARCHIVE (PACKFILENAME.STRING 'NAME (OR (FILENAMEFIELD - result - 'NAME) - 'Archive) - 'EXTENSION - (OR (FILENAMEFIELD result 'EXTENSION) - 'directory) - 'BODY result))) - (if (OR (NOT newdirectory?) - (AND newdirectory? result)) - then (TB.REPLACE.ITEMS browser) - (LISTPUT userdata 'ALLITEMS - (for item in (AB.Read.Directory browser) bind tableitem - eachtime (SETQ tableitem (create TABLEITEM - TIDATA _ item)) - collect (if (DIRECTORY.MATCH filter (PACKFILENAME 'BODY - (fetch (AB.item AB.Filename) - of item))) - then (SETQ namewidth (MAX namewidth - (STRINGWIDTH (fetch (AB.item - AB.Filename) - of item) - AB.browser.font))) - (TB.INSERT.ITEM browser tableitem)) - tableitem)) - (LISTPUT userdata 'NAMEWIDTH namewidth) - (TB.DISPLAY.LINES browser (TB.FIRST.VISIBLE.ITEM# browser region) - (TB.LAST.VISIBLE.ITEM# browser region]) - -(AB.Retrieve.Command - [LAMBDA (browser) (* N.H.Briggs " 3-Mar-87 12:41") - (DECLARE (GLOBALVARS AB.archivist)) - (PROG ((count 0) - registry corestream) - [SETQ registry (SELECTQ (OR (LAFITEMODE) - (\LAFITE.INFER.MODE)) - (GV ".pa") - (NS ":PA") - (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Can't retrieve -- Lafite mode must be set to GV or NS"] - (SETQ corestream (OPENSTREAM '{NODIRCORE} 'BOTH)) - (LINELENGTH MAX.SMALLP corestream) - (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " - (FULLUSERNAME) - T T) - [TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) - (printout corestream "Retrieve: " - (fetch (AB.item AB.Filename) - of (fetch (TABLEITEM TIDATA) - of item)) - " of " - (fetch (AB.item AB.Creation.Date) - of (fetch (TABLEITEM TIDATA) - of item)) - " from " - (CAR (fetch (AB.item AB.Media) - of (fetch (TABLEITEM TIDATA) - of item))) - " or " - (CADR (fetch (AB.item AB.Media) - of (fetch (TABLEITEM TIDATA) - of item))) - T) - (add count 1] - (SETQ corestream (OPENTEXTSTREAM corestream)) - (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Sending mail to " AB.archivist registry " requesting " count " file" - (if (NEQ count 1) - then "s: " - else ": ")) - (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) - then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - " done.") - else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - " failed."]) - -(AB.Retrieve.Directory.Command - [LAMBDA (browser) (* N.H.Briggs " 3-Mar-87 12:41") - (DECLARE (GLOBALVARS AB.archivist)) - (PROG ((count 0) - registry corestream newdirectory) - [SETQ registry (SELECTQ (OR (LAFITEMODE) - (\LAFITE.INFER.MODE)) - (GV ".pa") - (NS ":PA") - (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Can't retrieve -- Lafite mode must be set to GV or NS"] - (if (NOT (SETQ newdirectory (AB.Prompt.For.Input "Directory to retrieve into? " NIL browser - T))) - then (RETURN)) - (SETQ corestream (OPENSTREAM '{NODIRCORE} 'BOTH)) - (LINELENGTH MAX.SMALLP corestream) - (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " - (FULLUSERNAME) - T T) - [TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) - (printout - corestream "Retrieve: " - (fetch (AB.item AB.Filename) - of (fetch (TABLEITEM TIDATA) of item)) - " of " - (fetch (AB.item AB.Creation.Date) - of (fetch (TABLEITEM TIDATA) of item)) - " from " - (CAR (fetch (AB.item AB.Media) - of (fetch (TABLEITEM TIDATA) - of item))) - " or " - (CADR (fetch (AB.item AB.Media) - of (fetch (TABLEITEM TIDATA) - of item))) - " as " - [AB.Make.Cedar.Filename - (PACKFILENAME.STRING - 'DIRECTORY newdirectory 'VERSION NIL - 'BODY - (fetch (AB.item AB.Filename) - of (fetch (TABLEITEM TIDATA) of item] - T) - (add count 1] - (SETQ corestream (OPENTEXTSTREAM corestream)) - (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Sending mail to " AB.archivist registry " requesting " count " file" - (if (NEQ count 1) - then "s: " - else ": ")) - (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) - then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - " done.") - else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - " failed."]) - -(AB.Retrieve.Renamed.Command - [LAMBDA (browser) (* N.H.Briggs " 3-Mar-87 12:34") - (DECLARE (GLOBALVARS AB.archivist)) - (PROG ((count 0) - registry corestream) - (DECLARE (SPECVARS corestream count)) - [SETQ registry (SELECTQ (OR (LAFITEMODE) - (\LAFITE.INFER.MODE)) - (GV ".pa") - (NS ":PA") - (RETURN (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Can't retrieve -- Lafite mode must be set to GV or NS"] - (SETQ corestream (OPENSTREAM '{NODIRCORE} 'BOTH)) - (LINELENGTH MAX.SMALLP corestream) - (printout corestream "Subject: Retrieve request" T "To: " AB.archivist registry T "cc: " - (FULLUSERNAME) - T T) - (TB.MAP.SELECTED.ITEMS browser (FUNCTION AB.Retrieve.Renamed.Aux)) - (if (EQ count 0) - then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Nothing to retrieve.") - (CLOSEF corestream) - (RETURN)) - (SETQ corestream (OPENTEXTSTREAM corestream)) - (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - "Sending mail to " AB.archivist registry " requesting " count " file" - (if (NEQ count 1) - then "s: " - else ": ")) - (if (CAR (ERSETQ (LAFITE.SENDMESSAGE corestream))) - then (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - " done.") - else (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - " failed."]) - -(AB.Retrieve.Renamed.Aux - [LAMBDA (browser item) (* N.H.Briggs " 3-Mar-87 12:38") - (LET ((newname (AB.Prompt.For.Input (CONCAT "Retrieve " (fetch (AB.item AB.Filename) - of (fetch (TABLEITEM TIDATA) - of item)) - " as ?") - (fetch (AB.item AB.Filename) of (fetch (TABLEITEM TIDATA) of item)) - browser "... skipped"))) - (if newname - then (printout corestream "Retrieve: " (fetch (AB.item AB.Filename) - of (fetch (TABLEITEM TIDATA) of item)) - " of " - (fetch (AB.item AB.Creation.Date) of (fetch (TABLEITEM TIDATA) of item)) - " from " - (CAR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) - " or " - (CADR (fetch (AB.item AB.Media) of (fetch (TABLEITEM TIDATA) of item))) - " as " - (AB.Make.Cedar.Filename (PACKFILENAME.STRING 'VERSION NIL 'BODY newname)) - T) - (add count 1)) - (HELP]) - -(AB.Sort.Command - [LAMBDA (browser sorttype) (* N.H.Briggs "17-Jun-86 12:47") - (LET ((items (fetch (TABLEBROWSER TBITEMS) of browser))) - [if (EQ sorttype 'Reverse) - then (SETQ items (DREVERSE items)) - else (SORT items (SELECTQ sorttype - (CreationDate [FUNCTION (LAMBDA (x y) - (IGREATERP - (IDATE (fetch (AB.item AB.Creation.Date) - of (fetch (TABLEITEM TIDATA) - of x))) - (IDATE (fetch (AB.item AB.Creation.Date) - of (fetch (TABLEITEM TIDATA) - of y]) - (Archive [FUNCTION (LAMBDA (x y) - (ILESSP (fetch (AB.item AB.Sequence.Number) - of (fetch (TABLEITEM TIDATA) - of x)) - (fetch (AB.item AB.Sequence.Number) - of (fetch (TABLEITEM TIDATA) - of y]) - (FUNCTION (LAMBDA (x y) - (ALPHORDER (fetch (AB.item AB.Filename) - of (fetch (TABLEITEM TIDATA) of x)) - (fetch (AB.item AB.Filename) - of (fetch (TABLEITEM TIDATA) of y)) - (UPPERCASEARRAY] - (for item in items as i from 1 do (replace TI# of item with i)) - (TB.REPLACE.ITEMS browser items) - (TB.REDISPLAY.ITEMS browser]) - -(AB.Undelete.Command - [LAMBDA (browser all?) (* N.H.Briggs "16-Apr-86 21:01") - (LET ((count 0)) - [if all? - then [TB.MAP.DELETED.ITEMS browser (FUNCTION (LAMBDA (browser item) - (TB.UNDELETE.ITEM browser item) - (add count 1] - else (TB.MAP.SELECTED.ITEMS browser (FUNCTION (LAMBDA (browser item) - (TB.UNDELETE.ITEM browser item) - (add count 1] - (printout (GETPROMPTWINDOW (TB.WINDOW browser)) - count " item" (if (NEQ count 1) - then "s" - else "") - " undeleted."]) -) - - - -(* ;;; "miscellaneous functions") - -(DEFINEQ - -(AB.Set.Browser.Title - [LAMBDA (browser) (* N.H.Briggs "17-Jun-86 15:45") - (LET [(archive (LISTGET (TB.USERDATA browser) - 'ARCHIVE)) - (filter (LISTGET (TB.USERDATA browser) - 'FILTER] - (WINDOWPROP (GETPROMPTWINDOW (TB.WINDOW browser)) - 'TITLE - (CONCAT "Archive Browser" (OR (AND archive (CONCAT " " archive)) - "") - (OR (AND filter (CONCAT " - files " filter)) - ""]) - -(AB.Iconfn - [LAMBDA (window icon) (* N.H.Briggs "19-Sep-86 18:58") - (DECLARE (GLOBALVARS AB.titled.icon)) - (LET* [(browser (WINDOWPROP window 'TABLEBROWSER)) - (archive (LISTGET (TB.USERDATA browser) - 'ARCHIVE)) - (directory (UNPACKFILENAME.STRING archive 'DIRECTORY)) - (host (UNPACKFILENAME.STRING archive 'HOST)) - (title (PACKFILENAME.STRING 'HOST host 'DIRECTORY (SUBSTRING directory 1 (STRPOS directory - ">"] - (if icon - then (ICONW.TITLE icon title) - icon - else (TITLEDICONW AB.titled.icon title (FONTCREATE 'MODERN 8) - NIL NIL NIL (CHARCODE (}]) - -(AB.Closefn - [LAMBDA (window) (* edited%: "20-Jun-86 12:42") - (LET [(browser (WINDOWPROP window 'TABLEBROWSER] - (if (NOT (ZEROP (fetch (TABLEBROWSER TB#DELETED) of browser))) - then (if (MENU (create MENU - ITEMS _ '(("Expunge" 'Expunge "Expunge items marked for deletion") - ("Don't Expunge" NIL - "Don't expunge items marked for deletion")) - TITLE _ "Expunge deleted items?" - CENTERFLG _ T)) - then (AB.Expunge.Command browser))) - NIL]) - -(AB.Printfn - [LAMBDA (browser item window) (* N.H.Briggs "22-Sep-86 13:09") - (LET* ((entry (fetch TIDATA of item)) - (namewidth (OR (LISTGET (TB.USERDATA browser) - 'NAMEWIDTH) - 0)) - (offset (DSPXPOSITION NIL window)) - (datestart (IPLUS offset namewidth 10))) - - (* if this is to work for variable spaced fonts it has to be smart about the - widths of date and media fields too) - - (PRIN1 (fetch (AB.item AB.Filename) of entry) - window) - (if (ZEROP namewidth) - then (PRIN1 " " window) - else (BLTSHADE WHITESHADE window (DSPXPOSITION NIL window) - (IDIFFERENCE (DSPYPOSITION NIL window) - (FONTPROP AB.browser.font 'DESCENT)) - (IDIFFERENCE datestart (DSPXPOSITION NIL window)) - (FONTPROP AB.browser.font 'HEIGHT)) - (DSPXPOSITION datestart window)) - (PRIN1 (fetch (AB.item AB.Creation.Date) of entry) - window) - (PRIN1 " " window) - (for media in (fetch (AB.item AB.Media) of entry) do (PRIN1 media window) - (PRIN1 " " window]) - -(AB.Prompt.For.Input - [LAMBDA (prompt default browser abortflag) (* N.H.Briggs "22-Apr-86 17:32") - - (* * Prompt for input for browser browser with question prompt offering default - answer DEFAULT. If abortflag is true and response is NIL, prints "... aborted" or - abortflag (should be a text string)) - - (LET* ((promptwindow (GETPROMPTWINDOW (TB.WINDOW browser))) - (promptwidth (STRINGWIDTH prompt promptwindow)) - (windowwidth (WINDOWPROP promptwindow 'WIDTH)) - result) - (CLEARW promptwindow) - [if (IGREATERP (IPLUS promptwidth (STRINGWIDTH (OR default "XXX") - promptwindow)) - windowwidth) - then - - (* Prompt plus default response will overflow the width of the window, so be a - nice guy and break it up) - - (for i from (IDIFFERENCE (NCHARS prompt) - 4) to 10 by -1 bind (excesswidth _ (IDIFFERENCE promptwidth - windowwidth)) - when (AND (EQ (NTHCHARCODE prompt i) - (CHARCODE SPACE)) - (IGREATERP (STRINGWIDTH (SUBSTRING prompt i) - promptwindow) - excesswidth)) - do (RETURN (SETQ prompt (CONCAT (SUBSTRING prompt 1 (IPLUS i -1)) - " -" - (SUBSTRING prompt (IPLUS i 1] - [SETQ result (CAR (NLSETQ (PROMPTFORWORD prompt default NIL promptwindow NIL 'TTY - (CHARCODE (CR ESC] - (if (AND (EQ result NIL) - abortflag) - then (PRINTOUT promptwindow (if (EQ abortflag T) - then "... aborted" - else abortflag))) - (TERPRI promptwindow) - result]) - -(AB.Read.Directory - [LAMBDA (browser) (* N.H.Briggs "22-Sep-86 12:53") - (LET ([directorystream (AND (LISTGET (TB.USERDATA browser) - 'ARCHIVE) - (CAR (NLSETQ (OPENSTREAM (LISTGET (TB.USERDATA browser) - 'ARCHIVE) - 'INPUT] - (linerdtable (COPYREADTABLE 'ORIG)) - (promptwindow (GETPROMPTWINDOW (TB.WINDOW browser))) - items) - (if (NOT directorystream) - then (printout promptwindow "Can't find archive directory " (LISTGET (TB.USERDATA - browser) - 'ARCHIVE)) - (LISTPUT (TB.USERDATA browser) - 'ARCHIVE NIL) - (AB.Set.Browser.Title browser) - NIL - else (LISTPUT (TB.USERDATA browser) - 'ARCHIVE - (L-CASE (FULLNAME directorystream))) - (AB.Set.Browser.Title browser) - (SETSEPR (LIST (CONSTANT (CHARCODE EOL))) - NIL linerdtable) - (SETBRK NIL NIL linerdtable) - (bind start end inputline repeatuntil (EOFP directorystream) - eachtime (SETQ inputline (RSTRING directorystream linerdtable)) - (READC directorystream) as i from 1 - collect (create AB.item - AB.Filename _ [L-CASE (SUBSTRING inputline 1 - (SUB1 (SETQ end (STRPOS " " inputline] - AB.Creation.Date _ [SUBSTRING inputline (ADD1 end) - (SUB1 (SETQ end (STRPOS " " inputline - (ADD1 end] - AB.Media _ [first (SETQ end (ADD1 end)) repeatwhile end - eachtime (SETQ start (ADD1 end)) - (while (EQUAL (SUBSTRING inputline start start) - " ") do (SETQ start (ADD1 start)) - ) - (SETQ end (STRPOS " " inputline start)) - collect (SUBSTRING inputline start - (AND end (SUB1 end] - AB.Sequence.Number _ i) finally (CLOSEF directorystream]) - -(AB.Subitemp - [LAMBDA (subitem item) (* N.H.Briggs "16-Apr-86 18:32") - - (* * True if subitem appears among the subitems of item or descendents) - - (LET ((sub (CADDDR item))) - (AND sub (EQ (CAR (LISTP sub)) - 'SUBITEMS) - (OR (MEMBER subitem sub) - (for i in (CDR sub) thereis (AB.Subitemp subitem i]) - -(AB.Make.Cedar.Filename - [LAMBDA (filename) (* N.H.Briggs " 3-Mar-87 12:08") - (LET ((unpackedfilename (UNPACK filename))) - (PACK (SUBLIS '(({ . %[) - (} . %]) - (; . !)) - unpackedfilename]) -) - - - -(* ;;; "the user that gets retrieval requests") - - -(RPAQ? AB.archivist "Archivist") - - - -(* ;;; "the structure for an archive entry") - -(DECLARE%: EVAL@COMPILE - -(RECORD AB.item (AB.Filename AB.Creation.Date AB.Media AB.Sequence.Number)) -) - - - -(* ;;; "the icon") - - -(RPAQQ AB.icon #*(73 73)OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@O@@@@@@AN@@@@@@@@AH@ML@@@@@CK@@@@@@@@AH@LOOOOOOOOOOOOOOOOIH@LJ@@@@@DHG@@@@@@AIH@LK@@@@AHHAL@@@@@FIH@LIH@@@A@H@GH@@@@LIH@LHF@@@G@H@@OL@@GHIH@LHC@@COOOOOOGOOO@IH@LHAH@C@CN@@A@@@F@IH@LH@LON@FK@@A@@AL@IH@LH@FNBAOOOOA@@CL@IH@LH@CLBCHHL@A@@FH@IH@LH@AKOOOOOOI@@MH@IH@LH@ADB@@L@LA@AI@@IH@LH@ANB@@L@CA@FA@@IH@LH@@KCOOOOOOMOC@@IH@LH@@IH@CL@@@CJB@@IH@LH@@HH@FF@@@GBB@@IH@LH@@HDALG@@@LFC@@IH@LH@@HCOOOOOOHDA@@IH@LH@@HCL@F@@G@DA@@IH@LH@@HAOOOOOO@DAH@IH@OH@AHAOOOOOO@D@H@IH@LO@C@AOOOOOO@D@L@IH@LION@CAHC@FA@D@GHIH@LH@N@F@HA@LA@D@AOIH@LH@GNL@DAAHAHBAO@IH@LH@BGO@CAB@@LCOB@IH@LH@B@MNAIFAOOO@F@IH@LH@B@DCLOMNCHB@D@IH@LH@B@D@COO@F@B@D@IH@LH@B@D@@FGLB@B@D@IH@LH@B@L@GL@CO@C@F@IH@LH@B@HCL@@@GNAHC@IH@LH@FAKL@@@@@AOLAHIH@LH@DAL@@@@@@@AN@LIH@LH@OO@@@@@@@@@CNFIH@LHCL@@@@@@@@@@@CNIH@OOO@@@@@@@@@@@@@AIH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LH@@@@@@@@@@@@@@@IH@LOOOOOOOOOOOOOOOOIH@L@@@@@@@@@@@@@@@@AH@L@@@@@@@@@@@@@@@@AH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@ -) - -(RPAQQ AB.icon.mask #*(73 73)OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOH@ -) - -(RPAQ? AB.titled.icon (create TITLEDICON ICON _ AB.icon MASK _ AB.icon.mask TITLEREG _ - (CREATEREGION 7 8 60 24))) - - - -(* ;;; "the font for the browser, which must be a fixed pitch font for now") - - -(RPAQ AB.browser.font (FONTCREATE 'TERMINAL 10)) - - - -(* ;;; "based on the TableBrowser package") - - - - -(* ;;; " took out WORDFNS") - - -(FILESLOAD TABLEBROWSER) - - - -(* LOAD the FILEBROWSER first) - - -(FILESLOAD FILEBROWSER) - - - -(* ArchiveTool File Browser Interface Functions) - -(DEFINEQ - -(Arch.ConvertToCedarFileName - [LAMBDA (FileEntry LispFileName BROWSER) (* ; "Edited 1-Dec-88 12:47 by bbb") - -(* ;;; "Convert a Lisp file name to a Cedar filename with the [host] naming convention and the ! version numbering") - - (DECLARE (GLOBALVARS OKCedarCharBitTable)) - (DECLARE (SPECVARS SkippedBadFileName)) - (LET* ((UnpackedName (UNPACKFILENAME.STRING LispFileName)) - (Host (LISTGET UnpackedName 'HOST)) - (Name (LISTGET UnpackedName 'NAME)) - (Extension (LISTGET UnpackedName 'EXTENSION)) - (Directory (LISTGET UnpackedName 'DIRECTORY)) - (Version (LISTGET UnpackedName 'VERSION)) - BadCharPos NewLispFileName (OldLispFileName (ALLOCSTRING (NCHARS LispFileName))) - (GoodFileName T) - DirectoryEnd) - (if (OR (STRING-EQUAL Host "Core") - (STRPOS ":" Host) - (STRPOS "dsk" (L-CASE Host) - 1) - (STRPOS "/n" Host) - (STRING-EQUAL Host "Floppy")) - then - - (* ;; "we can only archive files on an IFS (as of June/88)") - - (FB.PROMPTWPRINT BROWSER T (CONCAT - "You can only archive files stored on an IFS. The host " - Host " is NOT an IFS!")) - (SETQ GoodFileName NIL) - elseif (AND (STRING-EQUAL Name "") - (STRING-EQUAL Extension "")) - then - - (* ;; "This is a file with no name - we want to skip the dif files") - - (SETQ GoodFileName NIL) - elseif (AND (STRING-EQUAL (L-CASE Name) - "archive") - (STRING-EQUAL (L-CASE Extension) - "directory")) - then - - (* ;; - " we don't want to ask to archive the file archive.directory so just skip it") - - (SETQ GoodFileName NIL) - elseif (STRPOS ":" LispFileName 1) - then (FB.PROMPTWPRINT BROWSER T (CONCAT LispFileName - " has a colon in the name which Lisp can't handle." - ) - " You need to manually call RENAMEFILE to eliminate the colons quoting all colons with a single quote." - ) - (SETQ GoodFileName NIL) - elseif (SETQ BadCharPos (STRPOSL OKCedarCharBitTable Name 1 T)) - then (FB.PROMPTWPRINT BROWSER T "Invalid character %"" (NTHCHAR Name BadCharPos) - "%" in file " LispFileName ". Only alphanumeric and .$-+ are allowed." - ) - (if (STRING-EQUAL (FB.PROMPTFORINPUT - "Shall I replace all bad chars with $ (Y/N):" "Y" - BROWSER NIL T) - "Y") - then (SETQ OldLispFileName (CONCAT LispFileName)) - (while (AND BadCharPos (ILEQ BadCharPos (NCHARS Name))) - do (SETQ Name (RPLCHARCODE Name BadCharPos (CHARCODE $))) - (SETQ BadCharPos (STRPOSL OKCedarCharBitTable Name BadCharPos - T))) - (SETQ NewLispFileName (PACKFILENAME.STRING 'NAME Name 'BODY - LispFileName)) - (FB.COPY/RENAME.ONE BROWSER FileEntry OldLispFileName NewLispFileName - 'Rename - (FUNCTION RENAMEFILE)) - else (FB.PROMPTWPRINT BROWSER "Skipping " LispFileName ".") - (SETQ SkippedBadFileName T) - (SETQ GoodFileName NIL))) - (if GoodFileName - then (L-CASE (CONCAT "[" Host "]<" Directory ">" Name - (if (NOT (STRING-EQUAL Extension "")) - then (CONCAT "." Extension) - else "") - "!" Version]) - -(FB.ArchiveCommand - [LAMBDA (BROWSER) (* N.H.Briggs " 3-Apr-86 20:43") - - (* * Called from FileBrowser Archive command -- - Archive all selected files) - - (FB.DoArchiveCommands BROWSER 'Archive]) - -(FB.ArchiveAllCommand - [LAMBDA (BROWSER) (* ; "Edited 28-Apr-88 17:58 by bbb") - - (* * Called from FileBrowser Archive All Files command -- - Archive all files) - - (FB.DoArchiveCommands BROWSER 'ArchiveAll]) - -(FB.ArchiveAndDeleteCommand - [LAMBDA (BROWSER) (* ; "Edited 28-Apr-88 15:47 by bbb") - - (* * Called from FileBrowser Archive and Delete command -- - Archive and Delete all selected files) - - (FB.DoArchiveCommands BROWSER 'ArchiveAndDelete]) - -(FB.ArchiveAndDeleteAllCommand - [LAMBDA (BROWSER) (* ; "Edited 28-Apr-88 16:52 by bbb") - - (* * Called from FileBrowser Archive and Delete All Files command -- - Archive and Delete all files) - - (FB.DoArchiveCommands BROWSER 'ArchiveAndDeleteAll]) - -(FB.DoArchiveCommands - [LAMBDA (BROWSER TypeOfArchive) (* ; "Edited 10-Mar-89 17:03 by bbb") - -(* ;;; "Called from FileBrowser Archive command -- Archive all selected files") - - (DECLARE (GLOBALVARS Arch.CcToSelfFlg)) - (FB.ALLOW.ABORT BROWSER) - (PROG (FileEntriesList REGISTRY CoreStream CedarFileNameList Pattern MakeRequestFLG FilesSelected - ArchivedFiles ArchiveDirectory DotStarPosition SkippedBadFileName) - (if (OR (EQ TypeOfArchive 'Archive) - (EQ TypeOfArchive 'ArchiveAndDelete)) - then (SETQ FilesSelected T)) - (SETQ Pattern (Arch.ConvertToCedarFileName NIL (fetch PATTERN of BROWSER) - BROWSER)) - - (* ;; "Now we need to fix the pattern because in Cedar *.* will only match files that do have extensions. If there is a %".*%" then replace this with %"*%"") - - [if (NULL Pattern) - then (RETURN) - elseif (SETQ DotStarPosition (STRPOS ".*" Pattern)) - then (SETQ Pattern (CONCAT (SUBSTRING Pattern 1 (SUB1 DotStarPosition)) - (if (NEQ (NTHCHAR Pattern (SUB1 DotStarPosition)) - '*) - then "*" - else "") - (SUBSTRING Pattern (PLUS 2 DotStarPosition] - [SETQ FileEntriesList (if FilesSelected - then (FB.SELECTEDFILES BROWSER) - else (* ; - "Collect everything that is not a directory item") - (TB.COLLECT.ITEMS (fetch (FILEBROWSER TABLEBROWSER) - of BROWSER) - (FUNCTION (LAMBDA (BROWSER ITEM) - (NOT (fetch TIUNSELECTABLE - of ITEM] - (if (NULL FileEntriesList) - then (RETURN)) - (if (AND Arch.VerifyNotArchivedFlg [SETQ ArchiveDirectory - (PACKFILENAME.STRING 'NAME "Archive" 'EXTENSION - "Directory" 'VERSION NIL 'BODY - (SUBSTRING Pattern 1 (STRPOS ">" Pattern 1] - (INFILEP ArchiveDirectory)) - then (SETQ ArchivedFiles (CL:MAKE-HASH-TABLE :TEST 'CL:EQUAL)) - - (* ;; - "Note that the Archive.Directory has: Filename <1 or more spaces> CreationDate <2 spaces>") - - (LET ((ArchiveDirectoryStream (OPENSTREAM ArchiveDirectory 'INPUT)) - Line EOFP) - (while (AND (SETQ Line (CL:READ-LINE ArchiveDirectoryStream EOFP)) - (NULL EOFP)) bind End FileName CreationDate - do (SETQ End (STRPOS " " Line)) - [SETQ FileName (CONCAT (L-CASE (SUBSTRING Line 1 (SUB1 End] - [SETQ CreationDate (IDATE (SUBSTRING Line (ADD1 End) - (SUB1 (STRPOS " " Line - (ADD1 End] - (CL:SETF (CL:GETHASH FileName ArchivedFiles) - CreationDate)) - (CLOSEF ArchiveDirectoryStream)) (* COLLECTWORDFILE ArchiveDirectory - (FUNCTION (LAMBDA (Line) - (LET* ((End (STRPOS " " Line)) - (FileName (CONCAT (L-CASE - (SUBSTRING Line 1 (SUB1 End))))) - (CreationDate (IDATE - (SUBSTRING Line (ADD1 End) - (SUB1 (STRPOS " " Line - (ADD1 End))))))) (CL:SETF - (CL:GETHASH FileName ArchivedFiles) - CreationDate)))) NIL - (FUNCTION DREADLINE) T)) - -(* ;;; "Determine right away if they can send mail to the Archivist") - - [SETQ REGISTRY (SELECTQ (OR (LAFITEMODE) - (\LAFITE.INFER.MODE)) - (GV ".pa") - (NS ":PA") - (RETURN (FB.PROMPTWPRINT BROWSER T - "Can't -- Lafite mode must be set to GV or NS"] - (if FilesSelected - then (FB.PROMPTWPRINT BROWSER "Validating and preparing archive request for " - (CONCAT (LENGTH FileEntriesList) - " file" - (COND - ((CDR FileEntriesList) - "s") - (T ""))) - ".")) - -(* ;;; "Convert the file names and enter them into the msg. SkippedBadFileName is set to T in Arch.ConvertToCedarFileName if there is an invalid Cedar file which the user chooses not to rename to a valid name") - - (SETQ SkippedBadFileName NIL) - (SETQ CedarFileNameList - (for FileName - in (bind CedarFileName ArchivedFileDate for FileEntry in - FileEntriesList - when (AND (SETQ CedarFileName (Arch.ConvertToCedarFileName - FileEntry - (FB.FETCHFILENAME FileEntry) - BROWSER)) - (if (NULL ArchivedFiles) - then T - else (SETQ ArchivedFileDate (CL:GETHASH CedarFileName - ArchivedFiles)) - (if (EQP ArchivedFileDate (GETFILEINFO ( - FB.FETCHFILENAME - FileEntry) - 'ICREATIONDATE)) - then (FB.PROMPTWPRINT BROWSER T ( - FB.FETCHFILENAME - FileEntry) - " has already been archived!" - " Skipping it.") - (SETQ SkippedBadFileName T) - NIL - else T))) collect CedarFileName) collect - FileName)) - (if CedarFileNameList - then [if (AND (NOT FilesSelected) - SkippedBadFileName) - then - - (* ;; "the person has asked to archive and delete all the files in the browser yet something was wrong with some of their names or else it has already been archived") - - (SETQ TypeOfArchive (SELECTQ TypeOfArchive - (ArchiveAll 'Archive) - (ArchiveAndDeleteAll - 'ArchiveAndDelete) - (SHOULDNT] - -(* ;;; "Setup the header fields for the msg") - - (SETQ CoreStream (OPENSTREAM '{NODIRCORE} 'BOTH)) - (LINELENGTH 1000 CoreStream) (* ; "In case of long file names") - -(* ;;; "Old code (printout CoreStream %"Subject: Archive request%" T %"To: Archivist%" REGISTRY T %"Cc: %")") - - (printout CoreStream "Subject: Archive request" (SELECTQ TypeOfArchive - ((ArchiveAll - ArchiveAndDeleteAll) - - (CONCAT - " for all files in " - Pattern)) - (CONCAT " for some files in " - Pattern)) - T "To: Archivist" REGISTRY T "Cc: ") - [COND - (Arch.CcToSelfFlg (printout CoreStream (FULLUSERNAME] - (TERPRI CoreStream) - (TERPRI CoreStream) - (SELECTQ TypeOfArchive - (ArchiveAll (printout CoreStream "Archive: " Pattern) - (SETQ MakeRequestFLG T)) - (ArchiveAndDeleteAll - (printout CoreStream "ArchiveAndDelete: " Pattern) - (SETQ MakeRequestFLG T)) - ((Archive ArchiveAndDelete) - (for CedarFileName in CedarFileNameList when CedarFileName - do (SELECTQ TypeOfArchive - (Archive (printout CoreStream "Archive: " CedarFileName T - )) - (ArchiveAndDelete - (printout CoreStream "ArchiveAndDelete: " - CedarFileName T)) - (SHOULDNT)) - (SETQ MakeRequestFLG T))) - (SHOULDNT)) - -(* ;;; "Send the mail off thru the Grapevine") - - (if MakeRequestFLG - then (SETQ CoreStream (OPENTEXTSTREAM CoreStream NIL NIL NIL - (LIST 'FONT LAFITEEDITORFONT))) - (ADD.PROCESS (LIST (FUNCTION \SENDMESSAGE) - (KWOTE CoreStream)) - 'NAME - 'ArchiveRequest]) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS Arch.CcToSelfFlg Arch.VerifyNotArchivedFlg OKCedarCharBitTable) -) - -(RPAQ OKCedarCharBitTable - [MAKEBITTABLE (APPEND (CHARCODE (%. $ - + * < > { })) - (for i from (CHARCODE a) - to - (CHARCODE z) - collect i) - (for i from (CHARCODE A) - to - (CHARCODE Z) - collect i) - (CHARCODE (0 1 2 3 4 5 6 7 8 9]) - -(RPAQ? Arch.CcToSelfFlg T) - -(RPAQ? Arch.VerifyNotArchivedFlg NIL) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(ADDTOVAR BackgroundMenuCommands (ArchiveBrowser '(ARCHIVEBROWSER) - "Brings up an archive browser")) - - -(SETQ BackgroundMenu) -) -(DECLARE%: EVAL@COMPILE DONTCOPY - -(FILESLOAD (SOURCE) - TABLEBROWSERDECLS) - - -(FILESLOAD (LOADCOMP) - FILEBROWSER) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -[if (NOT (SASSOC "Archive" FB.MENU.ITEMS)) - then (PUTASSOC "Archive" '(FB.ArchiveCommand - "Archives selected files by sending mail to Archivist.pa" - (SUBITEMS ("Archive" FB.ArchiveCommand - "Archives selected files by sending mail to Archivist.pa" - ) - ("Archive ALL Files" FB.ArchiveAllCommand - "Archives ALL files in the browser by sending mail to Archivist.pa" - ) - ("Archive and Delete" FB.ArchiveAndDeleteCommand - "Archives selected files by sending an Archive and Delete request to Archivist.pa" - ) - ("Archive and Delete ALL Files" - FB.ArchiveAndDeleteAllCommand - "Archives ALL files in the browser by sending an Archive and Delete request to Archivist.pa" - ))) - FB.MENU.ITEMS) - else (RPLACD (SASSOC "Archive" FB.MENU.ITEMS) - '(FB.ArchiveCommand "Archives selected files by sending mail to Archivist.pa" - (SUBITEMS ("Archive" FB.ArchiveCommand - "Archives selected files by sending mail to Archivist.pa") - ("Archive ALL Files" FB.ArchiveAllCommand - "Archives ALL files in the browser by sending mail to Archivist.pa" - ) - ("Archive and Delete" FB.ArchiveAndDeleteCommand - "Archives selected files by sending an Archive and Delete request to Archivist.pa" - ) - ("Archive and Delete ALL Files" FB.ArchiveAndDeleteAllCommand - "Archives ALL files in the browser by sending an Archive and Delete request to Archivist.pa" - ] -) - - - -(* Functions that aren't used any more) - -(DEFINEQ - -(Arch.ParseReturnMsg - [LAMBDA (Window) (* bvm%: "19-Sep-85 12:32") - - (* * Parse an archive response msg contained in Window. - Returns a list of the files archived.) - - (PROG (TextObj TextStream CHAR#) - (RETURN - (COND - ((WINDOWP Window) - (SETQ TextObj (WINDOWPROP Window 'TEXTOBJ)) - (SETQ TextStream (WINDOWPROP Window 'TEXTSTREAM)) - (SETQ CHAR# 0) - (while (SETQ CHAR# (TEDIT.FIND TextStream "Archived:" (ADD1 CHAR#))) - collect (PACKFILENAME 'BODY - (U-CASE (PACKC (DSUBLIS (CHARCODE (("[" . "{") - ("]" . "}"))) - (PROGN (SETFILEPTR TextStream CHAR#) - (READ TextStream) - (until (NEQ (PEEKC TextStream) - '% ) - do (BIN TextStream)) - (until (EQ (PEEKC TextStream) - '% ) - collect (BIN TextStream]) - -(Arch.BackgroundMenuFn - [LAMBDA NIL (* fgh%: " 6-Feb-85 01:03") - - (* * Archive tool called from background menu. - Get from the user a window containing an archive system response message, parse - the messsage, and delete the archived files.) - - (PROG (Window PromptWindow FileList) - (PROMPTPRINT "Click in the window containing the response from Archivist.pa") - (SETQ Window (WHICHW (GETPOSITION))) - (CLRPROMPT) - (COND - ([AND (WINDOWP Window) - (TEXTSTREAMP (WINDOWPROP Window 'TEXTSTREAM] - (SETQ FileList (Arch.ParseReturnMsg Window)) - (COND - [FileList (SETQ PromptWindow (GETPROMPTWINDOW Window 5)) - (COND - ((MEMBER (PROMPTFORWORD "Okay to delete files? " "Yes" NIL PromptWindow) - '("Yes" "yes" "Y" "y")) - (CLEARW PromptWindow) - (bind Deleted? for File in FileList - do (SETQ Deleted? (DELFILE File)) - (printout PromptWindow (CONCAT File (COND - (Deleted? " deleted.") - (T " not deleted."))) - T) - (DISMISS 500)) - (printout PromptWindow "Deletions Completed" T) - (DISMISS 2000) - (REMOVEPROMPTWINDOW Window] - (T (SETQ PromptWindow (GETPROMPTWINDOW Window 1)) - (printout PromptWindow "No archived files found in message.") - (DISMISS 2000) - (REMOVEPROMPTWINDOW Window]) -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA AB) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA ) -) -(PUTPROPS ARCHIVETOOL COPYRIGHT ("Xerox Corporation" 1985 1986 1988 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (7582 15419 (ARCHIVEBROWSER 7592 . 15136) (AB 15138 . 15417)) (15467 38810 ( -AB.When.Selected.Fn 15477 . 15895) (AB.Command.Fn 15897 . 17465) (AB.Delete.Command 17467 . 18090) ( -AB.Expunge.Command 18092 . 21221) (AB.Filter.Command 21223 . 21826) (AB.Recompute.Command 21828 . -25391) (AB.Retrieve.Command 25393 . 28482) (AB.Retrieve.Directory.Command 28484 . 32193) ( -AB.Retrieve.Renamed.Command 32195 . 34005) (AB.Retrieve.Renamed.Aux 34007 . 35508) (AB.Sort.Command -35510 . 37893) (AB.Undelete.Command 37895 . 38808)) (38853 48488 (AB.Set.Browser.Title 38863 . 39473) -(AB.Iconfn 39475 . 40325) (AB.Closefn 40327 . 41097) (AB.Printfn 41099 . 42508) (AB.Prompt.For.Input -42510 . 44744) (AB.Read.Directory 44746 . 47727) (AB.Subitemp 47729 . 48164) (AB.Make.Cedar.Filename -48166 . 48486)) (52285 70125 (Arch.ConvertToCedarFileName 52295 . 56895) (FB.ArchiveCommand 56897 . -57174) (FB.ArchiveAllCommand 57176 . 57465) (FB.ArchiveAndDeleteCommand 57467 . 57789) ( -FB.ArchiveAndDeleteAllCommand 57791 . 58120) (FB.DoArchiveCommands 58122 . 70123)) (73559 77045 ( -Arch.ParseReturnMsg 73569 . 75078) (Arch.BackgroundMenuFn 75080 . 77043))))) -STOP diff --git a/obsolete/lispusers/ARCHIVETOOL.LCOM b/obsolete/lispusers/ARCHIVETOOL.LCOM deleted file mode 100644 index 28243eeb..00000000 Binary files a/obsolete/lispusers/ARCHIVETOOL.LCOM and /dev/null differ diff --git a/obsolete/lispusers/BIGGER-FONT b/obsolete/lispusers/BIGGER-FONT deleted file mode 100644 index c403cbce..00000000 --- a/obsolete/lispusers/BIGGER-FONT +++ /dev/null @@ -1,33 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "26-Jan-89 11:18:56" {QV}LISP>BIGGER-FONT.;5 2459 - - changes to%: (VARS BIGGER-FONTCOMS) - - previous date%: "25-Jan-89 12:04:51" {QV}LISP>BIGGER-FONT.;4) - - -(* " -Copyright (c) 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT BIGGER-FONTCOMS) - -(RPAQQ BIGGER-FONTCOMS ((ALISTS (FONTDEFS BIGGER)) (DECLARE%: DONTEVAL@LOAD DOCOPY (APPENDVARS (FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (*WHO-LINE-NAME-FONT* BOLDFONT T) (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT DEFAULTFONT) (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) (LAFITE.FOLDER.MENU.FONT MENUFONT) (LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (FILEWATCHPROP (QUOTE FONT) TINYFONT))))) (P (IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T)))))) - -(ADDTOVAR FONTDEFS (BIGGER (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 12) (GACHA 8) (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))))) -(DECLARE%: DONTEVAL@LOAD DOCOPY - -(APPENDTOVAR FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (*WHO-LINE-NAME-FONT* BOLDFONT T) - (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT DEFAULTFONT) - (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) - (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) - (LAFITE.FOLDER.MENU.FONT MENUFONT) (LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (FILEWATCHPROP (QUOTE FONT) TINYFONT))) -) - - -(IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T)) -) -(PUTPROPS BIGGER-FONT COPYRIGHT ("Xerox Corporation" 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/lispusers/BIGGER-FONT.LCOM b/obsolete/lispusers/BIGGER-FONT.LCOM deleted file mode 100644 index ca58d19d..00000000 --- a/obsolete/lispusers/BIGGER-FONT.LCOM +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "31-Aug-94 14:46:03" ("compiled on " {DSK}lispusers>BIGGER-FONT.;1) "28-Jul-94 17:28:46" bcompl'd in "Medley 28-Jul-94 ..." dated "28-Jul-94 17:35:29") (FILECREATED "26-Jan-89 11:18:56" {QV}LISP>BIGGER-FONT.;5 2459 changes to%: (VARS BIGGER-FONTCOMS) previous date%: "25-Jan-89 12:04:51" {QV}LISP>BIGGER-FONT.;4) (PRETTYCOMPRINT BIGGER-FONTCOMS) (RPAQQ BIGGER-FONTCOMS ((ALISTS (FONTDEFS BIGGER)) (DECLARE%: DONTEVAL@LOAD DOCOPY (APPENDVARS ( FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) (*WHO-LINE-NAME-FONT* BOLDFONT T) (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) (FB.BROWSERFONT DEFAULTFONT) ( FB.PROMPTFONT DEFAULTFONT) (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) (LAFITE.FOLDER.MENU.FONT MENUFONT) ( LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ (FILEWATCHPROP (QUOTE FONT) TINYFONT)) ))) (P (IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T)))))) (ADDTOVAR FONTDEFS (BIGGER (FONTPROFILE (DEFAULTFONT 1 (TERMINAL 12) (GACHA 8) (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))))) (APPENDTOVAR FONTVARS (ARBUTTONFONT BIGFONT) (ARBOLDFONT BOLDFONT) (ARFONT TEXTFONT) ( *WHO-LINE-NAME-FONT* BOLDFONT T) (*WHO-LINE-VALUE-FONT* DEFAULTFONT T) (FB.ICONFONT LITTLEFONT) ( FB.BROWSERFONT DEFAULTFONT) (FB.PROMPTFONT DEFAULTFONT) (FB.MENUFONT MENUFONT) (LAFITEEDITORFONT TEXTFONT) (LAFITEENDOFMESSAGEFONT COMMENTFONT) (LAFITEMSGICONFONT LITTLEFONT) (LAFITEBROWSERFONT DEFAULTFONT) (LAFITEFIXEDWIDTHFONT NIL) (LAFITETITLEFONT BIGFONT) (LAFITEMENUFONT MENUFONT) ( LAFITE.FOLDER.MENU.FONT MENUFONT) (LAFITEDISPLAYFONT TEXTFONT T) ((NLSETQ (SEDIT:RESET))) ((NLSETQ ( FILEWATCHPROP (QUOTE FONT) TINYFONT)))) (IF (>= SCREENWIDTH 1400) THEN (FONTSET (QUOTE BIGGER) T)) (PUTPROPS BIGGER-FONT COPYRIGHT ("Xerox Corporation" 1989)) NIL \ No newline at end of file diff --git a/obsolete/lispusers/COLOR b/obsolete/lispusers/COLOR deleted file mode 100644 index 13695db2..00000000 --- a/obsolete/lispusers/COLOR +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) (FILECREATED "27-Jan-87 15:56:46" {ERIS}NEXT>COLOR.;2 65054 changes to%: (VARS COLORCOMS EditColorMapHeight EditColorMapWidth DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping NEWCOLORITEM DICOLOR.hueConstants DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange DICOLOR.saturationConstants DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid DICOLOR.lightnessConstants DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white) (FNS DISPLAYCOLORLEVELS DISPLAYHLSLEVELS HLSLEVEL HLSTORGB HLSVALUEFN HLSVALUEFROMLEVEL LEVELFROMHLSVALUE RAINBOWMAP RGBTOHLS OVERPAINT BITMAPFROMSTRING SHADEBITMAP EDITCOLORMAP GETCOLOR#FROMUSER GETCOLOR#FROMSCREEN DISPLAYCOLORLEVEL FILLINREGION AREAFILL CENTEREDLEFT OUTLINEAREA OUTLINEREGION ADJUSTCOLORMAP SHOWCOLORBLOCKS MAPOFACOLOR CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL CSLTOHLS RGBTOCNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN DICOLOR.saturationNvalue DICOLOR.saturationNname) (RECORDS hueRecord lightnessRecord saturationRecord) previous date%: "16-Jan-87 18:20:53" {ERIS}NEXT>COLOR.;1) (* " Copyright (c) 1982, 1983, 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COLORCOMS) (RPAQQ COLORCOMS [(FNS DISPLAYCOLORLEVELS DISPLAYHLSLEVELS HLSLEVEL HLSTORGB HLSVALUEFN HLSVALUEFROMLEVEL LEVELFROMHLSVALUE RAINBOWMAP RGBTOHLS) (FNS OVERPAINT BITMAPFROMSTRING SHADEBITMAP) (INITVARS (EDITCOLORMAP.WINDOW NIL)) (FNS EDITCOLORMAP EDITCOLORMAP.BUTTONEVENTFN EDITCOLORMAP.REDISPLAYFN EDITCOLORMAP.VALUELEVEL EDITCOLORMAP.WINDOWLEVEL CHANGECOLORLEVELS GETCOLOR#FROMUSER GETCOLOR#FROMSCREEN DISPLAYCOLORLEVEL FILLINREGION AREAFILL CENTEREDLEFT OUTLINEAREA OUTLINEREGION) (FNS ADJUSTCOLORMAP SHOWCOLORBLOCKS MAPOFACOLOR COLORHEXPATTERN) (VARS EditColorMapHeight EditColorMapWidth (COLOR#MENUSAVE) (CONTROLMENUSAVE) (EDIT8BITCOLORMAPMENU) (EDIT8BITCOLORMAPNUMBERREADER)) (GLOBALVARS COLOR#MENUSAVE CONTROLMENUSAVE EDIT8BITCOLORMAPMENU EDIT8BITCOLORMAPNUMBERREADER EditColorMapHeight EditColorMapWidth) (COMS (* ;;; "support for global naming and querying of colors.") (FNS CNSMENUINIT CNSTOCSL CNSTORGB CSLTOCNS DICOLOR.FROM.USER GETCNS HLSTOCSL CSLTOHLS RGBTOCNS) (VARS DICOLOR.hueMapping DICOLOR.lightnessMapping DICOLOR.saturationMapping NEWCOLORITEM) (INITVARS (COLORNAMEMENU)) (FNS DICOLOR.hueN DICOLOR.hueNvalue DICOLOR.hueNname DICOLOR.lightnessN DICOLOR.lightnessNvalue DICOLOR.lightnessNname DICOLOR.saturationN DICOLOR.saturationNvalue DICOLOR.saturationNname) (DECLARE%: EVAL@LOAD DONTCOPY (*) (RECORDS hueRecord lightnessRecord saturationRecord) (CONSTANTS * DICOLOR.hueConstants) (CONSTANTS * DICOLOR.saturationConstants) (CONSTANTS * DICOLOR.lightnessConstants)) (P (CNSMENUINIT))) (FILES LLCOLOR READNUMBER) (P (SETQ EDITBMMENU NIL) (MOVD 'ARRAYP 'COLORMAPP]) (DEFINEQ (DISPLAYCOLORLEVELS [LAMBDA (WINDOW RGB) (* kbr%: " 3-Jun-86 19:45") (PROG (HLS) (DISPLAYCOLORLEVEL WINDOW 'RED (fetch (RGB RED) of RGB) (fetch (RGB RED) of RGB)) (DISPLAYCOLORLEVEL WINDOW 'GREEN (fetch (RGB GREEN) of RGB) (fetch (RGB GREEN) of RGB)) (DISPLAYCOLORLEVEL WINDOW 'BLUE (fetch (RGB BLUE) of RGB) (fetch (RGB BLUE) of RGB)) (SETQ HLS (RGBTOHLS RGB)) (DISPLAYCOLORLEVEL WINDOW 'HUE (fetch (HLS HUE) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'HUE (fetch (HLS HUE) of HLS))) (DISPLAYCOLORLEVEL WINDOW 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS))) (DISPLAYCOLORLEVEL WINDOW 'SATURATION (fetch (HLS SATURATION) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'SATURATION (fetch (HLS SATURATION) of HLS]) (DISPLAYHLSLEVELS [LAMBDA (HLS WIN) (* rrb "25-OCT-82 14:08") (* displays a hue lightness saturation triple in the edit window.) (DISPLAYHLSLEVEL HLS 'HUE NIL WIN) (DISPLAYHLSLEVEL HLS 'LIGHTNESS NIL WIN) (DISPLAYHLSLEVEL HLS 'SATURATION NIL WIN]) (HLSLEVEL [LAMBDA (HLS FIELD NEWLEVEL) (* rrb "25-OCT-82 13:29") (* returns the value of the named field from a hue lightness saturation record.) (SELECTQ FIELD (HUE (PROG1 (fetch (HLS HUE) of HLS) (AND NEWLEVEL (replace (HLS HUE) of HLS with NEWLEVEL)))) (LIGHTNESS (PROG1 (fetch (HLS LIGHTNESS) of HLS) (AND NEWLEVEL (replace (HLS LIGHTNESS) of HLS with NEWLEVEL)))) (SATURATION (PROG1 (fetch (HLS SATURATION) of HLS) (AND NEWLEVEL (replace (HLS SATURATION) of HLS with NEWLEVEL)))) (SHOULDNT]) (HLSTORGB [LAMBDA (HLS LIGHTNESS SATURATION) (* kbr%: " 3-Jun-86 21:16") (* 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 (HUE M1 M2 RGB) (COND ((LISTP HLS) (SETQ HUE (fetch (HLS HUE) of HLS)) (SETQ LIGHTNESS (fetch (HLS LIGHTNESS) of HLS)) (SETQ SATURATION (fetch (HLS SATURATION) of HLS))) (T (SETQ HUE HLS))) [SETQ M1 (COND ((FGREATERP 0.5 LIGHTNESS) (FTIMES LIGHTNESS (FPLUS 1.0 SATURATION))) (T (FDIFFERENCE (FPLUS LIGHTNESS SATURATION) (FTIMES LIGHTNESS SATURATION] (SETQ M2 (FDIFFERENCE (FTIMES 2.0 LIGHTNESS) M1)) [SETQ RGB (create RGB RED _ (HLSVALUEFN M1 M2 HUE) GREEN _ (HLSVALUEFN M1 M2 (IDIFFERENCE HUE 120)) BLUE _ (HLSVALUEFN M1 M2 (IDIFFERENCE HUE 240] (RETURN RGB]) (HLSVALUEFN [LAMBDA (M1 M2 HUE) (* kbr%: " 3-Jun-86 20:45") (* Internal value function for converting from HLS to RGB.  *) (SETQ HUE (IMOD HUE 360)) (FIX (FTIMES (COND ((ILESSP HUE 60) M1) [(ILESSP HUE 120) (FPLUS M1 (FTIMES (FQUOTIENT (FDIFFERENCE HUE 60) 60) (FDIFFERENCE M2 M1] ((ILESSP HUE 240) M2) [(ILESSP HUE 300) (FPLUS M2 (FTIMES (FQUOTIENT (FDIFFERENCE HUE 240) 60) (FDIFFERENCE M1 M2] (T M1)) 255]) (HLSVALUEFROMLEVEL [LAMBDA (HLS LEVEL) (* rrb "25-OCT-82 13:26") (* returns the scaled value of the hls marker on a scale from 0 to 255) (SELECTQ HLS (HUE (IQUOTIENT (ITIMES LEVEL 360) 255)) (FQUOTIENT LEVEL 255]) (LEVELFROMHLSVALUE [LAMBDA (HLS LEVEL) (* rrb "25-OCT-82 14:06") (* returns the level on a scale from 0 to 255 that this value would have.) (SELECTQ HLS (HUE (IQUOTIENT (ITIMES LEVEL 255) 360)) (FIX (FTIMES LEVEL 255]) (RAINBOWMAP [LAMBDA (NBITS) (* rrb "21-OCT-82 18:14") [OR NBITS (NULL (COLORDISPLAYP)) (SETQ NBITS (COLORMAPBITS (SCREENCOLORMAP] (COLORMAPCREATE (COND [(EQ NBITS 8) (PROG (MAXINTENSITY MINVISIBLERED MINVISIBLEBLUE MINVISIBLEGREEN NSTEPS REDSTEPSIZE GREENSTEPSIZE BLUESTEPSIZE) (SETQ MAXINTENSITY 255) (SETQ MINVISIBLERED 69) (SETQ MINVISIBLEBLUE 38) (SETQ MINVISIBLEGREEN 38) (SETQ NSTEPS (IQUOTIENT (EXPT 2 NBITS) 8)) (* determine how many steps are available for each transition from one color to  the next. There are 8 such transitions. red up, green up, red down, blue up,  green down, red up, green up, all down) (* minimum visible intensity values were emperically determined but will differ  depending upon the brightness setting of the individual display.  They are also diddled to make the numer of steps come out right.) (RETURN (NCONC (for I from MINVISIBLERED to MAXINTENSITY by (SETQ REDSTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE MAXINTENSITY MINVISIBLERED ) NSTEPS -2) NSTEPS)) collect (* red up) (LIST I 0 0)) (for I from MINVISIBLEGREEN to MAXINTENSITY by (SETQ GREENSTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE MAXINTENSITY MINVISIBLEGREEN ) -1 NSTEPS) NSTEPS)) collect (* GREEN UP) (LIST 255 I 0)) (for I from REDSTEPSIZE to (IDIFFERENCE MAXINTENSITY MINVISIBLERED) by REDSTEPSIZE collect (* red down) (LIST (IDIFFERENCE MAXINTENSITY I) 255 0)) (CONS '(0 255 0)) (for I from MINVISIBLEBLUE to MAXINTENSITY by (SETQ BLUESTEPSIZE (IQUOTIENT (IPLUS (IDIFFERENCE MAXINTENSITY MINVISIBLEBLUE ) -1 NSTEPS) NSTEPS)) collect (* BLUE UP) (LIST 0 255 I)) (for I from GREENSTEPSIZE to (IDIFFERENCE MAXINTENSITY MINVISIBLEGREEN) by GREENSTEPSIZE collect (* GREEN down) (LIST 0 (IDIFFERENCE MAXINTENSITY I) 255)) (CONS '(0 0 255)) (for I from MINVISIBLERED to MAXINTENSITY by REDSTEPSIZE collect (* red up) (LIST I 0 255)) (for I from MINVISIBLEGREEN to MAXINTENSITY by GREENSTEPSIZE collect (* GREEN UP) (LIST 255 I 255)) (for I from GREENSTEPSIZE to (IDIFFERENCE MAXINTENSITY MINVISIBLEGREEN) by GREENSTEPSIZE collect (* all down) (LIST (IDIFFERENCE MAXINTENSITY I) (IDIFFERENCE MAXINTENSITY I) (IDIFFERENCE MAXINTENSITY I))) (CONS '(0 0 0] (T RAINBOWINTENSITIES)) NBITS]) (RGBTOHLS [LAMBDA (RGB GREEN BLUE) (* kbr%: " 3-Jun-86 20:13") (* Converts from a red green blue triple of color information into a hue  lightness saturation triple. *) (* This algorithm was taken from Procedural Elements for Computer Graphics 1985  page 405 by David F. Rogers *) (PROG (RED CR CG CB M1 M2 LIGHTNESS HLS) (COND ((LISTP RGB) (SETQ RED (fetch (RGB RED) of RGB)) (SETQ GREEN (fetch (RGB GREEN) of RGB)) (SETQ BLUE (fetch (RGB BLUE) of RGB))) (T (SETQ RED RGB))) (SETQ M1 (MAX RED GREEN BLUE)) (SETQ M2 (MIN RED GREEN BLUE)) (SETQ LIGHTNESS (FQUOTIENT (FPLUS (FQUOTIENT M1 255) (FQUOTIENT M2 255)) 2)) [SETQ HLS (COND ((EQ M1 M2) (create HLS HUE _ 0 LIGHTNESS _ LIGHTNESS SATURATION _ 0.0)) (T (SETQ CR (FQUOTIENT (IDIFFERENCE M1 RED) (IDIFFERENCE M1 M2))) (SETQ CG (FQUOTIENT (IDIFFERENCE M1 GREEN) (IDIFFERENCE M1 M2))) (SETQ CB (FQUOTIENT (IDIFFERENCE M1 BLUE) (IDIFFERENCE M1 M2))) (create HLS HUE _ (IMOD (FIX (FTIMES [COND ((EQ M1 RED) (FDIFFERENCE CB CG)) ((EQ M1 GREEN) (FPLUS 2.0 (FDIFFERENCE CR CB))) (T (FPLUS 4.0 (FDIFFERENCE CG CR] 60.0)) 360) LIGHTNESS _ LIGHTNESS SATURATION _ (COND ((FGREATERP 0.5 LIGHTNESS) (FQUOTIENT (IDIFFERENCE M1 M2) (IPLUS M1 M2))) (T (FQUOTIENT (IDIFFERENCE M1 M2) (IDIFFERENCE (ITIMES 2 255) (IPLUS M1 M2] (RETURN HLS]) ) (DEFINEQ (OVERPAINT [LAMBDA (BM1 BM2 X Y TXT SCR) (* kbr%: " 2-Sep-85 20:30") (* Uses BM1 as a mask thru which it paints the INVERSE of texture onto BM2 at  position X Y) (PROG (BMW BMH) (SETQ BMW (BITMAPWIDTH BM1)) (SETQ BMH (BITMAPHEIGHT BM1)) (OR SCR (SETQ SCR (BITMAPCOPY BM1))) (* We need a scratch BM.  Most demos cache one) (BITBLT BM1 0 0 SCR 0 0 BMW BMH 'INPUT 'REPLACE) (BITBLT NIL NIL NIL SCR 0 0 BMW BMH 'TEXTURE 'ERASE TXT) (BITBLT BM1 0 0 BM2 X Y BMW BMH 'INPUT 'ERASE) (BITBLT SCR 0 0 BM2 X Y BMW BMH 'INPUT 'PAINT]) (BITMAPFROMSTRING [LAMBDA (STRING FONT BITSPERPIXEL) (* kbr%: "11-Aug-85 16:14") (PROG (BITMAP DS) (SETQ BITMAP (BITMAPCREATE (STRINGWIDTH STRING FONT) (FONTPROP FONT 'HEIGHT) BITSPERPIXEL)) (SETQ DS (DSPCREATE BITMAP)) (DSPFONT FONT DS) (MOVETO 0 (FONTPROP FONT 'DESCENT) DS) (PRIN3 STRING DS) (RETURN BITMAP]) (SHADEBITMAP [LAMBDA (BM T0 T1) (* bas%: "25-APR-82 15:02") (* Shades bitmap BM with T0 into 0 areas and T1 into 1 areas) (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'INVERT (LOGAND T0 (LOGXOR T0 T1))) (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'PAINT (LOGAND T0 T1)) (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'ERASE (LOGXOR (LOGOR T0 T1) 65535]) ) (RPAQ? EDITCOLORMAP.WINDOW NIL) (DEFINEQ (EDITCOLORMAP [LAMBDA NIL (* kbr%: " 5-Jun-86 22:49") (* Colormap Editor. Let's user  interactively adjust colormap.  *) (PROG (XPOS REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM) (COND ((NULL EDITCOLORMAP.WINDOW) (SETQ EDITCOLORMAP.WINDOW (CREATEW (GETBOXREGION EditColorMapWidth EditColorMapHeight NIL NIL NIL "Select location of Colormap Editor window.") "Colormap Editor")) (CLRPROMPT) (WINDOWPROP EDITCOLORMAP.WINDOW 'BUTTONEVENTFN 'EDITCOLORMAP.BUTTONEVENTFN) (WINDOWPROP EDITCOLORMAP.WINDOW 'REPAINTFN 'EDITCOLORMAP.REDISPLAYFN) (WINDOWPROP EDITCOLORMAP.WINDOW 'COLOR 0)) (T (CLEARW EDITCOLORMAP.WINDOW))) (REDISPLAYW EDITCOLORMAP.WINDOW]) (EDITCOLORMAP.BUTTONEVENTFN [LAMBDA (WINDOW) (* kbr%: " 4-Jun-86 21:21") (* Colormap editor. Displays a colormap in a window and allows the user to  change it. *) (PROG (REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM COLOR COLORMAP LEVEL LASTX LASTY HLS OLDLEVEL COMPONENT) (PROGN (SETQ REDREGION (WINDOWPROP WINDOW 'REDREGION)) (SETQ GREENREGION (WINDOWPROP WINDOW 'GREENREGION)) (SETQ BLUEREGION (WINDOWPROP WINDOW 'BLUEREGION)) (SETQ HUEREGION (WINDOWPROP WINDOW 'HUEREGION)) (SETQ LIGHTNESSREGION (WINDOWPROP WINDOW 'LIGHTNESSREGION)) (SETQ SATURATIONREGION (WINDOWPROP WINDOW 'SATURATIONREGION)) (SETQ BOTTOM (fetch (REGION BOTTOM) of REDREGION))) (SETQ COLOR (WINDOWPROP WINDOW 'COLOR)) (SETQ COLORMAP (SCREENCOLORMAP)) (COND [(LASTMOUSESTATE MIDDLE) (COND ((NUMBERP (SETQ LEVEL (GETCOLOR#FROMUSER))) (WINDOWPROP WINDOW 'COLOR LEVEL) (REDISPLAYW WINDOW] ((LASTMOUSESTATE LEFT) (SETQ LASTX (LASTMOUSEX WINDOW)) (SETQ LASTY (LASTMOUSEY WINDOW)) (COND ([SETQ COMPONENT (COND ((INSIDEP REDREGION LASTX LASTY) 'RED) ((INSIDEP GREENREGION LASTX LASTY) 'GREEN) ((INSIDEP BLUEREGION LASTX LASTY) 'BLUE) ((INSIDEP HUEREGION LASTX LASTY) 'HUE) ((INSIDEP LIGHTNESSREGION LASTX LASTY) 'LIGHTNESS) ((INSIDEP SATURATIONREGION LASTX LASTY) 'SATURATION] (SETQ OLDLEVEL (WINDOWPROP WINDOW COMPONENT)) (until (MOUSESTATE (NOT LEFT)) do (* As long as LEFT is down, adjust the color.  *) [SETQ LEVEL (IMIN 255 (IMAX 0 (IDIFFERENCE (LASTMOUSEY WINDOW ) BOTTOM] (COND ((NOT (EQ LEVEL OLDLEVEL)) (CHANGECOLORLEVELS WINDOW COMPONENT LEVEL) [SCREENCOLORMAPENTRY COLOR (create RGB RED _ (WINDOWPROP WINDOW 'RED) GREEN _ (WINDOWPROP WINDOW 'GREEN) BLUE _ (WINDOWPROP WINDOW 'BLUE] (SETQ OLDLEVEL LEVEL]) (EDITCOLORMAP.REDISPLAYFN [LAMBDA (WINDOW) (* kbr%: " 4-Jun-86 20:46") (* Colormap Editor. Let's user  interactively adjust colormap.  *) (PROG (XPOS REDREGION GREENREGION BLUEREGION HUEREGION LIGHTNESSREGION SATURATIONREGION BOTTOM COLORMAP COLOR) (CLEARW WINDOW) (PROGN (MOVETO 35 4 WINDOW) (PRIN1 "RED" WINDOW) (SETQ REDREGION '(40 16 10 256)) (OUTLINEREGION REDREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'REDREGION REDREGION)) (PROGN (MOVETO 70 4 WINDOW) (PRIN1 "GREEN" WINDOW) (SETQ GREENREGION '(82 16 10 256)) (OUTLINEREGION GREENREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'GREENREGION GREENREGION)) (PROGN (MOVETO 119 4 WINDOW) (PRIN1 "BLUE" WINDOW) (SETQ BLUEREGION '(128 16 10 256)) (OUTLINEREGION BLUEREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'BLUEREGION BLUEREGION)) (PROGN (MOVETO 181 4 WINDOW) (PRIN1 "HUE" WINDOW) (SETQ HUEREGION '(186 16 10 256)) (OUTLINEREGION HUEREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'HUEREGION HUEREGION)) (PROGN (MOVETO 216 4 WINDOW) (PRIN1 "LIGHTNESS" WINDOW) (SETQ LIGHTNESSREGION '(242 16 10 256)) (OUTLINEREGION LIGHTNESSREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'LIGHTNESSREGION LIGHTNESSREGION)) (PROGN (MOVETO 300 4 WINDOW) (PRIN1 "SAT" WINDOW) (SETQ SATURATIONREGION '(305 16 10 256)) (OUTLINEREGION SATURATIONREGION 2 NIL WINDOW) (WINDOWPROP WINDOW 'SATURATIONREGION SATURATIONREGION)) (PROGN (SETQ COLORMAP (SCREENCOLORMAP)) (SETQ COLOR (WINDOWPROP WINDOW 'COLOR)) (MOVETO 8 250 WINDOW) (printout WINDOW |.I3| COLOR) (DISPLAYCOLORLEVELS WINDOW (ELT COLORMAP COLOR]) (EDITCOLORMAP.VALUELEVEL [LAMBDA (COMPONENT WINDOWLEVEL) (* kbr%: " 3-Jun-86 19:55") (* * Value that would be stored in an RGB or HLS corresponding to WINDOWLEVEL.  *) (SELECTQ COMPONENT (HUE (IQUOTIENT (ITIMES WINDOWLEVEL 360) 255)) ((LIGHTNESS SATURATION) (FQUOTIENT WINDOWLEVEL 255)) ((RED GREEN BLUE) WINDOWLEVEL) (SHOULDNT]) (EDITCOLORMAP.WINDOWLEVEL [LAMBDA (COMPONENT VALUELEVEL) (* kbr%: " 3-Jun-86 19:55") (* * Given VALUELEVEL of an RGB or HLS, what WINDOWLEVEL should be used to  display it? *) (SELECTQ COMPONENT (HUE (IQUOTIENT (ITIMES VALUELEVEL 255) 360)) ((LIGHTNESS SATURATION) (FIX (FTIMES VALUELEVEL 255))) ((RED GREEN BLUE) VALUELEVEL) (SHOULDNT]) (CHANGECOLORLEVELS [LAMBDA (WINDOW COMPONENT WINDOWLEVEL) (* kbr%: " 3-Jun-86 19:55") (PROG (RGB HLS) (DISPLAYCOLORLEVEL WINDOW COMPONENT (EDITCOLORMAP.VALUELEVEL COMPONENT WINDOWLEVEL) WINDOWLEVEL) (SELECTQ COMPONENT ((RED GREEN BLUE) [SETQ HLS (RGBTOHLS (WINDOWPROP WINDOW 'RED) (WINDOWPROP WINDOW 'GREEN) (WINDOWPROP WINDOW 'BLUE] (DISPLAYCOLORLEVEL WINDOW 'HUE (fetch (HLS HUE) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'HUE (fetch (HLS HUE) of HLS))) (DISPLAYCOLORLEVEL WINDOW 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'LIGHTNESS (fetch (HLS LIGHTNESS) of HLS))) (DISPLAYCOLORLEVEL WINDOW 'SATURATION (fetch (HLS SATURATION) of HLS) (EDITCOLORMAP.WINDOWLEVEL 'SATURATION (fetch (HLS SATURATION) of HLS)))) ((HUE LIGHTNESS SATURATION) [SETQ RGB (HLSTORGB (EDITCOLORMAP.VALUELEVEL 'HUE (WINDOWPROP WINDOW 'HUE)) (EDITCOLORMAP.VALUELEVEL 'LIGHTNESS (WINDOWPROP WINDOW 'LIGHTNESS)) (EDITCOLORMAP.VALUELEVEL 'SATURATION (WINDOWPROP WINDOW 'SATURATION] (DISPLAYCOLORLEVEL WINDOW 'RED (fetch (RGB RED) of RGB) (fetch (RGB RED) of RGB)) (DISPLAYCOLORLEVEL WINDOW 'GREEN (fetch (RGB GREEN) of RGB) (fetch (RGB GREEN) of RGB)) (DISPLAYCOLORLEVEL WINDOW 'BLUE (fetch (RGB BLUE) of RGB) (fetch (RGB BLUE) of RGB))) (SHOULDNT]) (GETCOLOR#FROMUSER [LAMBDA NIL (* edited%: " 8-SEP-82 21:44") (* reads a color number from the user.) (PROG (RESPONSE) (MOVEW [COND ((TYPENAMEP EDIT8BITCOLORMAPNUMBERREADER 'WINDOW) EDIT8BITCOLORMAPNUMBERREADER) (T (SETQ EDIT8BITCOLORMAPNUMBERREADER (CREATE.NUMBERPAD.READER '(Enter color number to edit%:) (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY] (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY)) LP (COND ([NULL (ERSETQ (SETQ RESPONSE (NUMBERPAD.READ EDIT8BITCOLORMAPNUMBERREADER] (* currently there is no way NIL can be returned from NUMBERPAD.READ but there  should be a way to quit.) (RETURN NIL)) ((OR (ILESSP RESPONSE 0) (IGREATERP RESPONSE 255)) (PROMPTPRINT "Color numbers must be between 0 and 255.") (GO LP)) (T (RETURN RESPONSE]) (GETCOLOR#FROMSCREEN [LAMBDA NIL (* rrb " 3-NOV-82 13:57") (* returns the color number of a point selected by the user.) (RESETFORM (CHANGECURSORSCREEN (COLORSCREENBITMAP)) (PROG (POS) (SETQ POS (GETPOSITION)) (RETURN (AND POS (BITMAPBIT (COLORSCREENBITMAP) (fetch (POSITION XCOORD) of POS) (fetch (POSITION YCOORD) of POS]) (DISPLAYCOLORLEVEL [LAMBDA (WINDOW COMPONENT NEWLEVEL WINDOWLEVEL) (* kbr%: " 4-Jun-86 20:23") (PROG (REGION) (WINDOWPROP WINDOW COMPONENT WINDOWLEVEL) (SETQ REGION (SELECTQ COMPONENT (RED (WINDOWPROP WINDOW 'REDREGION)) (BLUE (WINDOWPROP WINDOW 'BLUEREGION)) (GREEN (WINDOWPROP WINDOW 'GREENREGION)) (HUE (WINDOWPROP WINDOW 'HUEREGION)) (LIGHTNESS (WINDOWPROP WINDOW 'LIGHTNESSREGION)) (SATURATION (WINDOWPROP WINDOW 'SATURATIONREGION)) (SHOULDNT))) [PROGN (* Print out new level of COMPONENT.  *) (MOVETO (IDIFFERENCE (fetch (REGION LEFT) of REGION) 12) (IPLUS 8 (fetch (REGION TOP) of REGION)) WINDOW) (* Overstrike extra digits in case the old value was larger.  *) (COND ((FIXP NEWLEVEL) (printout WINDOW " " |.I3| NEWLEVEL)) (T (printout WINDOW |.F5.3| NEWLEVEL] (FILLINREGION REGION WINDOWLEVEL GRAYSHADE WINDOW]) (FILLINREGION [LAMBDA (REGION HEIGHT GRAY WINDOW) (* rrb "23-FEB-82 12:26") (* fills part of a region with gray.) (DSPFILL REGION WHITESHADE 'REPLACE WINDOW) (AREAFILL (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) HEIGHT GRAY 'REPLACE WINDOW]) (AREAFILL [LAMBDA (LFT BTM WDTH HGTH SHADE OPERATION WINDOW) (* fills an area of a window with  shade.) (BITBLT NIL NIL NIL WINDOW LFT BTM WDTH HGTH 'TEXTURE OPERATION SHADE]) (CENTEREDLEFT [LAMBDA (WIDTH LEFT RIGHT) (* rrb "16-FEB-82 14:58") (* returns the left point that would leave WIDTH centered between LEFT and  RIGHT) (IQUOTIENT (IDIFFERENCE (IPLUS LEFT RIGHT) WIDTH) 2]) (OUTLINEAREA [LAMBDA (LFT BTM WDTH HGHT LINEWIDTH OPERATION WIN) (* rrb "17-FEB-82 10:59") (* outlines an area of a window.) (PROG (LEFTPLUSWIDTH RIGHTLINELEFT VERTLINETOP TOPY LINEWIDTH) (SETQ LINEWIDTH (OR (NUMBERP LINEWIDTH) 1)) (SETQ LFT (IDIFFERENCE LFT LINEWIDTH)) (SETQ BTM (IDIFFERENCE BTM LINEWIDTH)) (SETQ WDTH (IPLUS WDTH (ITIMES LINEWIDTH 2))) (SETQ HGHT (IPLUS HGHT (ITIMES LINEWIDTH 2))) (DRAWLINE LFT BTM LFT (SETQ VERTLINETOP (SUB1 (IPLUS BTM HGHT))) LINEWIDTH OPERATION WIN) (DRAWLINE (SETQ RIGHTLINELEFT (IDIFFERENCE (IPLUS LFT WDTH) LINEWIDTH)) BTM RIGHTLINELEFT VERTLINETOP LINEWIDTH OPERATION WIN) (DRAWLINE (SETQ LEFTPLUSWIDTH (IPLUS LFT LINEWIDTH)) BTM (SETQ RIGHTLINELEFT (SUB1 RIGHTLINELEFT)) BTM LINEWIDTH OPERATION WIN) (DRAWLINE LEFTPLUSWIDTH (SETQ TOPY (ADD1 (IDIFFERENCE VERTLINETOP LINEWIDTH))) RIGHTLINELEFT TOPY LINEWIDTH OPERATION WIN]) (OUTLINEREGION [LAMBDA (REGION OUTLINEWIDTH OPERATION WIN) (* rrb "17-FEB-82 10:58") (* outlines the region REGION with a  width wide line) (OUTLINEAREA (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) OUTLINEWIDTH OPERATION WIN]) ) (DEFINEQ (ADJUSTCOLORMAP [LAMBDA (PRIMARY DELTA) (* kbr%: " 5-Jun-86 19:41") (* Adds DELTA points of intensity to all values of PRIMARY color in  SCREENCOLORMAP *) (PROG NIL (for COLOR from 0 to (MAXIMUMCOLOR (BITSPERPIXEL (SCREENCOLORMAP))) do (COLORLEVEL COLOR PRIMARY (IMIN 255 (IMAX 0 (IPLUS (COLORLEVEL COLOR PRIMARY) DELTA]) (SHOWCOLORBLOCKS [LAMBDA (DESTINATION) (* kbr%: "17-Aug-85 21:44") (* Puts shade blocks onto DESTINATION.  *) (PROG (BITSPERPIXEL MAXSHADE N WIDTH HEIGHT SHADE) (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) (SETQ MAXSHADE (MAXIMUMSHADE BITSPERPIXEL)) [SETQ N (FIXR (SQRT (ADD1 MAXSHADE] (SETQ WIDTH (IQUOTIENT (IPLUS (BITMAPWIDTH DESTINATION) N -1) N)) (SETQ HEIGHT (IQUOTIENT (IPLUS (BITMAPHEIGHT DESTINATION) N -1) N)) (SETQ SHADE 0) (for Y from (SUB1 N) to 0 by -1 do (for X from 0 to (SUB1 N) do (BLTSHADE SHADE DESTINATION (ITIMES X WIDTH) (ITIMES Y HEIGHT) WIDTH HEIGHT 'REPLACE) (SETQ SHADE (ADD1 SHADE)) (COND ((IGREATERP SHADE MAXSHADE) (SETQ SHADE 0]) (MAPOFACOLOR [LAMBDA (RGB BITSPERPIXEL) (* kbr%: "11-Jul-85 20:04") (* creates a gray color map *) (PROG (MAXCOLOR RED GREEN BLUE OPRED OPGREEN OPBLUE COLORMAP) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ RED (fetch (RGB RED) of RGB)) (SETQ GREEN (fetch (RGB GREEN) of RGB)) (SETQ BLUE (fetch (RGB BLUE) of RGB)) (SETQ OPRED (IDIFFERENCE MAXCOLOR RED)) (SETQ OPGREEN (IDIFFERENCE MAXCOLOR GREEN)) (SETQ OPBLUE (IDIFFERENCE MAXCOLOR BLUE)) (SETQ COLORMAP (COLORMAPCREATE (for I from 0 to MAXCOLOR as OPI from MAXCOLOR to 0 by -1 collect (create RGB RED _ (IQUOTIENT (IPLUS (ITIMES OPI OPRED) (ITIMES I RED)) MAXCOLOR) GREEN _ (IQUOTIENT (IPLUS (ITIMES OPI OPGREEN) (ITIMES I GREEN)) MAXCOLOR) BLUE _ (IQUOTIENT (IPLUS (ITIMES OPI OPBLUE) (ITIMES I BLUE)) MAXCOLOR))) BITSPERPIXEL)) (RETURN COLORMAP]) (COLORHEXPATTERN [LAMBDA (LIGHTNESS) (* kbr%: " 3-Jun-86 22:36") (* Put a color hex pattern on the color display.  *) (PROG (DESTINATION WIDTH HEIGHT BITSPERPIXEL N HEXWIDTH HEXHEIGHT LEFT BOTTOM COLOR MAXI JDIST IDIST) (COND ((NULL LIGHTNESS) (SETQ LIGHTNESS 0.5))) (SETQ DESTINATION (COLORSCREENBITMAP)) (SETQ WIDTH (BITMAPWIDTH DESTINATION)) (SETQ HEIGHT (BITMAPHEIGHT DESTINATION)) (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) (SETQ N (SELECTQ BITSPERPIXEL (4 1) (8 8) (RETURN))) (SETQ HEXWIDTH (IQUOTIENT WIDTH (IPLUS (ITIMES 2 N) 1))) (SETQ HEXHEIGHT (IQUOTIENT HEIGHT (IPLUS (ITIMES 2 N) 1))) (BLTSHADE MINIMUMSHADE DESTINATION) (SETQ COLOR 0) [for J from N to 0 by -1 do (SETQ BOTTOM (ITIMES (IPLUS J N) HEXHEIGHT)) (SETQ MAXI (IDIFFERENCE (IPLUS (ITIMES 2 N) 1) J)) (for I from 0 to MAXI do (SETQ LEFT (IQUOTIENT (ITIMES (IPLUS (ITIMES 2 I) J) HEXWIDTH) 2)) (SETQ COLOR (ADD1 COLOR)) (BLTSHADE COLOR DESTINATION LEFT BOTTOM HEXWIDTH HEXHEIGHT) (SETQ JDIST (FQUOTIENT J N)) (SETQ IDIST (FDIFFERENCE (FTIMES 2.0 (FQUOTIENT I MAXI)) 1.0)) (SCREENCOLORMAPENTRY COLOR (HLSTORGB (ATAN JDIST IDIST) LIGHTNESS (SQRT (FQUOTIENT (FPLUS (FTIMES IDIST IDIST) (FTIMES JDIST JDIST)) 2.0] (for J from -1 to (IMINUS N) by -1 do (SETQ BOTTOM (ITIMES (IPLUS J N) HEXHEIGHT)) (SETQ MAXI (IPLUS (IPLUS (ITIMES 2 N) 1) J)) (for I from 0 to MAXI do (SETQ LEFT (IQUOTIENT (ITIMES (IPLUS (ITIMES 2 I) (IMINUS J)) HEXWIDTH) 2)) (SETQ COLOR (ADD1 COLOR)) (BLTSHADE COLOR DESTINATION LEFT BOTTOM HEXWIDTH HEXHEIGHT) (SETQ JDIST (FQUOTIENT J N)) (SETQ IDIST (FDIFFERENCE (FTIMES 2.0 (FQUOTIENT I MAXI)) 1.0)) (SCREENCOLORMAPENTRY COLOR (HLSTORGB (ATAN JDIST IDIST) LIGHTNESS (SQRT (FQUOTIENT (FPLUS (FTIMES IDIST IDIST) (FTIMES JDIST JDIST)) 2.0]) ) (RPAQQ EditColorMapHeight 315) (RPAQQ EditColorMapWidth 380) (RPAQQ COLOR#MENUSAVE NIL) (RPAQQ CONTROLMENUSAVE NIL) (RPAQQ EDIT8BITCOLORMAPMENU NIL) (RPAQQ EDIT8BITCOLORMAPNUMBERREADER NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COLOR#MENUSAVE CONTROLMENUSAVE EDIT8BITCOLORMAPMENU EDIT8BITCOLORMAPNUMBERREADER EditColorMapHeight EditColorMapWidth) ) (* ;;; "support for global naming and querying of colors.") (DEFINEQ (CNSMENUINIT [LAMBDA NIL (* gbn " 9-Aug-85 03:11") [SETQ CNSHUEMENU (create MENU ITEMS _ (for I in DICOLOR.hueMapping collect (CAR I] [SETQ CNSSATURATIONMENU (create MENU ITEMS _ (for I in DICOLOR.saturationMapping collect (CAR I] (SETQ CNSLIGHTNESSMENU (create MENU ITEMS _ (for I in DICOLOR.lightnessMapping collect (CAR I]) (CNSTOCSL [LAMBDA (hue saturation lightness) (* hdj "12-Apr-85 19:01") (PROG ((hueAtom (MKATOM hue)) (saturationAtom (MKATOM saturation)) (lightnessAtom (MKATOM lightness)) c s l) (if [NOT (SETQ c (fetch (hueRecord ordering) of (ASSOC hueAtom DICOLOR.hueMapping] then (SETQ c DICOLOR.achromatic)) (if (EQ c DICOLOR.achromatic) then (SETQ s DICOLOR.noSaturation) else (if [NOT (SETQ s (fetch (saturationRecord ordering) of (ASSOC saturationAtom DICOLOR.saturationMapping ] then (SETQ s DICOLOR.vivid))) (SELECTQ hueAtom (Black (SETQ l DICOLOR.black)) (White (SETQ l DICOLOR.white)) (if [NOT (SETQ l (fetch (lightnessRecord ordering) of (ASSOC lightnessAtom DICOLOR.lightnessMapping] then (SETQ l DICOLOR.medium))) (RETURN (LIST c s l]) (CNSTORGB [LAMBDA (saturation lightness hue) (* hdj "15-Jul-85 12:33") (LET ((CSL (CNSTOCSL hue saturation lightness))) (HLSTORGB (APPLY (FUNCTION CSLTOHLS) CSL]) (CSLTOCNS [LAMBDA (c s l) (* hdj "15-Jul-85 12:37") (PROG (hue saturation lightness) [if (EQ c DICOLOR.achromatic) then (SETQ saturation "") [SELECTC l (DICOLOR.black (SETQ hue "Black") (SETQ lightness "")) (DICOLOR.white (SETQ hue "White") (SETQ lightness "")) (PROGN (SETQ hue "Gray") (SETQ lightness (MKSTRING (fetch (lightnessRecord name) of (DICOLOR.lightnessN l] else (SETQ hue (fetch (hueRecord name) of (DICOLOR.hueN c))) (SETQ saturation (fetch (saturationRecord name) of (DICOLOR.saturationN s))) (SETQ lightness (fetch (lightnessRecord name) of (DICOLOR.lightnessN l] (RETURN (LIST saturation lightness hue]) (DICOLOR.FROM.USER [LAMBDA NIL (* gbn "30-Oct-85 11:28") (* * Returns a color, either by its name  (which can then be looked up on colornames) or as an RGB triple if it is not  named. Prompts the user first with the global color name menu.  She can then choose NEWCOLOR which can be specified as RGB or CNS) (PROG (NAME RGB) (* first try to get a color name) [SETQ NAME (MENU (OR COLORNAMEMENU (SETQ COLORNAMEMENU (create MENU ITEMS _ (CONS NEWCOLORITEM (for ENTRY in COLORNAMES collect (CAR ENTRY] (if (NOT NAME) then (* the user clicked outside the menu) (RETURN)) (SETQ RGB (SELECTQ NAME (RGB (READCOLOR1 "specify new color")) (CNS (APPLY (FUNCTION CNSTORGB) (GETCNS))) (RETURN NAME))) (if (NOT (SETQ NAME (TTYIN "New color name? "))) then (* user decided that she didn't want to name the color) (RETURN RGB)) (push COLORNAMES (CONS (SETQ NAME (CAR NAME)) RGB)) (SETQ COLORNAMEMENU NIL) (* invalidate the menu) (RETURN NAME]) (GETCNS [LAMBDA NIL (* gbn " 9-Aug-85 03:13") (LIST (MENU CNSLIGHTNESSMENU) (MENU CNSSATURATIONMENU) (MENU CNSHUEMENU]) (HLSTOCSL [LAMBDA (hue lightness saturation) (* hdj "15-Jul-85 12:14") (LET ((ISLHue (FQUOTIENT (MOD (PLUS hue 240) 360) 360))) (PROG (c s l) (for old s from DICOLOR.noSaturation to DICOLOR.vivid do (if (EQ s DICOLOR.vivid) then (RETURN)) (if (LEQ saturation (PLUS (DICOLOR.saturationNvalue s) (QUOTIENT (DIFFERENCE (DICOLOR.saturationNvalue (ADD1 s)) (DICOLOR.saturationNvalue s)) 2))) then (RETURN))) [if (EQ s DICOLOR.noSaturation) then (SETQ c DICOLOR.achromatic) (for old l from DICOLOR.black to DICOLOR.white do (if (EQ l DICOLOR.white) then (RETURN)) (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l) (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue (ADD1 l)) (DICOLOR.lightnessNvalue l)) 2))) then (RETURN))) else (for old c from DICOLOR.red to DICOLOR.purplishRed do (* (HELP c)) (if (EQ c DICOLOR.purplishRed) then (if (GREATERP ISLHue (PLUS (DICOLOR.hueNvalue c) (QUOTIENT (DIFFERENCE 1 (  DICOLOR.hueNvalue c)) 2))) then (SETQ c DICOLOR.red)) (RETURN)) (if (LEQ ISLHue (PLUS (DICOLOR.hueNvalue c) (QUOTIENT (DIFFERENCE (DICOLOR.hueNvalue (ADD1 c)) (DICOLOR.hueNvalue c)) 2))) then (RETURN))) (for old l from DICOLOR.veryDark to DICOLOR.veryLight do (if (EQ l DICOLOR.veryLight) then (RETURN)) (if (LEQ lightness (PLUS (DICOLOR.lightnessNvalue l) (QUOTIENT (DIFFERENCE (DICOLOR.lightnessNvalue (ADD1 l)) (DICOLOR.lightnessNvalue l)) 2))) then (RETURN] (RETURN (LIST c s l]) (CSLTOHLS [LAMBDA (c s l) (* hdj "15-Jul-85 12:23") (PROG (hue saturation lightness) (if (EQ c DICOLOR.achromatic) then (SETQ hue 0.0) (SETQ saturation 0.0) (SETQ lightness (DICOLOR.lightnessNvalue l)) else (SETQ hue (DICOLOR.hueNvalue c)) (SETQ saturation (DICOLOR.saturationNvalue s)) (SETQ lightness (DICOLOR.lightnessNvalue l))) (RETURN (LIST (MOD (FPLUS 120 (FTIMES hue 360)) 360) lightness saturation]) (RGBTOCNS [LAMBDA (Red Green Blue) (* hdj "15-Jul-85 12:36") (APPLY (FUNCTION CSLTOCNS) (APPLY (FUNCTION HLSTOCSL) (RGBTOHLS Red Green Blue]) ) (RPAQQ DICOLOR.hueMapping ((Achromatic 0.0 -1) (Red 0.0 0) (OrangishRed 0.01 1) (RedOrange 0.02 2) (ReddishOrange 0.03 3) (Orange 0.04 4) (YellowishOrange 0.070 5) (OrangeYellow 0.1 6) (OrangishYellow 0.13 7) (Yellow 0.1673 8) (GreenishYellow 0.2073 9) (YellowGreen 0.2473 10) (YellowishGreen 0.2873 11) (Green 0.3333 12) (BluishGreen 0.4133 13) (GreenBlue 0.4933 14) (GreenishBlue 0.5733 15) (Blue 0.6666 16) (PurplishBlue 0.6816 17) (BluePurple 0.6966 18) (BluishPurple 0.7116 19) (Purple 0.73 20) (ReddishPurple 0.8 21) (PurpleRed 0.87 22) (PurplishRed 0.94 23) (BrownishRed 0.01 24) (RedBrown 0.02 25) (ReddishBrown 0.03 26) (Brown 0.04 27) (YellowishBrown 0.070 28) (BrownYellow 0.1 29) (BrownishYellow 0.13 30))) (RPAQQ DICOLOR.lightnessMapping ((Black 0.0 0) (VeryDark 0.1666 1) (Dark 0.3333 2) (Medium 0.5 3) (Light 0.6666 4) (VeryLight 0.8333 5) (White 1.0 6))) (RPAQQ DICOLOR.saturationMapping ((NoSaturation 0.0 0) (Grayish 0.25 1) (Moderate 0.5 2) (Strong 0.75 3) (Vivid 1.0 4))) (RPAQQ NEWCOLORITEM (New% Color 'CNS "Allows specification of a new color" (SUBITEMS (RGB 'RGB "Specify a new color using Red, Green, Blue sliders" ) (CNS 'CNS "Specify a new color using English" )))) (RPAQ? COLORNAMEMENU ) (DEFINEQ (DICOLOR.hueN [LAMBDA (N) (* hdj "17-Apr-85 13:38") (DECLARE (GLOBALVARS DICOLOR.hueMapping)) (for ELT in DICOLOR.hueMapping suchthat (EQ (fetch (hueRecord ordering) of ELT) N]) (DICOLOR.hueNvalue [LAMBDA (N) (* hdj "18-Apr-85 09:58") (fetch (hueRecord value) of (DICOLOR.hueN N]) (DICOLOR.hueNname [LAMBDA (N) (* hdj "18-Apr-85 10:07") (fetch (hueRecord name) of (DICOLOR.hueN N]) (DICOLOR.lightnessN [LAMBDA (N) (* hdj "17-Apr-85 13:40") (DECLARE (GLOBALVARS DICOLOR.lightnessMapping)) (for ELT in DICOLOR.lightnessMapping suchthat (EQ (fetch (lightnessRecord ordering) of ELT) N]) (DICOLOR.lightnessNvalue [LAMBDA (N) (* hdj "17-Apr-85 13:36") (fetch (lightnessRecord value) of (DICOLOR.lightnessN N]) (DICOLOR.lightnessNname [LAMBDA (N) (* hdj "17-Apr-85 14:02") (fetch (lightnessRecord name) of (DICOLOR.lightnessN N]) (DICOLOR.saturationN [LAMBDA (N) (* hdj "17-Apr-85 13:39") (DECLARE (GLOBALVARS DICOLOR.saturationMapping)) (for ELT in DICOLOR.saturationMapping suchthat (EQ (fetch (saturationRecord ordering) of ELT) N]) (DICOLOR.saturationNvalue [LAMBDA (N) (* hdj "17-Apr-85 13:36") (fetch (saturationRecord value) of (DICOLOR.saturationN N]) (DICOLOR.saturationNname [LAMBDA (N) (* hdj "17-Apr-85 14:02") (fetch (saturationRecord name) of (DICOLOR.saturationN N]) ) (DECLARE%: EVAL@LOAD DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD hueRecord (name value ordering)) (RECORD lightnessRecord (name value ordering)) (RECORD saturationRecord (name value ordering)) ) (RPAQQ DICOLOR.hueConstants (DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange)) (DECLARE%: EVAL@COMPILE (RPAQQ DICOLOR.achromatic -1) (RPAQQ DICOLOR.blue 16) (RPAQQ DICOLOR.bluePurple 18) (RPAQQ DICOLOR.bluishGreen 13) (RPAQQ DICOLOR.bluishPurple 19) (RPAQQ DICOLOR.brown 27) (RPAQQ DICOLOR.brownYellow 29) (RPAQQ DICOLOR.brownishRed 24) (RPAQQ DICOLOR.brownishYellow 30) (RPAQQ DICOLOR.green 12) (RPAQQ DICOLOR.greenBlue 14) (RPAQQ DICOLOR.greenishBlue 15) (RPAQQ DICOLOR.greenishYellow 9) (RPAQQ DICOLOR.orange 4) (RPAQQ DICOLOR.orangeYellow 6) (RPAQQ DICOLOR.orangishRed 1) (RPAQQ DICOLOR.orangishYellow 7) (RPAQQ DICOLOR.purple 20) (RPAQQ DICOLOR.purpleRed 22) (RPAQQ DICOLOR.purplishBlue 17) (RPAQQ DICOLOR.purplishRed 23) (RPAQQ DICOLOR.red 0) (RPAQQ DICOLOR.redBrown 25) (RPAQQ DICOLOR.redOrange 2) (RPAQQ DICOLOR.reddishBrown 26) (RPAQQ DICOLOR.reddishOrange 3) (RPAQQ DICOLOR.reddishPurple 21) (RPAQQ DICOLOR.yellow 8) (RPAQQ DICOLOR.yellowGreen 10) (RPAQQ DICOLOR.yellowishBrown 28) (RPAQQ DICOLOR.yellowishGreen 11) (RPAQQ DICOLOR.yellowishOrange 5) (CONSTANTS DICOLOR.achromatic DICOLOR.blue DICOLOR.bluePurple DICOLOR.bluishGreen DICOLOR.bluishPurple DICOLOR.brown DICOLOR.brownYellow DICOLOR.brownishRed DICOLOR.brownishYellow DICOLOR.green DICOLOR.greenBlue DICOLOR.greenishBlue DICOLOR.greenishYellow DICOLOR.orange DICOLOR.orangeYellow DICOLOR.orangishRed DICOLOR.orangishYellow DICOLOR.purple DICOLOR.purpleRed DICOLOR.purplishBlue DICOLOR.purplishRed DICOLOR.red DICOLOR.redBrown DICOLOR.redOrange DICOLOR.reddishBrown DICOLOR.reddishOrange DICOLOR.reddishPurple DICOLOR.yellow DICOLOR.yellowGreen DICOLOR.yellowishBrown DICOLOR.yellowishGreen DICOLOR.yellowishOrange) ) (RPAQQ DICOLOR.saturationConstants (DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid)) (DECLARE%: EVAL@COMPILE (RPAQQ DICOLOR.noSaturation 0) (RPAQQ DICOLOR.grayish 1) (RPAQQ DICOLOR.moderate 2) (RPAQQ DICOLOR.strong 3) (RPAQQ DICOLOR.vivid 4) (CONSTANTS DICOLOR.noSaturation DICOLOR.grayish DICOLOR.moderate DICOLOR.strong DICOLOR.vivid) ) (RPAQQ DICOLOR.lightnessConstants (DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white)) (DECLARE%: EVAL@COMPILE (RPAQQ DICOLOR.black 0) (RPAQQ DICOLOR.veryDark 1) (RPAQQ DICOLOR.dark 2) (RPAQQ DICOLOR.medium 3) (RPAQQ DICOLOR.light 4) (RPAQQ DICOLOR.veryLight 5) (RPAQQ DICOLOR.white 6) (CONSTANTS DICOLOR.black DICOLOR.veryDark DICOLOR.dark DICOLOR.medium DICOLOR.light DICOLOR.veryLight DICOLOR.white) ) ) (CNSMENUINIT) (FILESLOAD LLCOLOR READNUMBER) (SETQ EDITBMMENU NIL) (MOVD 'ARRAYP 'COLORMAPP) (PUTPROPS COLOR COPYRIGHT ("Xerox Corporation" 1982 1983 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5033 20085 (DISPLAYCOLORLEVELS 5043 . 6161) (DISPLAYHLSLEVELS 6163 . 6503) (HLSLEVEL 6505 . 7240) (HLSTORGB 7242 . 8671) (HLSVALUEFN 8673 . 9550) (HLSVALUEFROMLEVEL 9552 . 9884) ( LEVELFROMHLSVALUE 9886 . 10223) (RAINBOWMAP 10225 . 17234) (RGBTOHLS 17236 . 20083)) (20086 21872 ( OVERPAINT 20096 . 20857) (BITMAPFROMSTRING 20859 . 21349) (SHADEBITMAP 21351 . 21870)) (21910 38520 ( EDITCOLORMAP 21920 . 23139) (EDITCOLORMAP.BUTTONEVENTFN 23141 . 26871) (EDITCOLORMAP.REDISPLAYFN 26873 . 29232) (EDITCOLORMAP.VALUELEVEL 29234 . 29727) (EDITCOLORMAP.WINDOWLEVEL 29729 . 30232) ( CHANGECOLORLEVELS 30234 . 32361) (GETCOLOR#FROMUSER 32363 . 33681) (GETCOLOR#FROMSCREEN 33683 . 34241) (DISPLAYCOLORLEVEL 34243 . 35667) (FILLINREGION 35669 . 36136) (AREAFILL 36138 . 36400) (CENTEREDLEFT 36402 . 36728) (OUTLINEAREA 36730 . 37959) (OUTLINEREGION 37961 . 38518)) (38521 45894 ( ADJUSTCOLORMAP 38531 . 39051) (SHOWCOLORBLOCKS 39053 . 40520) (MAPOFACOLOR 40522 . 42173) ( COLORHEXPATTERN 42175 . 45892)) (46360 55962 (CNSMENUINIT 46370 . 47005) (CNSTOCSL 47007 . 48269) ( CNSTORGB 48271 . 48518) (CSLTOCNS 48520 . 49593) (DICOLOR.FROM.USER 49595 . 51354) (GETCNS 51356 . 51560) (HLSTOCSL 51562 . 55062) (CSLTOHLS 55064 . 55732) (RGBTOCNS 55734 . 55960)) (58806 61057 ( DICOLOR.hueN 58816 . 59134) (DICOLOR.hueNvalue 59136 . 59315) (DICOLOR.hueNname 59317 . 59494) ( DICOLOR.lightnessN 59496 . 59844) (DICOLOR.lightnessNvalue 59846 . 60043) (DICOLOR.lightnessNname 60045 . 60240) (DICOLOR.saturationN 60242 . 60653) (DICOLOR.saturationNvalue 60655 . 60855) ( DICOLOR.saturationNname 60857 . 61055))))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/COLOROBJ b/obsolete/lispusers/COLOROBJ deleted file mode 100644 index b4b09e9d..00000000 --- a/obsolete/lispusers/COLOROBJ +++ /dev/null @@ -1,166 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "14-Jun-90 21:02:08" {DSK}local>lde>lispcore>internal>library>COLOROBJ.;2 7921 - - changes to%: (FNS COLOROBJ.IMAGEBOXFN COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN - COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN) - (VARS COLOROBJCOMS) - - previous date%: " 4-Feb-87 23:58:42" {DSK}local>lde>lispcore>internal>library>COLOROBJ.;1 -) - - -(* ; " -Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT COLOROBJCOMS) - -(RPAQQ COLOROBJCOMS - [(FNS * COLOROBJFNS) - (FILES COLOR) - (INITVARS (COLOROBJ.DEFAULT.COLOR 'RED)) - (VARS (COLOROBJFNS '(COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN - COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN)) - (COLOROBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN) - (FUNCTION COLOROBJ.IMAGEBOXFN) - (FUNCTION COLOROBJ.PUTFN) - (FUNCTION COLOROBJ.GETFN) - (FUNCTION COLOROBJ.COPYFN) - (FUNCTION COLOROBJ.BUTTONEVENTFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION COLOROBJ.WHENOPERATEDONFN) - (FUNCTION NILL]) - -(RPAQQ COLOROBJFNS (COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN - COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN)) -(DEFINEQ - -(COLOROBJ.CREATE - [LAMBDA (COLOR) (* gbn "13-Jan-86 16:00") - - (* * create a color object. color is anything acceptable to dspcolor - (atoms on colornames, rgb triples, indices)) - - (LET ((COLOROBJ (IMAGEOBJCREATE NIL COLOROBJ.IMAGEFNS))) - (IMAGEOBJPROP COLOROBJ 'COLOR (OR COLOR COLOROBJ.DEFAULT.COLOR)) - COLOROBJ]) - -(COLOROBJ.DISPLAYFN - [LAMBDA (COLOROBJ IMAGE.STREAM) (* gbn "13-Jan-86 17:51") - - (* On the display a color object shows up as the color name, otherwise it has - no image. On any stream it has the sideeffect of changing the foreground color) - - (LET* ((COLOR (IMAGEOBJPROP COLOROBJ 'COLOR)) - (X (DSPXPOSITION NIL IMAGE.STREAM)) - (Y (DSPYPOSITION NIL IMAGE.STREAM))) - (DSPCOLOR COLOR IMAGE.STREAM) - (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) - (DISPLAY (DSPFONT '(WEIGHT BOLD) - IMAGE.STREAM) - (LET* ((STRING (IMAGEOBJPROP COLOROBJ 'COLOR)) - (STRINGREGION (STRINGREGION STRING IMAGE.STREAM)) - (LEFT (ADD1 (fetch (REGION LEFT) of STRINGREGION))) - (BOTTOM (fetch (REGION BOTTOM) of STRINGREGION)) - (REGION (create REGION - LEFT _ LEFT - BOTTOM _ BOTTOM - HEIGHT _ (IPLUS (fetch (REGION HEIGHT) of - STRINGREGION - ) - 2) - WIDTH _ (IPLUS (fetch (REGION WIDTH) of - STRINGREGION - ) - 6))) - (TOP (fetch (REGION TOP) of REGION)) - (RIGHT (fetch (REGION RIGHT) of REGION))) - (IMAGEOBJPROP COLOROBJ 'REGION REGION) - (CENTERPRINTINREGION STRING REGION IMAGE.STREAM) - (DRAWLINE LEFT BOTTOM LEFT (SUB1 TOP) - 1 - 'INVERT IMAGE.STREAM) - (DRAWLINE LEFT TOP (SUB1 RIGHT) - TOP 1 'INVERT IMAGE.STREAM) - (DRAWLINE RIGHT TOP RIGHT (ADD1 BOTTOM) - 1 - 'INVERT IMAGE.STREAM) - (DRAWLINE RIGHT BOTTOM (ADD1 LEFT) - BOTTOM 1 'INVERT IMAGE.STREAM))) - (NILL]) - -(COLOROBJ.GETFN - [LAMBDA (INPUT.STREAM TEXTSTREAM) (* gbn "13-Jan-86 15:42") - (* reads the COLOR and creates an - COLOROBJ) - (COLOROBJ.CREATE (READ INPUT.STREAM]) - -(COLOROBJ.IMAGEBOXFN - [LAMBDA (COLOROBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* gbn "13-Jan-86 16:01") - - (* * Returns a null imagebox, except to the display, where it returns the size - of the box) - - (LET NIL (SELECTQ (IMAGESTREAMTYPE IMAGE.STREAM) - (DISPLAY (create IMAGEBOX - XSIZE _ (IPLUS (STRINGWIDTH (IMAGEOBJPROP COLOROBJ 'COLOR) - (DSPFONT NIL IMAGE.STREAM)) - 8) - YSIZE _ (IPLUS (FONTHEIGHT (DSPFONT NIL IMAGE.STREAM)) - 4) - YDESC _ 4 - XKERN _ 0)) - (create IMAGEBOX - XSIZE _ 0 - YSIZE _ 0 - YDESC _ 0 - XKERN _ 0]) - -(COLOROBJ.PUTFN - [LAMBDA (COLOROBJ OUTPUT.STREAM) (* gbn "13-Jan-86 15:57") - (* prints only the color to the file) - (PRINT (IMAGEOBJPROP COLOROBJ 'COLOR) - OUTPUT.STREAM]) - -(COLOROBJ.COPYFN - [LAMBDA (IMAGEOBJ FROMSTREAM TOSTREAM) (* gbn "13-Jan-86 15:58") - (COLOROBJ.CREATE (IMAGEOBJPROP IMAGEOBJ 'COLOR) - TOSTREAM]) - -(COLOROBJ.WHENOPERATEDONFN - [LAMBDA (A B C C) (* gbn " 6-Jan-85 13:23") - (* DUMMY) - ]) -) - -(FILESLOAD COLOR) - -(RPAQ? COLOROBJ.DEFAULT.COLOR 'RED) - -(RPAQQ COLOROBJFNS (COLOROBJ.CREATE COLOROBJ.DISPLAYFN COLOROBJ.GETFN COLOROBJ.IMAGEBOXFN - COLOROBJ.PUTFN COLOROBJ.COPYFN COLOROBJ.WHENOPERATEDONFN)) - -(RPAQ COLOROBJ.IMAGEFNS - (IMAGEFNSCREATE (FUNCTION COLOROBJ.DISPLAYFN) - (FUNCTION COLOROBJ.IMAGEBOXFN) - (FUNCTION COLOROBJ.PUTFN) - (FUNCTION COLOROBJ.GETFN) - (FUNCTION COLOROBJ.COPYFN) - (FUNCTION COLOROBJ.BUTTONEVENTFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION COLOROBJ.WHENOPERATEDONFN) - (FUNCTION NILL))) -(PUTPROPS COLOROBJ COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1964 7057 (COLOROBJ.CREATE 1974 . 2380) (COLOROBJ.DISPLAYFN 2382 . 5080) ( -COLOROBJ.GETFN 5082 . 5411) (COLOROBJ.IMAGEBOXFN 5413 . 6375) (COLOROBJ.PUTFN 6377 . 6659) ( -COLOROBJ.COPYFN 6661 . 6850) (COLOROBJ.WHENOPERATEDONFN 6852 . 7055))))) -STOP diff --git a/obsolete/lispusers/COLOROBJ.LCOM b/obsolete/lispusers/COLOROBJ.LCOM deleted file mode 100644 index 985e4893..00000000 Binary files a/obsolete/lispusers/COLOROBJ.LCOM and /dev/null differ diff --git a/obsolete/lispusers/COLOROBJ.TEDIT b/obsolete/lispusers/COLOROBJ.TEDIT deleted file mode 100644 index 9be15d91..00000000 Binary files a/obsolete/lispusers/COLOROBJ.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/EDITKEYS b/obsolete/lispusers/EDITKEYS deleted file mode 100644 index f221788d..00000000 --- a/obsolete/lispusers/EDITKEYS +++ /dev/null @@ -1,141 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - -(FILECREATED " 4-Dec-2023 21:06:15" {WMEDLEY}EDITKEYS.;6 7146 - - :EDIT-BY rmk - - :CHANGES-TO (VARS EDITKEYSCOMS) - - :PREVIOUS-DATE "25-Oct-2022 10:58:27" {WMEDLEY}EDITKEYS.;5) - - -(PRETTYCOMPRINT EDITKEYSCOMS) - -(RPAQQ EDITKEYSCOMS - ((VARS KEY.TEMPLATE) - (FNS BUILDFNKEYS KEY.BITMAP) - (P (* ; "could have (STRIKEOUT)") - (* ; "RMK: Removed (HELP HELP)") - (BUILDFNKEYS '((BOLD BOLD) - (ITALICS ITALICS) - (CASE CASE) - (STRIKEOUT (STRIKE- OUT)) - (UNDERLINE (UNDER- LINE)) - (SUPERSCRIPT (SUPER/ SUB)) - (LARGER (LARGER SMALLER)) - (DEFAULTS DEFAULTS) - (CENTER JUSTIFY) - (AGAIN REDO)) - '(Tedit Keys) - 1)))) - -(RPAQQ KEY.TEMPLATE #*(78 48)OOOOOOOOOOOOOOOOOOOLON@@@@@@@@@@@@@@@AOLO@@@@@@@@@@@@@@@@@CLO@@@@@@@@@@@@@@@@@CLMH@@@@@@@@@@@@@@@@DLNLGOOOOOOOOOOOOOOHHLMFL@@@@@@@@@@@@@@M@LJK@@@@@@@@@@@@@@@B@DMF@@@@@@@@@@@@@@@A@DJN@@@@@@@@@@@@@@@AHDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMD@@@@@@@@@@@@@@@@HDJL@@@@@@@@@@@@@@@@HDMF@@@@@@@@@@@@@@@AHDJJ@@@@@@@@@@@@@@@A@DMG@@@@@@@@@@@@@@@B@DNEL@@@@@@@@@@@@@@O@LLIGOOOOOOOOOOOOOOMHLOBBJJJJJJJJJJJJJJJLLNDEEEEEEEEEEEEEEEEGLOHJJJJJJJJJJJJJJJJKLOLEEEEEEEEEEEEEEEEOLOOOOOOOOOOOOOOOOOOOL -) -(DEFINEQ - -(BUILDFNKEYS - [LAMBDA (KEYS TITLE NROWS) - - (* ;; "Edited 20-Jul-2022 08:40 by rmk: BKSYSBUF only if the TTY is TEDIT, change title to Tedit Keys, expand with left button. Move with background menu") - - (* ;; "Edited 20-Jul-2022 07:56 by rmk") - (* lmm " 5-Nov-85 15:35") - (LET - (ICONWINDOW) - [SETQ ICONWINDOW - (SHRINKW - (ADDMENU - [create - MENU - ITEMS _ - [for KEY in KEYS - collect - (LIST (KEY.BITMAP (CADR KEY)) - (LET [(KEYN (OR (SMALLP (CAR KEY)) - (\KEYNAMETONUMBER (CAR KEY] - (for LST in (LIST \DOVEKEYACTIONS \DLIONKEYACTIONS \ORIGKEYACTIONS) - do (AND [SETQ $$VAL (for KEY in LST - when (EQ (OR (SMALLP (CAR KEY)) - (\KEYNAMETONUMBER (CAR KEY))) - KEYN) do (RETURN (CADR KEY] - (RETURN (LIST (OR (SMALLP (CAR $$VAL)) - (CHARCODE.DECODE (CAR $$VAL))) - (OR (SMALLP (CADR $$VAL)) - (CHARCODE.DECODE (CADR $$VAL] - TITLE _ (SUBSTRING TITLE 2 -2) - MENUROWS _ NROWS - WHENSELECTEDFN _ (FUNCTION (LAMBDA (X) - (CL:WHEN (EQ '\TEDIT.PROCENTRYFN (FETCH (PROCESS PROCTTYENTRYFN - ) OF ( - TTY.PROCESS - ))) - [BKSYSCHARCODE (if (SHIFTDOWNP 'SHIFT) - then (CADR (CADR X)) - else (CAR (CADR X])] - NIL - (create POSITION - XCOORD _ (PLUS (DIFFERENCE (QUOTIENT SCREENWIDTH 2) - (QUOTIENT (TIMES (BITMAPWIDTH KEY.TEMPLATE) - (LENGTH KEYS)) - 2)) - (TIMES 2 WBorder)) - YCOORD _ 0)) - (KEY.BITMAP TITLE) - '(0 . 0] - [WINDOWPROP ICONWINDOW 'BUTTONEVENTFN (FUNCTION (LAMBDA (ICONW) - (CL:WHEN (LASTMOUSESTATE (OR LEFT MIDDLE)) - (CURSOR (PROG1 (CURSOR WAITINGCURSOR) - (EXPANDW ICONW))))] - ICONWINDOW]) - -(KEY.BITMAP - [LAMBDA (X) (* lmm " 5-Nov-85 14:04") - (PROG ((BITMAP (BITMAPCOPY KEY.TEMPLATE)) - DS QUARTER REGION) - (SETQ DS (DSPCREATE BITMAP)) - (DSPFONT MENUFONT DS) - (COND - ((LISTP X) - - (* this is supposed to have two labels, one on top of the other) - - (SETQ QUARTER (IQUOTIENT (BITMAPHEIGHT BITMAP) - 4)) - (CENTERPRINTINREGION (CADR X) - (SETQ REGION (create REGION - LEFT _ 0 - BOTTOM _ QUARTER - WIDTH _ (BITMAPWIDTH BITMAP) - HEIGHT _ QUARTER)) - DS) - (replace BOTTOM of REGION with (ITIMES 2 QUARTER)) - (CENTERPRINTINREGION (CAR X) - REGION DS)) - (T (CENTERPRINTINREGION X (create REGION - LEFT _ 0 - BOTTOM _ 0 - WIDTH _ (BITMAPWIDTH BITMAP) - HEIGHT _ (BITMAPHEIGHT BITMAP)) - DS))) - (RETURN BITMAP]) -) - - (* ; "could have (STRIKEOUT)") - - (* ; "RMK: Removed (HELP HELP)") - -(BUILDFNKEYS '((BOLD BOLD) - (ITALICS ITALICS) - (CASE CASE) - (STRIKEOUT (STRIKE- OUT)) - (UNDERLINE (UNDER- LINE)) - (SUPERSCRIPT (SUPER/ SUB)) - (LARGER (LARGER SMALLER)) - (DEFAULTS DEFAULTS) - (CENTER JUSTIFY) - (AGAIN REDO)) - '(Tedit Keys) - 1) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (2120 6542 (BUILDFNKEYS 2130 . 5158) (KEY.BITMAP 5160 . 6540))))) -STOP diff --git a/obsolete/lispusers/EDITKEYS.LCOM b/obsolete/lispusers/EDITKEYS.LCOM deleted file mode 100644 index 98975a58..00000000 Binary files a/obsolete/lispusers/EDITKEYS.LCOM and /dev/null differ diff --git a/obsolete/lispusers/EDITKEYS.TEDIT b/obsolete/lispusers/EDITKEYS.TEDIT deleted file mode 100644 index 32ed4d68..00000000 Binary files a/obsolete/lispusers/EDITKEYS.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/ENDNOTE b/obsolete/lispusers/ENDNOTE deleted file mode 100644 index cdfda194..00000000 --- a/obsolete/lispusers/ENDNOTE +++ /dev/null @@ -1,419 +0,0 @@ -(FILECREATED "18-Feb-87 15:43:31" {SUMEX-AIM}PS:ENDNOTE.;4 15652 - - changes to: (FNS NOTE.BUTTONEVENTINFN) - - previous date: "18-Feb-87 10:11:49" {SUMEX-AIM}PS:ENDNOTE.;6) - - -(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) - -(PRETTYCOMPRINT ENDNOTECOMS) - -(RPAQQ 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) - (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.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 "17-Feb-87 10:47") - - (* * Insert an ENDNOTE ImageObject as a superscript. Displayed as a number when updated.) - - - (LET ((NOBJ (NUMBEROBJ 'NOTE))) - (TEDIT.INSERT.OBJECT NOBJ STREAM) - (COND - ((UPDATE? WINDOW) - (UPDATE.NUMBEROBJS WINDOW 'ENDNOTEP)) - (T NIL)) - (replace (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of NOBJ) - with (TEDIT.GETINPUT STREAM "Endnote text:")) - (TEDIT.PROMPTPRINT STREAM "" T)))) - -(INSERT.ENDNOTES - (LAMBDA (STREAM WINDOW) (* fsg "18-Feb-87 09:38") - - (* * 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 (TSP.LIST.OF.OBJECTS TEXTOBJ 'ENDNOTEP)) - (CARETPOSITION (fetch CH# of (TEDIT.GETSEL STREAM)))) - (DELETE.ENDNOTES STREAM) - (COND - (LIST.OF.ENDNOTES (TEDIT.PROMPTPRINT STREAM - "Inserting notes at the end of the document..." - 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 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)) - ) - (T NIL))))) - -(INSERT.ENDNOTES.TEXT - (LAMBDA (STREAM TEXTOBJ LIST.OF.ENDNOTES) (* fsg " 7-Jan-87 14:31") - - (* * Here to print the text of each endnote.) - - - (LET ((TEXTLOOKS (fetch (ENDNOTEFONTS TEXT.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 NUMBER.TEXT) of (fetch OBJECTDATUM - of (CAR ENDNOTEOBJ))))) - (TEDIT.INSERT STREAM NUMSTRING (ADD1 (fetch TEXTLEN of TEXTOBJ)) - TEXTLOOKS T) - (TEDIT.INSERT STREAM (CONCAT " " TEXT (CHARACTER (CHARCODE EOL))) - (ADD1 (fetch TEXTLEN of TEXTOBJ)) - TEXTLOOKS T)))))) - -(DELETE.ENDNOTES - (LAMBDA (STREAM) (* fsg "18-Feb-87 09:11") - - (* * 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 NOTEMARKER.LIST (TEDIT.DELETE STREAM NOTES.START (IDIFFERENCE (ADD1 NOTES.END) - NOTES.START)))))) - -(NOTESREGIONP - (LAMBDA (IMOBJ) (* fsg "26-Jan-87 09:41") - (AND (REGMARKOBJP IMOBJ) - (EQ (fetch REGION.USE of (fetch OBJECTDATUM of IMOBJ)) - 'ENDNOTES)))) - -(SET.ENDNOTE.STYLE - (LAMBDA (STREAM WINDOW) (* fsg " 9-Jan-87 09:18") - - (* * 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 " - (LIST (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) (* fsg " 9-Jan-87 09:09") - - (* * 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) (* fsg " 5-Jan-87 10:40") - - (* * 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: " 2-Jul-85 16:51") - (AND (NUMBEROBJP IMOBJ) - (EQ (fetch USE of (fetch OBJECTDATUM of IMOBJ)) - 'NOTE)))) - -(NOTE.PUTFN - (LAMBDA (NUMBEROBJ STREAM WINDOW) (* fsg "28-Jan-87 13:48") - - (* * Used to put a numberobj that is functioning as an endnote.) - - - (replace (NUMBEROBJ FONT) of (fetch OBJECTDATUM of NUMBEROBJ) - with (for NOTEFONT in (GET.ENDNOTE.FONTS WINDOW) collect (LIST.FONT.PROPS NOTEFONT) - )) - (PRIN4 (LIST 'Endnote - (IMAGEOBJPROP NUMBEROBJ 'TAG) - (fetch OBJECTDATUM of NUMBEROBJ)) - STREAM))) - -(NOTE.GETFN - (LAMBDA (NEWOBJ USE/TEXT WINDOW) (* fsg " 8-Jan-87 10:19") - - (* * Used to get a numberobj that is functioning as an endnote.) - - - (WINDOWPROP WINDOW 'ENDNOTE.FONTS - (for NOTEFONT in (fetch (NUMBEROBJ FONT) of USE/TEXT) - collect (FONTCREATE NOTEFONT))) - (replace (NUMBEROBJ FONT) of USE/TEXT with NIL) - (replace OBJECTDATUM of NEWOBJ with USE/TEXT) - NEWOBJ)) - -(NOTE.BUTTONEVENTINFN - (LAMBDA (NUMBEROBJ STREAM) (* fsg "18-Feb-87 11:16") - - (* * Bring up another TEdit window where user can edit the text of an Endnote.) - - - (MENU (create MENU - TITLE _ 'Endnotes% Menu - CENTERFLG _ T - ITEMS _ '((Edit% Endnote (AUX.TEDIT NUMBEROBJ - (CONCAT "Endnote #" - (fetch NUMSTRING of - (fetch OBJECTDATUM of - NUMBEROBJ))) - STREAM)) - (Tag% Endnote (XREF.TAG.OBJECT NUMBEROBJ STREAM))))))) -) -[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) (* fsg "20-Jan-87 15:46") - - (* * 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 (MKSTRING (fetch (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM - of IMOBJ))) - AUXWINDOW NIL '(AFTERQUITFN AUX.TEDIT.AFTERQUITFN TITLEMENUFN - AUX.TEDIT.TITLEMENUFN))))) - -(AUX.TEDIT.AFTERQUITFN - (LAMBDA (AUXWINDOW) (* fsg "20-Jan-87 15:56") - - (* * 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) (* fsg "20-Jan-87 15:49") - - (* * 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 NUMBER.TEXT) - 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) (* ss: "15-Jul-85 11:54") - (LET ((NEWOBJ (IMAGEOBJCREATE (create REGMARKOBJ - REGION.USE _ USE - MARKING _ MARKING) - (IMAGEFNSCREATE (FUNCTION REGMARK.DISPLAYFN) - (FUNCTION REGMARK.IMAGEBOXFN) - (FUNCTION REGMARK.PUTFN) - (FUNCTION REGMARK.GETFN) - (FUNCTION NILL) - (FUNCTION REGMARK.BUTTONEVENTINFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL))))) - (IMAGEOBJPROP NEWOBJ 'TYPE - 'REGMARKOBJ) - NEWOBJ))) - -(REGMARKOBJP - (LAMBDA (IMOBJ) (* ss: "12-Jul-85 15:04") - (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 "28-Jan-87 14:10") - (PRIN2 (LIST 'Region - (IMAGEOBJPROP MARKOBJ 'TAG) - (LIST (fetch REGION.USE of (fetch OBJECTDATUM of MARKOBJ)) - (fetch MARKING of (fetch OBJECTDATUM of MARKOBJ)))) - STREAM))) - -(REGMARK.GETFN - (LAMBDA (STREAM) (* fsg "28-Jan-87 16:06") - (OR (WINDOWPROP (PROCESSPROP (THIS.PROCESS) - 'WINDOW) - 'IMAGEOBJ.MENUW) - (TSP.FMMENU (TEXTSTREAM (PROCESSPROP (THIS.PROCESS) - 'WINDOW)))) - (LET* ((REGMARK.ARGS (CDR (READ STREAM))) - (NEWOBJ (APPLY 'REGMARKOBJ - (CADR REGMARK.ARGS)))) - (IMAGEOBJPROP NEWOBJ 'TAG - (CAR REGMARK.ARGS)) - NEWOBJ))) - -(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 ENDNOTE COPYRIGHT ("Leland Stanford Junior University" 1987)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (1240 8234 (ADD.ENDNOTE 1252 . 1873) (INSERT.ENDNOTES 1877 . 3628) (INSERT.ENDNOTES.TEXT - 3632 . 4538) (DELETE.ENDNOTES 4542 . 5135) (NOTESREGIONP 5139 . 5384) (SET.ENDNOTE.STYLE 5388 . 7086) - (MAP.ENDNOTE.LOOKS 7090 . 7727) (GET.ENDNOTE.FONTS 7731 . 8231)) (8236 10115 (ENDNOTEP 8248 . 8477) ( -NOTE.PUTFN 8481 . 9034) (NOTE.GETFN 9038 . 9547) (NOTE.BUTTONEVENTINFN 9551 . 10112)) (10280 12228 ( -AUX.TEDIT 10292 . 11019) (AUX.TEDIT.AFTERQUITFN 11023 . 11495) (AUX.TEDIT.TITLEMENUFN 11499 . 12225)) -(12302 15479 (REGMARKOBJ 12314 . 13131) (REGMARKOBJP 13135 . 13328) (REGMARK.DISPLAYFN 13332 . 13548) -(REGMARK.IMAGEBOXFN 13552 . 13859) (REGMARK.PUTFN 13863 . 14228) (REGMARK.GETFN 14232 . 14759) ( -REGMARK.BUTTONEVENTINFN 14763 . 15476))))) -STOP diff --git a/obsolete/lispusers/EVAL-WHEN-PATCH b/obsolete/lispusers/EVAL-WHEN-PATCH deleted file mode 100644 index 44523995..00000000 --- a/obsolete/lispusers/EVAL-WHEN-PATCH +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (filecreated " 2-Jun-87 14:51:46" {dsk}work>eval-when-patch.\;1 30488 |changes| |to:| (vars eval-when-patchcoms) (fns addtocom delfromcom getdefcurrent importeval infilecom)) ; Copyright (c) 1987 by Xerox Corporation. All rights reserved. (prettycomprint eval-when-patchcoms) (rpaqq eval-when-patchcoms ((fns addtocom delfromcom getdefcurrent importeval infilecom))) (defineq (addtocom (lambda (com name type near listname) (* \; "Edited 2-May-87 19:04 by Pavel") (* \;  "tries to insert NAME into the prettycom COM; returns NIL if unsuccessful") (prog (tem) (cond ((and near (not (infilecoms? near type (list com)))) (return))) (cond ((setq tem (|fetch| add |of| (car com))) (return (cond ((or (null listname) (infilecoms? listname 'filevars (list com))) (and (setq tem (apply* tem com name type near)) (markaschanged comsname 'vars)) tem))))) (return (selectq (car com) (fns (and (eq type 'fns) (addtocom1 com name near listname))) ((vars initvars) (cond ((or (eq (car com) 'vars) near listname) (* \;  "Don't stick on INITVARS unless NEAR or LISTNAME says we should.") (selectq type (expressions (cond ((eq (car name) 'setq) (addtocom1 com (cdr name) near listname)))) (vars (addtocom1 com name near listname)) nil)))) (coms (addtocoms (cond ((eq (cadr com) '*) (cond ((litatom (caddr com)) (caddr com)) (t (return)))) (t (cdr com))) name type near listname)) (declare\: (and (or listname near) (addtocoms (cond ((eq (cadr com) '*) (cond ((litatom (caddr com)) (caddr com)) (t (return)))) (t (cdr com))) name type near listname))) (cl:eval-when (and (or listname near) (addtocoms (cond ((eq (cl:third com) '*) (cond ((litatom (cl:fourth com)) (cl:fourth com)) (t (return)))) (t (cddr com))) name type near listname))) ((prop ifprop) (selectq type (props (cond ((eq (cadr com) (cadr name)) (addtocom1 (cdr com) (car name) near listname)) ((and (eq (car name) (caddr com)) (null (cdddr com))) (/rplaca (cdr com) (union (mklist (cdr name)) (mklist (cadr com)))) (markaschanged comsname 'vars) t))) (macros (cond ((and (|for| prop |inside| (cadr com) |always| (eqmemb prop macroprops)) (|for| prop |in| macroprops |always| (or (eqmemb prop (cadr com)) (not (getprop name prop))))) (* |;;| "every property in the command is a macro prop and, either this is an IFPROP or else the MACROS are changed") (addtocom1 (cdr com) name near listname)))) nil)) ((props alists) (and (eq type (car com)) (addtocom1 com (/nconc1 (or (assoc (car name) (cond ((eq (cadr com) '*) (cond ((litatom (caddr com)) (and (or (null listname) (eq (caddr com) listname)) (gettopval (caddr com)))) (t (return)))) (t (cdr com)))) (list (car name))) (cadr name)) near listname))) (p (cond ((and (eq type 'expressions) (neq (car name) 'setq)) (addtocom1 com name near listname)))) (and (eq (car com) type) (addtocom1 com name near listname))))))) (delfromcom (lambda (com name type) (* \; "Edited 2-May-87 19:02 by Pavel") (* \; "Tries to delete NAME from COM") (prog (tem var new) (cond ((setq tem (|fetch| delete |of| (car com))) (and (setq tem (apply* tem com name type)) (markaschanged comsname 'vars)) (return tem))) (return (selectq (car com) ((declare\: coms) (delfromcoms (cond ((eq (cadr com) '*) (cond ((litatom (caddr com)) (caddr com)) (t (return)))) (t (cdr com))) name type)) ((cl:eval-when) (delfromcoms (cond ((eq (cl:third com) '*) (cond ((litatom (cl:fourth com)) (cl:fourth com)) (t (return)))) (t (cddr com))) name type)) ((alists props) (and (eq type (car com)) (cond ((eq (cadr com) '*) (cond ((and (litatom (setq var (caddr com))) (setq tem (assoc (car name) (gettopval var))) (neq (cdr tem) (setq tem (removeitem (cadr name) (cdr tem))))) (saveset var tem t 'noprint) t))) ((and (cdr (setq tem (assoc (car name) (cdr com)))) (neq (cdr tem) (setq new (removeitem (cadr name) (cdr tem))))) (/rplacd tem new) (markaschanged comsname 'vars) t)))) (blocks (* |;;| "Remove function name from blocks declarations. This isn't entirely correctly, since in removing the name from the block variables, it will hit homonyms in globalvars, specvars, etc.") (and (eq type 'fns) (|for| block |in| (infilecomtail com t) |do| (and (memb name block) (/dremove name block)) (|for| x |in| block |when| (and (listp x) (memb name (cdr x))) |do| (/rplacd x (remove name (cdr x))))))) ((prop ifprop) (selectq type (props (return (cond ((eq (cadr com) (cadr name)) (delfromcom1 (cdr com) (car name))) ((and (eqmemb (cadr name) (cadr com)) (null (cdr (setq tem (prettycom1 (cdr com))))) (eq (car tem) (car name))) (/rplaca (cdr com) (remove (cadr name) (mklist (cadr com)))) (markaschanged comsname 'vars) t)))) (cond ((|for| prop |inside| (cadr com) |always| (eq type (getprop prop 'proptype))) (delfromcom1 (cdr com) name))))) ((records initrecords sysrecords) (and (eq type 'records) (delfromcom1 com name))) (p (and (eq type 'expressions) (delfromcom1 com name))) ((vars initvars) (and (eq type 'vars) (delfromcom1 com name t))) (and (eq type (car com)) (delfromcom1 com name))))))) (getdefcurrent (lambda (name type options) (* \; "Edited 2-May-87 19:00 by Pavel") (* \;  "Gets the current definition--source=0") (let (def) (cond ((and (setq def (|fetch| getdef |of| type)) (neq def t)) (* |;;| "We assign T to types whose GETDEF is normally handled in the SELECTQ below but whose MACRO is to be defaulted to the PUTDEF/GETDEF in PRETTYCOM.") (or (neq (setq def (apply* def name type options)) (|fetch| nulldef |of| type)) (getdeferr name type options)) def) (t (or (neq (setq def (selectq type (fns (and (litatom name) (exprp (setq def (virginfn name))) def)) (vars (|if| (litatom name) |then| (gettopval name) |else| 'nobind)) ((fields records) (|if| (litatom name) |then| (setq def (selectq type (records (reclook name)) (mkprogn (fieldlook name)))) (|if| (eqmemb 'edit options) |then| (copy def) |else| def))) (files (* \;  "what is the `definition' of a file? -- I guess the COMS which say what it contains") (|if| (litatom name) |then| (|if| (setq def (getfiledef name)) |then| (updatefiles) (list (listp (gettopval (filecoms def))) (|fetch| tobedumped |of| (|fetch| fileprop |of| def)) (listp (|fetch| filedates |of| def)))))) (templates (|if| (and (litatom name) (setq def (gettemplate name))) |then| (list 'settemplate (kwote name) (kwote def)))) (macros (|if| (and (litatom name) (setq def (|for| x |on| (getproplist name) |by| (cddr x) |when| (fmemb (car x) macroprops) |join| (list (car x) (cadr x))))) |then| `(putprops ,name ,@def))) (expressions (listp name)) (props (and (listp name) (and (setq def (some (getproplist (car name)) (function (lambda (x) (eq x (cadr name)))) (function cddr))) (list 'putprops (car name) (cadr name) (cadr def))))) (filepkgcoms (and (litatom name) (prog ((com (filepkgcom name)) (typ (filepkgtype name))) (return (cond ((and com typ) (list (cons 'com com) (cons 'type typ))) (com (list (cons 'com com))) (typ (list (cons 'type typ)))))))) (filevars (cond ((and (litatom name) (listp (setq def (gettopval name))) (whereis name 'filevars)) def) (t 'nobind))) (let ((coms (list (makenewcom name type))) file) (cond ((not (setq def (getdefcom coms))) (with-reader-environment *old-interlisp-read-environment* (resetlst (resetsave prettyflg) (resetsave fontchangeflg) (resetsave (output (setq file (openstream '{nodircore} 'both)))) (prettydefcoms coms) (setfileptr file 0) (setq def (|for| x |in| (readfile file) |join| (selectq (car x) ((*) nil) (declare\: (|for| y |on| (cdr x) |unless| (selectq (car y) ((copywhen eval@loadwhen eval@compilewhen) (return (list y))) (fmemb (car y) declaretagslst)) |collect| (car y))) (cl:eval-when (cddr x)) (progn (cdr x)) (list x)))) (setq nocopy t))))) (mkprogn def)))) (|fetch| nulldef |of| type)) (getdeferr name type options)) def))))) (importeval (lambda (form returnflg) (* \; "Edited 2-May-87 18:57 by Pavel") (* |;;| "Ignore DONTEVAL@LOAD'S --- If RETURNFLG is on, return list of forms") (and (listp form) (selectq (car form) (declare\: (for z in (cdr form) join (importeval z returnflg))) (cl:eval-when (for z in (cddr form) join (importeval z returnflg))) (/declaredatatype (* \;  "Ignore datatype initializations -- we only need the record declaration itself") nil) (progn (* \; "default: eval and/or return it") (and (neq returnflg t) (eval form)) (and returnflg (list form))))))) (infilecom (lambda (com) (* \; "Edited 2-May-87 19:03 by Pavel") (cond ((nlistp com) (cond ((eq type 'vars) (infilecomsval com)))) ((eq (car com) commentflg) (* |;;|  "must be special case'd first so that (* * values) doesn't make it look like `values' is a variable") (* \;  "don't know why I should bother, but someone might want to know all of the comments on a file???") (cond ((eq type commentflg) (infilecomsval com t))) nil) (t (prog ((comname (car com)) (tail (cdr com)) cfn tem) (cond ((cond ((setq cfn (|fetch| (filepkgcom contents) |of| comname)) (setq tem (apply* cfn com (cond ((and (null onfiletype) (listp name)) (* \;  "call from WHEREIS of a name which is a list") (list name)) (t name)) type onfiletype))) ((setq cfn (|fetch| (filepkgcom prettytype) |of| comname)) (* \; "for compatability") (setq tem (apply* cfn com type name)))) (cond ((nlistp tem) (cond ((eq tem t) (cond ((or (eq name t) (null onfiletype)) (retfrom 'infilecoms? t)))))) (t (infilecomsvals tem)))) ((listp tail) (* |;;| "this SELECTQ handles the `exceptional cases' for the built in types. There is an explicit RETURN in the SELECTQ clause if the default is handled") (selectq comname ((prop ifprop) (setq tail (cdr tail))) nil) (cond ((eq (car tail) '*) (cond ((litatom (cadr tail)) (selectq type ((vars filevars) (infilecomsval (cadr tail))) nil)) ((and (listp (cadr tail)) (eq onfiletype 'update) (eq type 'vars) (eq (caadr tail) 'progn) (fmemb (car (last (cadr tail))) name)) (setq val (cons (cadr tail) val)))))) (selectq comname ((coms export) (infilecoms (infilecomtail com))) (cl:eval-when (infilecoms (infilecomtail (cdr com)))) (declare\: (* \; "skip over DECLARE: tags") (return (and (not (fmemb 'compilervars com)) (ifcdeclare (infilecomtail com) (eq type 'declare\:))))) (original (* \; "dont expand macros") (prog ((origflg t)) (infilecoms (infilecomtail com)))) ((prop ifprop) (* \;  "this currently does not handle `pseudo-types' of PROPNAMES") (selectq type (props (ifcpropscan (infilecomtail (cdr com)) (cadr com))) (macros (infilecomsmacro (infilecomtail (cdr com)) (cadr com))) nil)) (props (return (ifcprops com))) (macros (return (selectq type (props (ifcpropscan (infilecomtail com) macroprops)) (macros (infilecomsvals (infilecomtail com))) nil))) (alists (* \;  "sigh. This should probably also `coerce' when asking for LISPXMACROS, etc.") (return (selectq type (alists (infilepairs (infilecomtail com))) nil))) (p (return (selectq type ((expressions p) (infilecomsvals (infilecomtail com t) t)) (cond ((null onfiletype) (* \; "for WHEREIS and FILECOMSLST") (selectq type (i.s.oprs (ifcexprtype com 'i.s.opr)) (templates (ifcexprtype com 'settemplate)) nil)))))) ((addvars appendvars) (selectq type (vars (return (and (null onfiletype) (|for| x |in| (infilecomtail com t) |do| (infilecomsval (car x) t))))) (alists (return (|for| x |in| (infilecomtail com) |when| (eqmemb 'alist (getprop (car x) 'vartype)) |do| (|for| z |in| (cdr x) |do| (infilecomsval (list (car x) (car z)) t))))) (or (eq type comname) (return)))) ((vars initvars filevars uglyvars horriblevars constants array) (return (cond ((eq type 'expressions) (|for| x |in| (infilecomtail com) |when| (listp x) |do| (infilecomsval (cons 'setq x) t))) ((or (eq type 'vars) (eq type comname))(* \;  "either want all VARS, or else want all FILEVARS and this is a FILEVARS command") (|for| x |in| (infilecomtail com) |do| (cond ((listp x) (and (car x) (infilecomsval (car x) t))) (x (infilecomsval x (eq comname 'initvars))))))))) (defs (return (|for| x |in| (infilecomtail com) |when| (eq type (car x)) |do| (infilecomsvals (cdr x))))) (files (return)) nil) (* |;;| "Exceptional cases now handled. If TYPE matches (CAR COM) then scan the tail as usual. Else expand the com's MACRO, if it has one, unless there was a CONTENTS function") (cond ((eq comname type) (infilecomsvals (infilecomtail com))) ((and (or (null cfn) (and (eq cfn t) (null onfiletype))) (null origflg) (setq tem (|fetch| (filepkgcom macro) |of| comname))) (infilecoms (subpair (car tem) (infilecomtail com) (cdr tem)))))))))))) ) (putprops eval-when-patch copyright ("Xerox Corporation" 1987)) (declare\: dontcopy (filemap (nil (475 30395 (addtocom 485 . 7020) (delfromcom 7022 . 12896) (getdefcurrent 12898 . 19529) (importeval 19531 . 20542) (infilecom 20544 . 30393))))) stop \ No newline at end of file diff --git a/obsolete/lispusers/FASTEDITBM b/obsolete/lispusers/FASTEDITBM deleted file mode 100644 index fa5e7dda..00000000 --- a/obsolete/lispusers/FASTEDITBM +++ /dev/null @@ -1,1431 +0,0 @@ -(FILECREATED "16-Nov-87 17:15:41" {ERINYES}KOTO>FASTEDITBM.;3 68144 - - changes to: (FNS EXPANDBITMAP) - (VARS FASTEDITBMCOMS) - - previous date: " 4-Sep-87 15:58:23" {ERINYES}KOTO>FASTEDITBM.;2) - - -(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT FASTEDITBMCOMS) - -(RPAQQ FASTEDITBMCOMS ((DECLARE: DONTCOPY (MACROS UPDATE/BM/DISPLAY)) - (P (SETQ EDITBMMENU NIL)) - (FNS GRID) - (FNS EDITBM EDITBMCLOSEFN TILEAREA EDITBMBUTTONFN EDITBMSCROLLFN - \EDITBM/PUTUP/DISPLAY EDITBMRESHAPEFN EDITBMREPAINTFN.NEW - EDITBMREPAINTFN RESETGRID.NEW) - (FNS SCALEBM BLTPATTERN BLTPATTERN.REPLACEDISPLAY) - (FNS EXPANDBITMAP EXPANDBM))) -(DECLARE: DONTCOPY -(DECLARE: EVAL@COMPILE -[PUTPROPS UPDATE/BM/DISPLAY MACRO ((BM W) - (BITBLT BM (WINDOWPROP W (QUOTE DXOFFSET)) - (WINDOWPROP W (QUOTE DYOFFSET)) - W 0 (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM)) - (WINDOWPROP W (QUOTE BMDISPLAYWIDTH)) - 1000 NIL (QUOTE REPLACE] -) -) -(SETQ EDITBMMENU NIL) -(DEFINEQ - -(GRID - [LAMBDA (GRIDSPEC WIDTH HEIGHT BORDER DS GRIDSHADE) (* N.H.Briggs " 4-Sep-87 15:39") - (* ; "draws a grid") - (PROG ((X0 (fetch (REGION LEFT) of GRIDSPEC)) - (Y0 (fetch (REGION BOTTOM) of GRIDSPEC)) - (SQWIDTH (fetch (REGION WIDTH) of GRIDSPEC)) - (SQHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC)) - (GRIDSHADE (COND - ((TEXTUREP GRIDSHADE)) - (T BLACKSHADE))) - LINELENGTH TWICEBORDER MAXIMUMCOLOR TOTALHEIGHT GRIDBM TEMPBM) - (SETQ TOTALHEIGHT (ITIMES HEIGHT SQHEIGHT)) - (COND - ((OR (ZEROP BORDER) - (NULL BORDER)) (* ; "don't draw anything.") - (RETURN)) - [(NUMBERP BORDER) - (SETQ TWICEBORDER (ITIMES BORDER 2)) - (PROGN (* ;;  -  -"draw vertical lines use BITBLT so that we don't have to correct for the width of the line since line drawing will put the coordinate in the middle." -) - (BLTSHADE GRIDSHADE DS X0 Y0 BORDER TOTALHEIGHT (QUOTE REPLACE)) - (for X from (IDIFFERENCE (IPLUS X0 SQWIDTH) - BORDER) - to (IDIFFERENCE (IPLUS X0 (ITIMES (SUB1 WIDTH) - SQWIDTH)) - BORDER) - by SQWIDTH do (BLTSHADE GRIDSHADE DS X Y0 TWICEBORDER TOTALHEIGHT - (QUOTE REPLACE))) - (BLTSHADE GRIDSHADE DS (IDIFFERENCE (IPLUS X0 (ITIMES WIDTH SQWIDTH)) - BORDER) - Y0 BORDER TOTALHEIGHT (QUOTE REPLACE))) - (PROGN (* ; "draw horizontal lines") - (BLTSHADE GRIDSHADE DS X0 Y0 (SETQ LINELENGTH (ITIMES WIDTH SQWIDTH)) - BORDER - (QUOTE REPLACE)) - (for Y from (IDIFFERENCE (IPLUS Y0 SQHEIGHT) - BORDER) - to (IDIFFERENCE (IPLUS Y0 (ITIMES (SUB1 HEIGHT) - SQHEIGHT)) - BORDER) - by SQHEIGHT do (BLTSHADE GRIDSHADE DS X0 Y LINELENGTH TWICEBORDER - (QUOTE REPLACE))) - (BLTSHADE GRIDSHADE DS X0 (IDIFFERENCE (IPLUS Y0 TOTALHEIGHT) - BORDER) - LINELENGTH BORDER (QUOTE REPLACE] - [(EQ BORDER (QUOTE POINT)) (* ; -"put a point in the lower left corner of each box") - (if (WINDOWP DS) - then (SETQ TEMPBM (WINDOWPROP DS (QUOTE TEMPBM))) - (SETQ GRIDBM (WINDOWPROP DS (QUOTE GRIDBM))) - (if (NOT GRIDBM) - then (SETQ GRIDBM (BITMAPCREATE SQWIDTH SQHEIGHT)) - (WINDOWPROP DS (QUOTE GRIDBM) - GRIDBM)) - (BLTSHADE WHITESHADE GRIDBM 0 0) - (* ; "Clear temporary bitmap.") - (BLTSHADE BLACKSHADE GRIDBM 0 0 1 1 (QUOTE REPLACE)) - (* ; "Put spot down.") - (* ; "Fill up temporary bitmap.") - (BLTPATTERN GRIDBM 0 0 SQWIDTH SQHEIGHT DS X0 Y0 (ITIMES WIDTH SQWIDTH) - (ITIMES HEIGHT SQHEIGHT) - (QUOTE PAINT) - TEMPBM) - else [SETQ MAXIMUMCOLOR (SUB1 (EXPT 2 (BITSPERPIXEL (DSPDESTINATION - NIL DS] - (* ;; "Crufty slow original code.") - (for X from X0 to (IPLUS X0 (ITIMES WIDTH SQWIDTH)) by SQWIDTH - do (for Y from Y0 to (IPLUS Y0 TOTALHEIGHT) by SQHEIGHT - do (BITMAPBIT DS X Y MAXIMUMCOLOR] - (T (\ILLEGAL.ARG BORDER]) -) -(DEFINEQ - -(EDITBM - [LAMBDA (BMSPEC) (* N.H.Briggs " 4-Sep-87 15:39") - (* ;;; "A simple bitmap editor.") - (* ;;  -  -"The edit part of the display is from 0 to MAXGRIDWIDTH in width and from 0 to MAXGRIDHEIGHT in height. The commands and display area for the bitmap being edited are above the edit region." -) - (DECLARE (GLOBALVARS SCREENWIDTH SCREENHEIGHT)) - (PROG (BMW BMWINTERIOR BMWWIDTH BMWHEIGHT WIDTH HEIGHT BM CR ORIGBM GRIDSQUARE BPP ORIGBPP - ORIGWIDTH) (* ;  -  -"set ORIGBM to the input bitmap if any and BM to a copy of it for editting.") - [COND - ((OR (EQ BMSPEC CursorBitMap) - (AND (EQ BMSPEC (QUOTE CursorBitMap)) - (SETQ BMSPEC CursorBitMap))) (* ;  -  -"editing cursor, save old value and make changes to the original.") - (SETQ ORIGBM (BITMAPCOPY CursorBitMap)) - (SETQ BM CursorBitMap)) - [(BITMAPP BMSPEC) - (SETQ BM (BITMAPCOPY (SETQ ORIGBM BMSPEC] - [(LITATOM BMSPEC) - (COND - ([BITMAPP (SETQ ORIGBM (EVALV BMSPEC (QUOTE EDITBM] - (* ; "use value.") - (SETQ BM (BITMAPCOPY ORIGBM))) - (T (SETQ ORIGBM NIL) - (SETQ BM (\READBMDIMENSIONS] - ((REGIONP BMSPEC) (* ;  -  -"if BMSPEC is a region, treat it as a region of the screen.") - [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of BMSPEC) - (fetch (REGION HEIGHT) of BMSPEC) - (BITSPERPIXEL (SCREENBITMAP] - (* ; "note that bm has initial bits in it.") - (SETQ ORIGBM BMSPEC) - (BITBLT (SCREENBITMAP) - (fetch (REGION LEFT) of BMSPEC) - (fetch (REGION BOTTOM) of BMSPEC) - BM 0 0 NIL NIL (QUOTE INPUT) - (QUOTE REPLACE))) - ((WINDOWP BMSPEC) - (SETQ ORIGBM BMSPEC) (* ;;  -  -"FS: Seems too big below, why not ClipRegion's Width & Height? That's all that's used...") - (SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC (QUOTE WIDTH)) - (WINDOWPROP BMSPEC (QUOTE HEIGHT)) - (BITSPERPIXEL BMSPEC))) - (* ; "open the window and bring it to the top.") - (TOTOPW BMSPEC) - (SETQ CR (DSPCLIPPINGREGION NIL BMSPEC)) - (BITBLT BMSPEC (fetch (REGION LEFT) of CR) - (fetch (REGION BOTTOM) of CR) - BM 0 0 (fetch (REGION WIDTH) of CR) - (fetch (REGION HEIGHT) of CR))) - (T (* ; "otherwise create a bitmap") - (SETQ BM (\READBMDIMENSIONS] - (if (OR (EQ (BITMAPHEIGHT BM) - 0) - (EQ (BITMAPWIDTH BM) - 0)) - then (ERROR "Can't edit a bitmap with no bits in it." BMSPEC)) - (SETQ BPP (BITSPERPIXEL (SCREENBITMAP))) - (SETQ ORIGBPP (fetch (BITMAP BITMAPBITSPERPIXEL) of BM)) - [COND - ((NOT (EQ BPP ORIGBPP)) (* ;;  -  -"save the actual number of bits per pixel and set it to BPP in the bitmap being edited so that it can be BITBLT ed on the screen." -) - (SETQ ORIGWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) - (replace (BITMAP BITMAPBITSPERPIXEL) of BM with BPP) - (SETQ WIDTH (IQUOTIENT (ITIMES ORIGBPP ORIGWIDTH) - BPP)) - (replace (BITMAP BITMAPWIDTH) of BM with WIDTH)) - (T (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BM] - (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) - (* ;;  -  -"Calculate a default window size. Start by calculating the grid size from the bitmap size.") - (SETQ GRIDSQUARE (IMAX (IMIN (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES - SCREENWIDTH - 2) - 3) - GRIDTHICKNESS) - WIDTH) - (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES - - SCREENHEIGHT 2) - 3) - (ITIMES GRIDTHICKNESS 2)) - (ADD1 HEIGHT)) - NORMALGRIDSQUARE) - MINGRIDSQUARE)) - (SETQ BMWWIDTH (IMIN (IPLUS (ITIMES GRIDSQUARE WIDTH) - GRIDTHICKNESS) - (IQUOTIENT (ITIMES SCREENWIDTH 2) - 3))) - (SETQ BMWHEIGHT (IMIN (IPLUS (ITIMES HEIGHT (ADD1 GRIDSQUARE)) - (ITIMES GRIDTHICKNESS 2) - 1) - (IQUOTIENT (ITIMES SCREENHEIGHT 2) - 3))) - (SETQ BMW (CREATEW (GETBOXREGION (WIDTHIFWINDOW BMWWIDTH) - (HEIGHTIFWINDOW BMWHEIGHT T) - NIL NIL NIL - "Indicate the position for the Bitmap Edit window.") - "Bitmap Editor")) - (WINDOWPROP BMW (QUOTE BM) - BM) - (WINDOWPROP BMW (QUOTE SCROLLFN) - (FUNCTION EDITBMSCROLLFN)) - (WINDOWPROP BMW (QUOTE RESHAPEFN) - (FUNCTION EDITBMRESHAPEFN)) - (WINDOWPROP BMW (QUOTE REPAINTFN) - (FUNCTION EDITBMREPAINTFN)) - (WINDOWPROP BMW (QUOTE BUTTONEVENTFN) - (FUNCTION EDITBMBUTTONFN)) - (WINDOWPROP BMW (QUOTE CLOSEFN) - (FUNCTION EDITBMCLOSEFN)) - (WINDOWPROP BMW (QUOTE XOFFSET) - 0) - (WINDOWPROP BMW (QUOTE YOFFSET) - 0) - (WINDOWPROP BMW (QUOTE DXOFFSET) - 0) - (WINDOWPROP BMW (QUOTE DYOFFSET) - 0) - (WINDOWPROP BMW (QUOTE ORIGINALBITMAP) - ORIGBM) - (WINDOWPROP BMW (QUOTE FINISHEDFLG) - NIL) - (WINDOWPROP BMW (QUOTE COLOR) - (SUB1 (EXPT 2 BPP))) - (WINDOWPROP BMW (QUOTE GRIDON) - T) (* ;  - "call reshapefn to initialize the display and values") - (EDITBMRESHAPEFN BMW NIL NIL NIL (NOT ORIGBM)) - (* ;  -  -"start a mouse process in case this process is the mouse process.") - (SPAWN.MOUSE) - (while (NOT (WINDOWPROP BMW (QUOTE FINISHEDFLG))) do (DISMISS 500)) - (* ; "remove the closefn before closing the window.") - (WINDOWPROP BMW (QUOTE CLOSEFN) - NIL) - (CLOSEW BMW) - (COND - ((NOT (EQ ORIGBPP BPP)) - (replace (BITMAP BITMAPBITSPERPIXEL) of BM with ORIGBPP) - (replace (BITMAP BITMAPWIDTH) of BM with ORIGWIDTH))) - (RETURN (COND - ((EQ T (WINDOWPROP BMW (QUOTE FINISHEDFLG))) - (* ;  -  -"editor exited via ok, stuff contents into original bitmap.") - (COND - ((EQ BMSPEC CursorBitMap) (* ; "editting happened in original, leave it alone.") - CursorBitMap) - ((REGIONP ORIGBM) (* ; "put it back into the screen.") - (BITBLT BM 0 0 (SCREENBITMAP) - (fetch (REGION LEFT) of ORIGBM) - (fetch (REGION BOTTOM) of ORIGBM) - (fetch (REGION WIDTH) of ORIGBM) - (fetch (REGION HEIGHT) of ORIGBM) - (QUOTE INPUT) - (QUOTE REPLACE)) - BM) - ((WINDOWP ORIGBM) (* ; "put it back into the window") - (BITBLT BM 0 0 ORIGBM (fetch (REGION LEFT) of CR) - (fetch (REGION BOTTOM) of CR) - (fetch (REGION WIDTH) of CR) - (fetch (REGION HEIGHT) of CR) - (QUOTE INPUT) - (QUOTE REPLACE)) - BM) - (ORIGBM (BITBLT BM 0 0 ORIGBM 0 0 WIDTH HEIGHT) - [COND - ((AND BMSPEC (LITATOM BMSPEC)) - (* ;  -  -"if spec was an atom without a bm value, set it. in the environment above EDITBM.") - (MARKASCHANGED BMSPEC (QUOTE VARS)) - (STKEVAL (QUOTE EDITBM) - (LIST (QUOTE SETQQ) - BMSPEC BM] - ORIGBM) - (T BM))) - (T (* ;  - "error exit, if cursor return it to original value.") - (COND - ((EQ BMSPEC CursorBitMap) - (BITBLT ORIGBM NIL NIL CursorBitMap))) - (ERROR!]) - -(EDITBMCLOSEFN - [LAMBDA (BMW) (* ; "Edited 27-Aug-87 21:26 by FS") - (* ;;  -  -"the close function for a bitmap edit window. For now do what a STOP would have done.") - (* ;;  -  -"FS: Assuming this window won't be reused, flush the temporary bm.") - (WINDOWPROP BMW (QUOTE TEMPBM) - NIL) - (WINDOWPROP BMW (QUOTE GRIDBM) - NIL) - (WINDOWPROP BMW (QUOTE FINISHEDFLG) - (QUOTE KILL]) - -(TILEAREA - [LAMBDA (LFT BTM WDTH HGHT SRCBM WIN) (* ; "Edited 27-Aug-87 21:20 by FS") - (* ;;  -  -"lays tiles out in an area of a window. This function only provided for backwards compatibility.") - (BLTPATTERN.REPLACEDISPLAY SRCBM 0 0 (BITMAPWIDTH SRCBM) - (BITMAPHEIGHT SRCBM) - WIN LFT BTM WDTH HGHT]) - -(EDITBMBUTTONFN - [LAMBDA (W) (* N.H.Briggs " 4-Sep-87 15:30") - (* ;; "inner function of bitmap editor.") - (DECLARE (GLOBALVARS \CURRENTCURSOR)) - (PROG (GRIDX0 GRIDY0 BITMAPWIDTH BITMAPHEIGHT NEWGRIDSIZE PAINTW ORIGBM GRIDSPEC GRIDINTERIOR - BM BITSWIDE BITSHIGH WREGION XOFFSET YOFFSET DXOFFSET DYOFFSET DISPLAYREGION - EXTENT BITSPERPIXEL CURSORBM) - (SETQ GRIDSPEC (WINDOWPROP W (QUOTE GRIDSPEC))) - (SETQ GRIDINTERIOR (WINDOWPROP W (QUOTE GRIDINTERIOR))) - (SETQ BM (WINDOWPROP W (QUOTE BM))) - (SETQ BITSWIDE (WINDOWPROP W (QUOTE BITSWIDE))) - (SETQ BITSHIGH (WINDOWPROP W (QUOTE BITSHIGH))) - (SETQ WREGION (WINDOWPROP W (QUOTE REGION))) - (SETQ XOFFSET (WINDOWPROP W (QUOTE XOFFSET))) - (SETQ YOFFSET (WINDOWPROP W (QUOTE YOFFSET))) - (SETQ DXOFFSET (WINDOWPROP W (QUOTE DXOFFSET))) - (SETQ DYOFFSET (WINDOWPROP W (QUOTE DYOFFSET))) - (SETQ DISPLAYREGION (WINDOWPROP W (QUOTE DISPLAYREGION))) - (SETQ EXTENT (WINDOWPROP W (QUOTE EXTENT))) - (SETQ GRIDX0 (fetch (REGION LEFT) of GRIDSPEC)) - (SETQ GRIDY0 (fetch (REGION BOTTOM) of GRIDSPEC)) - (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) - (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) - (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BM)) - (SETQ COLOR (WINDOWPROP W (QUOTE COLOR))) - (* ;;  - "mark the region of the bitmap that is being editted." -) - (COND - ((INSIDE? GRIDINTERIOR (LASTMOUSEX W) - (LASTMOUSEY W)) (* ;; "if cursor is inside, shade it.") - (\SHADEBITS BM GRIDSPEC GRIDINTERIOR W BITSWIDE BITSHIGH COLOR)) - ((INSIDE? DISPLAYREGION (LASTMOUSEX W) - (LASTMOUSEY W)) (* ;;  - "Run the menu foe re-windowing into the whole bitmap") - (SELECTQ - [MENU (COND - ((type? MENU EDITBMWINDOWMENU) - EDITBMWINDOWMENU) - ((SETQ EDITBMWINDOWMENU (create MENU - ITEMS _ - (QUOTE ((Move (QUOTE Move) - - "Selects a different part of the bitmap to edit."))) - CENTERFLG _ T] - (Move (* ;  - "move the editing window's location on the bitmap.") - (PROG (POS) - [SETQ POS (GETBOXPOSITION BITSWIDE BITSHIGH - [IPLUS 4 (fetch (REGION LEFT) - of WREGION) - (DIFFERENCE XOFFSET - (WINDOWPROP - W - (QUOTE DXOFFSET] - (IPLUS (WINDOWPROP W (QUOTE - BMDISPLAYBOTTOM)) - (DIFFERENCE YOFFSET - (WINDOWPROP - W - (QUOTE DYOFFSET)) - ) - 4 - (fetch (REGION BOTTOM) - of WREGION] - [WINDOWPROP W (QUOTE XOFFSET) - (SETQ XOFFSET - (IMIN (IDIFFERENCE BITMAPWIDTH BITSWIDE) - (IMAX [IPLUS - (WINDOWPROP W (QUOTE DXOFFSET)) - (DIFFERENCE - (fetch (POSITION XCOORD) - of POS) - (IPLUS 4 (fetch (REGION LEFT) - of WREGION] - 0] - [WINDOWPROP - W - (QUOTE YOFFSET) - (SETQ YOFFSET - (IMAX 0 (IMIN (DIFFERENCE BITMAPHEIGHT BITSHIGH) - (DIFFERENCE - (IPLUS (WINDOWPROP W (QUOTE DYOFFSET)) - (DIFFERENCE - (fetch (POSITION YCOORD) - of POS) - (IPLUS (fetch (REGION BOTTOM) - of WREGION) - 4))) - (WINDOWPROP W (QUOTE BMDISPLAYBOTTOM] - (replace (REGION LEFT) of EXTENT - with (IMINUS (QUOTIENT (TIMES XOFFSET (fetch (REGION WIDTH) - of EXTENT)) - BITMAPWIDTH))) - (replace (REGION BOTTOM) of EXTENT - with (IMINUS (QUOTIENT (TIMES YOFFSET (fetch (REGION HEIGHT) - of EXTENT)) - BITMAPHEIGHT))) - [COND - ([OR (ILESSP XOFFSET DXOFFSET) - (ILESSP YOFFSET DYOFFSET) - [IGREATERP (IPLUS XOFFSET BITSWIDE) - (IPLUS DXOFFSET (WINDOWPROP W (QUOTE - BMDISPLAYWIDTH] - (IGREATERP (IPLUS YOFFSET BITSHIGH) - (IPLUS DYOFFSET (WINDOWPROP W (QUOTE - BMDISPLAYHEIGHT] - (* ;;  -  -"Adjust the display region left lower corner so the selected region is near the center.") - [WINDOWPROP W (QUOTE DXOFFSET) - (SETQ DXOFFSET - (IMAX 0 (IMIN (DIFFERENCE (fetch - (BITMAP BITMAPWIDTH) - of BM) - (WINDOWPROP - W - (QUOTE - BMDISPLAYWIDTH))) - (DIFFERENCE - (IPLUS XOFFSET - (LRSH BITSWIDE 1)) - (LRSH (WINDOWPROP - W - (QUOTE BMDISPLAYWIDTH) - ) - 1] - (WINDOWPROP W (QUOTE DYOFFSET) - (SETQ DYOFFSET - (IMAX 0 (IMIN (DIFFERENCE (fetch - (BITMAP - BITMAPHEIGHT) - of BM) - (WINDOWPROP - W - (QUOTE - BMDISPLAYHEIGHT))) - (DIFFERENCE - (IPLUS YOFFSET - (LRSH BITSHIGH 1)) - (LRSH (WINDOWPROP - W - (QUOTE - BMDISPLAYHEIGHT)) - 1] - (* DSPFILL GRIDINTERIOR WHITESHADE  - (QUOTE REPLACE) W) - (UPDATE/BM/DISPLAY BM W) (* ;;  -  -"FS: More useless code: (COND ((WINDOWPROP W 'GRIDON) (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W)))") - (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T))) - NIL)) - ((LASTMOUSESTATE LEFT) - (UPDATE/BM/DISPLAY/SELECTED/REGION W) - (SETQ CURSORBM (BITMAPCREATE 16 16 (BITSPERPIXEL BM))) - (BITBLT BM NIL NIL CURSORBM) - [RESETFORM [CURSOR (CURSORCREATE CURSORBM (fetch (CURSOR CURSORHOTSPOTX) - of (CURSOR)) - (fetch (CURSOR CURSORHOTSPOTY) - of (CURSOR] - (until (MOUSESTATE (NOT LEFT] - (UPDATE/BM/DISPLAY/SELECTED/REGION W)) - (T (* ;;  -  -"the region being editted is inverted while the menu is active. Each command must make sure that it is recomplemented." -) - (UPDATE/BM/DISPLAY/SELECTED/REGION W) - (SELECTQ [MENU (COND - ((type? MENU EDITBMMENU) - EDITBMMENU) - (T (SETQ EDITBMMENU - (create MENU - ITEMS _ - [APPEND (COND - [(COLORDISPLAYP) - (QUOTE ((Color (QUOTE Color) - - "Choose color to set bits with"] - (T NIL)) - (QUOTE ((Paint (QUOTE Paint) - - "Calls the window PAINT command on the bitmap.") - (ShowAsTile (QUOTE - ShowAsTile) - - "tiles the upper part of the edit window with the bitmap.") - (Grid% On/Off (QUOTE - GridOnOff) - - "Grid On/Off Switch") - (GridSize_ (QUOTE - GridSize_) - - "Allows setting of the size of a bit in the edit area.") - (Reset (QUOTE Reset) - - "Sets the bitmap back to the state at the start of this edit session.") - (Clear (QUOTE Clear) - - "Sets the entire bitmap to 0") - (Cursor_ (QUOTE Cursor_) - - "Puts the bitmap into the cursor and exits the editor.") - (OK (QUOTE OK) - - "Leaves the edit session.") - (Abort (QUOTE Abort) - - "Restores the bitmap to its original values and leaves the editor."] - CENTERFLG _ T] - (OK (WINDOWPROP W (QUOTE FINISHEDFLG) - T)) - (Abort (WINDOWPROP W (QUOTE FINISHEDFLG) - (QUOTE KILL))) - [Reset (* ;;  -  -"allow the user to choose between everything or just visible part. This also give the user a chance to change their mind." -) - (COND - ((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH - "RESET how much?") - (VISIBLE [COND - [(SETQ ORIGBM (WINDOWPROP - W - (QUOTE ORIGINALBITMAP))) - (COND - ((REGIONP ORIGBM) - (BITBLT - (SCREENBITMAP) - (IPLUS XOFFSET - (fetch (REGION LEFT) - of ORIGBM)) - (IPLUS YOFFSET - (fetch (REGION BOTTOM) - of ORIGBM)) - BM XOFFSET YOFFSET BITSWIDE - BITSHIGH (QUOTE INPUT) - (QUOTE REPLACE))) - (T (BITBLT ORIGBM XOFFSET YOFFSET - BM XOFFSET YOFFSET - BITSWIDE BITSHIGH] - (T (BLTSHADE WHITESHADE BM XOFFSET - YOFFSET BITSWIDE BITSHIGH - (QUOTE REPLACE] - T) - (WHOLE [COND - [(SETQ ORIGBM (WINDOWPROP W - (QUOTE - - ORIGINALBITMAP))) - (COND - ((REGIONP ORIGBM) - (BITBLT (SCREENBITMAP) - (fetch (REGION LEFT) - of ORIGBM) - (fetch (REGION BOTTOM) - of ORIGBM) - BM)) - (T (BITBLT ORIGBM NIL NIL BM] - (T (BLTSHADE WHITESHADE BM NIL NIL NIL - NIL (QUOTE REPLACE] - T) - (PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W) - NIL)) - (\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE - BITSHIGH] - [Clear (* ;;  -  -"allow the user to choose between everything or just visible part. This also give the user a chance to change their mind." -) - (COND - ((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH - "CLEAR how much?") - (VISIBLE (BLTSHADE WHITESHADE BM XOFFSET YOFFSET - BITSWIDE BITSHIGH (QUOTE - REPLACE)) - T) - (WHOLE (\CLEARBM BM) - T) - (PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W) - NIL)) - (DSPFILL GRIDINTERIOR WHITESHADE (QUOTE REPLACE) - W) - (COND - ((WINDOWPROP W (QUOTE GRIDON)) - (GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT) - W))) - (UPDATE/BM/DISPLAY BM W] - (GridOnOff (COND - ((NOT (WINDOWPROP W (QUOTE GRIDON))) - (* ; "Turn Grid On") - (WINDOWPROP W (QUOTE GRIDON) - T) - (GRID GRIDSPEC BITSWIDE BITSHIGH (QUOTE POINT) - W) (* ;;  -  -"FS: The update here was unnecessary. (UPDATE/BM/DISPLAY BM W)") - NIL) - (T (* ; "Turn off grid") - (WINDOWPROP W (QUOTE GRIDON) - NIL) - - (* DSPFILL (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (ADD1 (fetch (REGION WIDTH) of GRIDINTERIOR)) HEIGHT _  - (ADD1 (fetch (REGION HEIGHT) of GRIDINTERIOR))) WHITESHADE (QUOTE REPLACE) W) - - - (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T) - (* ;;  -  -"FS: The update here was unnecessary. (UPDATE/BM/DISPLAY BM W)") - NIL))) - [GridSize_ (* ;  - "sets the grid square size and calls the reshapefn.") - (COND - ([SETQ NEWGRIDSIZE - (NUMBERP (MENU - (COND - ((TYPENAMEP GRIDSIZEMENU (QUOTE - MENU)) - GRIDSIZEMENU) - (T (SETQ GRIDSIZEMENU - (create MENU - ITEMS _ - (QUOTE (3 4 5 6 7 8 12 - 16 20 24 28 32) - ) - MENUROWS _ 4] - (WINDOWPROP W (QUOTE GRIDSQUARE) - NEWGRIDSIZE) - (EDITBMRESHAPEFN W] - (ShowAsTile (* ;  -  -"tiles the upper part of the window with the bitmap so the user can see what it would be as a shade.") - (UPDATE/SHADE/DISPLAY BM W)) - [Paint (* ;  -  -"call the window paint command on the contents of the bitmap.") - [SETQ PAINTW (CREATEW (create REGION - LEFT _ - (IQUOTIENT (DIFFERENCE - SCREENWIDTH - BITMAPWIDTH) - 2) - BOTTOM _ - (IQUOTIENT (DIFFERENCE - SCREENHEIGHT - BITMAPHEIGHT) - 2) - WIDTH _ (WIDTHIFWINDOW - BITMAPWIDTH) - HEIGHT _ (HEIGHTIFWINDOW - BITMAPHEIGHT NIL] - (OPENW PAINTW) - (BITBLT BM 0 0 PAINTW) - (PAINTW PAINTW) - (COND - ((MENU (create MENU - ITEMS _ (QUOTE ((YES T - "Will put the newly painted bits back in the bitmap being editted.") - (NO NIL - "Will discard the painted bits, not changing the bitmap being editted."))) - TITLE _ "Put change into bitmap?" - CENTERFLG _ T)) - (BITBLT PAINTW 0 0 BM) - (CLOSEW PAINTW) (* ; "set PAINTW so that space can be reclaimed") - (SETQ PAINTW) - (\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE - BITSHIGH] - (Cursor_ (* ;  -  -"Stuffs lower left part of image into the cursor and sets the hotspot.") - (READHOTSPOT BM GRIDSPEC GRIDINTERIOR W) - (WINDOWPROP W (QUOTE FINISHEDFLG) - T)) - (Color (WINDOWPROP W (QUOTE COLOR) - (OR (MENU (COLORMENU BITSPERPIXEL)) - COLOR))) - (UPDATE/BM/DISPLAY/SELECTED/REGION W]) - -(EDITBMSCROLLFN - [LAMBDA (W DX DY) (* ; "Edited 31-Aug-87 13:29 by FS") - (* ; "Do scrolling for the bitmap editor.") - (PROG (GRIDSPEC REG WHEIGHT WWIDTH (DXGRID 0) - (DYGRID 0) - EXTENT EXTENTWIDTH EXTENTHEIGHT GILEFT GIBOTTOM GIHEIGHT GWIDTH GHEIGHT - GRIDINTERIOR EBMXLIMIT EBMYLIMIT EBMXOFFSET EBMYOFFSET BM BITMAPWIDTH - BITMAPHEIGHT BITSWIDE BITSHIGH DXOFFSET DYOFFSET) - (SETQ GRIDSPEC (WINDOWPROP W (QUOTE GRIDSPEC))) - (SETQ REG (WINDOWPROP W (QUOTE REGION))) - (SETQ WHEIGHT (WINDOWPROP W (QUOTE HEIGHT))) - (SETQ WWIDTH (WINDOWPROP W (QUOTE WIDTH))) - (SETQ GRIDINTERIOR (WINDOWPROP W (QUOTE GRIDINTERIOR))) - (SETQ EBMXOFFSET (WINDOWPROP W (QUOTE XOFFSET))) - (SETQ EBMYOFFSET (WINDOWPROP W (QUOTE YOFFSET))) - (SETQ BM (WINDOWPROP W (QUOTE BM))) - (SETQ BITMAPWIDTH (fetch BITMAPWIDTH of BM)) - (SETQ BITMAPHEIGHT (fetch BITMAPHEIGHT of BM)) - (SETQ BITSWIDE (WINDOWPROP W (QUOTE BITSWIDE))) - (SETQ BITSHIGH (WINDOWPROP W (QUOTE BITSHIGH))) - (SETQ DXOFFSET (WINDOWPROP W (QUOTE DXOFFSET))) - (SETQ DYOFFSET (WINDOWPROP W (QUOTE DYOFFSET))) - (SETQ EBMXLIMIT (IPLUS EBMXOFFSET BITSWIDE)) - (SETQ EBMYLIMIT (IPLUS EBMYOFFSET BITSHIGH)) - (COND - (GRIDSPEC (SETQ GILEFT (fetch (REGION LEFT) of GRIDINTERIOR)) - (SETQ GIBOTTOM (fetch (REGION BOTTOM) of GRIDINTERIOR)) - (SETQ GIHEIGHT (fetch (REGION HEIGHT) of GRIDINTERIOR)) - (SETQ GWIDTH (fetch (REGION WIDTH) of GRIDSPEC)) - (SETQ GHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC)) - (SETQ EXTENT (WINDOWPROP W (QUOTE EXTENT))) - (SETQ EXTENTWIDTH (fetch (REGION WIDTH) of EXTENT)) - (SETQ EXTENTHEIGHT (fetch (REGION HEIGHT) of EXTENT)) - (* ; "Make a horizontal adjustment") - (COND - ((FLOATP DX) (* ; "Horizontal thumbing") - [WINDOWPROP W (QUOTE XOFFSET) - (SETQ EBMXOFFSET (FIX (TIMES (IDIFFERENCE - BITMAPWIDTH - BITSWIDE) - DX] - (replace (REGION LEFT) of EXTENT - with (IMINUS (QUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH) - BITMAPWIDTH))) - (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM SCREENWIDTH  - SCREENHEIGHT (QUOTE REPLACE) GRIDINTERIOR) - (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T)) - ((ILESSP DX 0) (* ; "moving to the left.") - (* ; "determine how many grid points to move.") - (SETQ DXGRID (IMIN (GRIDXCOORD (IMINUS DX) - GRIDSPEC) - (IDIFFERENCE BITMAPWIDTH EBMXLIMIT))) - (COND - ((NOT (IGREATERP DXGRID 0)) - (* ; "right edge is at the right margin") - (RETURN))) - (WINDOWPROP W (QUOTE XOFFSET) - (SETQ EBMXOFFSET (IPLUS EBMXOFFSET DXGRID))) - (* ; "update EXTENT bar") - (replace (REGION LEFT) of EXTENT - with (IMAX (IMINUS (QUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH) - BITMAPWIDTH)) - (IMINUS EXTENTWIDTH))) - (* ; "move image to the left.") - (BITBLT W (IPLUS GILEFT (TIMES DXGRID GWIDTH)) - GIBOTTOM W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT - (QUOTE INPUT) - (QUOTE REPLACE) - NIL GRIDINTERIOR) (* ; "clear the newly exposed area.") - (BLTSHADE WHITESHADE W (IPLUS GILEFT (TIMES (IDIFFERENCE BITSWIDE - DXGRID) - GWIDTH)) - GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE REPLACE) - GRIDINTERIOR) - (RESETGRID.NEW BM GRIDSPEC DXGRID BITSHIGH (IDIFFERENCE BITSWIDE - DXGRID) - 0 W)) - ((ILESSP 0 DX) (* ;  - "determine how many grid point to the left to move.") - (SETQ DXGRID (IMIN EBMXOFFSET (GRIDXCOORD DX GRIDSPEC))) - (COND - ((NOT (IGREATERP DXGRID 0)) - (* ; "left edge is at the left margin") - (RETURN))) - (WINDOWPROP W (QUOTE XOFFSET) - (SETQ EBMXOFFSET (IDIFFERENCE EBMXOFFSET DXGRID))) - (* ; "update REGION bar") - (replace (REGION LEFT) of EXTENT - with (IMIN (IMINUS (IQUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH) - BITMAPWIDTH)) - 0)) (* ; "move image to the right.") - (BITBLT W GILEFT GIBOTTOM W (IPLUS GILEFT (TIMES DXGRID GWIDTH)) - GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT) - (QUOTE REPLACE) - NIL GRIDINTERIOR) (* ; "clear the newly exposed area.") - (BLTSHADE WHITESHADE W GILEFT GIBOTTOM (TIMES DXGRID GWIDTH) - GIHEIGHT - (QUOTE REPLACE)) - (RESETGRID.NEW BM GRIDSPEC DXGRID BITSHIGH 0 0 W))) - (* ; "Make a vertical adjustment") - (COND - ((FLOATP DY) (* ; "Vertical Thumbing") - [WINDOWPROP W (QUOTE YOFFSET) - (SETQ EBMYOFFSET (FIX (TIMES (IDIFFERENCE - BITMAPHEIGHT - BITSHIGH) - (FDIFFERENCE 1.0 DY] - (* ; "set EXTENT bar") - (replace (REGION BOTTOM) of EXTENT - with (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT) - BITMAPHEIGHT))) - (* ; "Clear Window") - (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM SCREENWIDTH  - SCREENHEIGHT (QUOTE REPLACE) GRIDINTERIOR) - (* ; "Repaint the image using grid function") - (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T)) - ((ILESSP DY 0) (* ; "determine how many squares to move down.") - (SETQ DYGRID (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT) - of BM) - EBMYLIMIT) - (GRIDYCOORD (IMIN GIHEIGHT (IMINUS DY)) - GRIDSPEC))) - (COND - ((NOT (IGREATERP DYGRID 0)) - (* ; "top edge is at the top margin") - (RETURN))) - (WINDOWPROP W (QUOTE YOFFSET) - (SETQ EBMYOFFSET (IPLUS EBMYOFFSET DYGRID))) - (replace (REGION BOTTOM) of EXTENT - with (IMAX (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT) - BITMAPHEIGHT)) - (IMINUS EXTENTHEIGHT))) - (BITBLT W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID GHEIGHT)) - W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT (QUOTE INPUT) - (QUOTE REPLACE) - NIL GRIDINTERIOR) (* BLTSHADE WHITESHADE W GILEFT  - (IPLUS GIBOTTOM (ITIMES (IDIFFERENCE BITSHIGH DYGRID)  - GHEIGHT)) SCREENWIDTH SCREENHEIGHT  - (QUOTE REPLACE) GRIDINTERIOR) - (RESETGRID.NEW BM GRIDSPEC BITSWIDE DYGRID 0 (IDIFFERENCE BITSHIGH - DYGRID) - W T)) - ((ILESSP 0 DY) (* ;  - "moving up; determine how may grid squares to move.") - (SETQ DYGRID (IMIN EBMYOFFSET (GRIDYCOORD (IMIN GIHEIGHT DY) - GRIDSPEC))) - (COND - ((NOT (IGREATERP DYGRID 0)) - (* ; "bottom edge is at the bottom margin") - (RETURN))) - (WINDOWPROP W (QUOTE YOFFSET) - (SETQ EBMYOFFSET (IDIFFERENCE EBMYOFFSET DYGRID))) - (replace (REGION BOTTOM) of EXTENT - with (IMIN (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT) - BITMAPHEIGHT)) - 0)) - (BITBLT W GILEFT GIBOTTOM W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID - GHEIGHT)) - SCREENWIDTH SCREENHEIGHT (QUOTE INPUT) - (QUOTE REPLACE) - NIL GRIDINTERIOR) (* BLTSHADE WHITESHADE W GILEFT GIBOTTOM  - (fetch (REGION WIDTH) of GRIDINTERIOR)  - (ITIMES DYGRID GHEIGHT) (QUOTE REPLACE)) - (RESETGRID.NEW BM GRIDSPEC BITSWIDE DYGRID 0 0 W T))) - (* ;;  -  -"This call to GRID is unnecessary as the grid dots get filled in earlier.") - (* ;;  -  -"(COND ((WINDOWPROP W 'GRIDON) (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W)))") - [COND - ([OR (ILESSP EBMXOFFSET DXOFFSET) - (ILESSP EBMYOFFSET DYOFFSET) - [IGREATERP (IPLUS EBMXOFFSET BITSWIDE) - (IPLUS DXOFFSET (WINDOWPROP W (QUOTE - BMDISPLAYWIDTH] - (IGREATERP (IPLUS EBMYOFFSET BITSHIGH) - (IPLUS DYOFFSET (WINDOWPROP W (QUOTE - BMDISPLAYHEIGHT] - (* ;  -  -"Adjust the display region left lower corner so the selected region is near the center.") - [WINDOWPROP W (QUOTE DXOFFSET) - (SETQ DXOFFSET - (IMAX 0 (IMIN (IDIFFERENCE (fetch (BITMAP - BITMAPWIDTH) - of BM) - (WINDOWPROP - W - (QUOTE - BMDISPLAYWIDTH))) - (IDIFFERENCE - (IPLUS EBMXOFFSET (LRSH BITSWIDE - 1)) - (LRSH (WINDOWPROP W (QUOTE - - BMDISPLAYWIDTH)) - 1] - (WINDOWPROP W (QUOTE DYOFFSET) - (SETQ DYOFFSET - (IMAX 0 (IMIN (IDIFFERENCE (fetch (BITMAP - BITMAPHEIGHT) - of BM) - (WINDOWPROP - W - (QUOTE - BMDISPLAYHEIGHT))) - (IDIFFERENCE - (IPLUS EBMYOFFSET (LRSH BITSHIGH - 1)) - (LRSH (WINDOWPROP W (QUOTE - - BMDISPLAYHEIGHT)) - 1] - (UPDATE/BM/DISPLAY BM W]) - -(\EDITBM/PUTUP/DISPLAY - [LAMBDA (WINDOW BM GRIDSPEC GRIDINTERIOR BITSWIDE BITSHIGH) - (* ; "Edited 31-Aug-87 13:05 by FS") - (* initializes the display for the bitmap editor.) - (* DSPFILL GRIDINTERIOR WHITESHADE  - (QUOTE REPLACE) WINDOW) - (* COND ((WINDOWPROP WINDOW  - (QUOTE GRIDON)) (GRID GRIDSPEC BITSWIDE BITSHIGH  - (QUOTE POINT) WINDOW))) - (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 WINDOW T) - (UPDATE/BM/DISPLAY BM WINDOW]) - -(EDITBMRESHAPEFN - [LAMBDA (BMEDITWINDOW OLDIMAGE OLDREGION OLDSCREENREGION ZEROBMFLG) - (* ; "Edited 31-Aug-87 12:41 by FS") - (* ;;  -  -"allows the bitmap edit window to be reshaped to enlarge the editting area. This is also called to set up the image during initialization." -) - (PROG (BMWINTERIORWIDTH BMWINTERIORHEIGHT EDITAREABITWIDTH EDITAREABITHEIGHT GRIDSQUARE - GRIDINTERIOR BITMAPWIDTH BMDISPLAYWIDTH BMDISPLAYBOTTOM BMDISPLAYHEIGHT - BITMAPHEIGHT (BM (WINDOWPROP BMEDITWINDOW (QUOTE BM))) - MINCOMMANDAREAWIDTH EXTENTWIDTH EXTENTHEIGHT) - (SETQ MINCOMMANDAREAWIDTH 30) - (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) - (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) - (SETQ BMWINTERIORWIDTH (WINDOWPROP BMEDITWINDOW (QUOTE WIDTH))) - (* ;;  -  -"leave room at the top for the full size display area. But not more than half of the window.") - (SETQ BMWINTERIORHEIGHT (IMAX (IDIFFERENCE (WINDOWPROP BMEDITWINDOW (QUOTE - HEIGHT)) - (IPLUS BITMAPHEIGHT GRIDTHICKNESS)) - (IQUOTIENT (WINDOWPROP BMEDITWINDOW (QUOTE HEIGHT) - ) - 2))) - (* ;;  -  -"if the user hasn't set it, determine the grid size as the largest size which fits the interior but not larger than NORMALGRIDSQUARE nor smaller than MINGRIDSQUARE. If GRIDSQUARE was specified, reset it to NIL so that if reshaped it will be recalculated." -) - (SETQ GRIDSQUARE (OR (WINDOWPROP BMEDITWINDOW (QUOTE GRIDSQUARE) - NIL) - (IMAX (IMIN (IQUOTIENT BMWINTERIORWIDTH BITMAPWIDTH) - (IQUOTIENT BMWINTERIORHEIGHT BITMAPHEIGHT) - NORMALGRIDSQUARE) - MINGRIDSQUARE))) - (* ;  - "calculate how many bits will be displayed at once.") - (SETQ EDITAREABITWIDTH (IMIN (IQUOTIENT BMWINTERIORWIDTH GRIDSQUARE) - BITMAPWIDTH)) - (WINDOWPROP BMEDITWINDOW (QUOTE BITSWIDE) - EDITAREABITWIDTH) - (SETQ EDITAREABITHEIGHT (IMIN (IQUOTIENT BMWINTERIORHEIGHT GRIDSQUARE) - BITMAPHEIGHT)) - (* ;  -  -"calculate offset of display and command regions at the top of the window.") - (WINDOWPROP BMEDITWINDOW (QUOTE BITSHIGH) - EDITAREABITHEIGHT) - (SETQ BMDISPLAYBOTTOM (IPLUS (ITIMES GRIDSQUARE EDITAREABITHEIGHT) - GRIDTHICKNESS)) - (SETQ BMDISPLAYWIDTH (IMIN BITMAPWIDTH (IDIFFERENCE BMWINTERIORWIDTH - MINCOMMANDAREAWIDTH))) - (* ;;  -  -"put the offset --- the lower left coordinate --- in the same place unless the new shape allows more to be shown past the upper right corner." -) - (WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET) - (IMIN (WINDOWPROP BMEDITWINDOW (QUOTE XOFFSET)) - (IDIFFERENCE BITMAPWIDTH EDITAREABITWIDTH))) - (WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET) - (IMIN (WINDOWPROP BMEDITWINDOW (QUOTE YOFFSET)) - (IDIFFERENCE BITMAPHEIGHT EDITAREABITHEIGHT))) - (* ; "Center edit square") - (SETQ GRIDINTERIOR (create REGION - LEFT _ (IQUOTIENT (IDIFFERENCE BMWINTERIORWIDTH - (ITIMES - EDITAREABITWIDTH - GRIDSQUARE)) - 2) - BOTTOM _ (IQUOTIENT (IDIFFERENCE BMDISPLAYBOTTOM - (ITIMES - EDITAREABITHEIGHT - GRIDSQUARE)) - 2) - WIDTH _ (ITIMES EDITAREABITWIDTH GRIDSQUARE) - HEIGHT _ (ITIMES EDITAREABITHEIGHT GRIDSQUARE))) - (WINDOWPROP BMEDITWINDOW (QUOTE GRIDINTERIOR) - GRIDINTERIOR) - (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYBOTTOM) - BMDISPLAYBOTTOM) - (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYWIDTH) - BMDISPLAYWIDTH) - (WINDOWPROP BMEDITWINDOW (QUOTE BMDISPLAYHEIGHT) - (SETQ BMDISPLAYHEIGHT (IDIFFERENCE (WINDOWPROP BMEDITWINDOW - (QUOTE HEIGHT)) - BMDISPLAYBOTTOM))) - (WINDOWPROP BMEDITWINDOW (QUOTE DISPLAYREGION) - (create REGION - LEFT _ 0 - BOTTOM _ BMDISPLAYBOTTOM - WIDTH _ BMDISPLAYWIDTH - HEIGHT _ BMDISPLAYHEIGHT)) - (WINDOWPROP BMEDITWINDOW (QUOTE GRIDSPEC) - (create REGION - LEFT _ (fetch (REGION LEFT) of GRIDINTERIOR) - BOTTOM _ (fetch (REGION BOTTOM) of GRIDINTERIOR) - WIDTH _ GRIDSQUARE - HEIGHT _ GRIDSQUARE)) - (SETQ EXTENTHEIGHT (QUOTIENT (TIMES BITMAPHEIGHT (WINDOWPROP BMEDITWINDOW - (QUOTE HEIGHT))) - EDITAREABITHEIGHT)) - [SETQ EXTENTWIDTH (IDIFFERENCE (QUOTIENT (TIMES BITMAPWIDTH BMWINTERIORWIDTH) - EDITAREABITWIDTH) - (WINDOWPROP BMEDITWINDOW (QUOTE BORDER] - (WINDOWPROP BMEDITWINDOW (QUOTE EXTENT) - (CREATEREGION (MINUS (QUOTIENT (TIMES (WINDOWPROP BMEDITWINDOW - (QUOTE - XOFFSET)) - EXTENTWIDTH) - BITMAPWIDTH)) - (MINUS (QUOTIENT (TIMES (WINDOWPROP BMEDITWINDOW - (QUOTE - YOFFSET)) - EXTENTHEIGHT) - BITMAPHEIGHT)) - EXTENTWIDTH EXTENTHEIGHT)) - (EDITBMREPAINTFN BMEDITWINDOW NIL ZEROBMFLG]) - -(EDITBMREPAINTFN.NEW - [LAMBDA (WIN REGION ZEROBM) (* ; "Edited 27-Aug-87 22:02 by FS") - (* ;;  -  -"Stub in case I missed a call to this guy. Take out later.") - (EDITBMREPAINTFN WIN REGION ZEROBM]) - -(EDITBMREPAINTFN - [LAMBDA (WIN REGION ZEROBM) (* N.H.Briggs " 4-Sep-87 15:07") - (* ;;  -  -"redisplays a bitmap editting window If ZEROBM is non-NIL, it doesn't bother to display the bits.") - (PROG [(GRIDSPEC (WINDOWPROP WIN (QUOTE GRIDSPEC))) - (EDITAREABITWIDTH (WINDOWPROP WIN (QUOTE BITSWIDE))) - (EDITAREABITHEIGHT (WINDOWPROP WIN (QUOTE BITSHIGH))) - (BM (WINDOWPROP WIN (QUOTE BM] - (CLEARW WIN) (* ;  -  -"gray the area above the edit grid that is not bitmap display area.") - (BLTSHADE NOTINUSEGRAY WIN (PLUS (WINDOWPROP WIN (QUOTE BMDISPLAYWIDTH)) - GRIDTHICKNESS) - (WINDOWPROP WIN (QUOTE BMDISPLAYBOTTOM))) - (* ;; "put in the display of the full sized bitmap.") - (UPDATE/BM/DISPLAY BM WIN) (* ;;  -  -"FS: Now that RESETGRID displays the grid, don't need the call to GRID.") - (* ;;  -  -"(COND ((WINDOWPROP WIN 'GRIDON) (GRID GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 'POINT WIN)))") - (if ZEROBM - then (if (WINDOWPROP WIN (QUOTE GRIDON)) - then (GRID GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT (QUOTE POINT) - WIN)) - else (RESETGRID.NEW BM GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 0 0 WIN]) - -(RESETGRID.NEW - [LAMBDA (BM GRIDSPEC WIDTH HEIGHT ORIGX ORIGY WINDOW DOCLEARFLG) - (* N.H.Briggs " 4-Sep-87 15:08") - (* ;;  -  -"Copies the contents of a bitmap into the edit display grid of window. ORIGX & Y are used to offest into both bitmap and destination window." -) - (LET (XOFFSET YOFFSET MAXX MAXY SHADE XSCALE YSCALE TEMPBM) - (SETQ XSCALE (fetch (REGION WIDTH) of GRIDSPEC)) - (SETQ YSCALE (fetch (REGION HEIGHT) of GRIDSPEC)) - (if (NULL ORIGX) - then (SETQ ORIGX 0)) - (if (NULL ORIGY) - then (SETQ ORIGY 0)) - (SETQ XOFFSET (WINDOWPROP WINDOW (QUOTE XOFFSET))) - (SETQ YOFFSET (WINDOWPROP WINDOW (QUOTE YOFFSET))) - (SETQ MAXX (IPLUS ORIGX WIDTH -1)) - (SETQ MAXY (IPLUS ORIGY HEIGHT -1)) (* ;; "Build & cache a temporary bitmap.") - (SETQ TEMPBM (WINDOWPROP WINDOW (QUOTE TEMPBM))) - (if (NOT TEMPBM) - then (SETQ TEMPBM (BITMAPCREATE (BITMAPWIDTH WINDOW) - (BITMAPHEIGHT BM))) - (WINDOWPROP WINDOW (QUOTE TEMPBM) - TEMPBM)) (* ;;  -  -"Use SCALEBM. Bitmap destination must be empty (white).") - (if DOCLEARFLG - then (BLTSHADE WHITESHADE WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC) - (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) - (TIMES WIDTH XSCALE) - (TIMES HEIGHT YSCALE) - (QUOTE REPLACE))) - (SCALEBM BM (PLUS ORIGX XOFFSET) - (PLUS ORIGY YOFFSET) - WINDOW - (LEFTOFGRIDCOORD ORIGX GRIDSPEC) - (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) - WIDTH HEIGHT XSCALE YSCALE TEMPBM) (* ;; "Shade the pixels correctly.") - (BLTSHADE DARKBITSHADE WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC) - (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) - (TIMES WIDTH XSCALE) - (TIMES HEIGHT YSCALE) - (QUOTE ERASE)) (* ;; "Add grid") - (if (WINDOWPROP WINDOW (QUOTE GRIDON)) - then (if (OR (NEQ ORIGX (CAR GRIDSPEC)) - (NEQ ORIGY (CADR GRIDSPEC))) - then (SETQ GRIDSPEC (COPYALL GRIDSPEC)) - (replace (REGION LEFT) of GRIDSPEC with (LEFTOFGRIDCOORD - ORIGX GRIDSPEC)) - (replace (REGION BOTTOM) of GRIDSPEC with (BOTTOMOFGRIDCOORD - ORIGY GRIDSPEC))) - (GRID GRIDSPEC WIDTH HEIGHT (QUOTE POINT) - WINDOW]) -) -(DEFINEQ - -(SCALEBM - [LAMBDA (SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEWIDTH SRCEHEIGHT XSCALE YSCALE TEMPBM) - (* N.H.Briggs " 4-Sep-87 15:48") - (* ;;  -  -"Magnify a bitmap as per EDITBM. Use smearing algorithm.") - (LET ((DESTWIDTH (BITMAPWIDTH DESTBM)) - (DESTHEIGHT (if (WINDOWP DESTBM) - then (WINDOWPROP DESTBM (QUOTE HEIGHT)) - else (BITMAPHEIGHT DESTBM))) - XSTEPS YSTEPS POWER) (* ;; "Check parameters, apply defaults") - (if (NUMBERP SRCEWIDTH) - else (SETQ SRCEWIDTH (BITMAPWIDTH SRCEBM))) - (if (NUMBERP SRCEHEIGHT) - else (SETQ SRCEHEIGHT (BITMAPHEIGHT SRCEBM))) - (* ;;  - "Save effort by considering min of srce and dest.") - (SETQ DESTWIDTH (MIN DESTWIDTH (TIMES SRCEWIDTH XSCALE))) - (SETQ DESTHEIGHT (MIN DESTHEIGHT (TIMES SRCEHEIGHT YSCALE))) - (SETQ SRCEWIDTH (MIN SRCEWIDTH (IQUOTIENT DESTWIDTH XSCALE))) - (SETQ SRCEHEIGHT (MIN SRCEHEIGHT (IQUOTIENT DESTHEIGHT YSCALE))) - (if TEMPBM - then (BLTSHADE WHITESHADE TEMPBM) - else (SETQ TEMPBM (BITMAPCREATE DESTWIDTH SRCEHEIGHT))) - (* ;;  -  -"CALL EXPANDBM twice, once for each direction, because we have a spare bitmap which makes it run faster than a single call to EXPANDBM would (I think)." -) (* ;; "") - (* ;; "Do X Direction Smearing.") - (* ;; "============") - (EXPANDBM SRCEBM SRCEX SRCEY SRCEWIDTH SRCEHEIGHT TEMPBM 0 0 DESTWIDTH SRCEHEIGHT XSCALE 1 - XSCALE 1) (* ;; "") - (* ;; "Do Y Direction Smearing.") - (* ;; "============") - (EXPANDBM TEMPBM 0 0 DESTWIDTH SRCEHEIGHT DESTBM DESTX DESTY DESTWIDTH DESTHEIGHT 1 YSCALE - 1 YSCALE) (* ;; "") - (* ;;  - "Return the temporary bitmap for recycling purposes.") - TEMPBM]) - -(BLTPATTERN - [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH OPER TEMPBM) (* N.H.Briggs " 4-Sep-87 15:10") - (* ;;  -  -"Fills region of Destination with tiles of Source region, using operation. If Temporary bitmap is provided, use it for optimal performance." -) - (PROG (W H RX RW) - (if (NULL SW) - then (SETQ SW (BITMAPWIDTH SRCE))) - (if (NULL SH) - then (SETQ SH (BITMAPHEIGHT SRCE))) (* ;; "") - (* ;; "Fill columns ") - (* ;; "") - [if TEMPBM - then (* ;;  -  -"Temporary bitmap is only useful if larger than source.") - (if [AND (GREATERP (BITMAPWIDTH TEMPBM) - (MIN SW (BITMAPWIDTH SRCE))) - (GREATERP (BITMAPHEIGHT TEMPBM) - (MIN SH (BITMAPHEIGHT SRCE] - then (BLTPATTERN.REPLACEDISPLAY SRCE SX SY SW SH TEMPBM 0 0 - (BITMAPWIDTH TEMPBM) - (BITMAPHEIGHT TEMPBM)) - (* ;;  -  -"Allow code to fall through using TEMPBM as source area.") - (SETQ SRCE TEMPBM) - (SETQ SX 0) - (SETQ SY 0) - (SETQ SW (ITIMES SW (IQUOTIENT (BITMAPWIDTH TEMPBM) - SW))) - (SETQ SH (ITIMES SH (IQUOTIENT (BITMAPHEIGHT TEMPBM) - SH] - (if (AND (EQ OPER (QUOTE REPLACE)) - (OR (BITMAPP DEST) - (WINDOWP DEST))) - then (BLTPATTERN.REPLACEDISPLAY SRCE SX SY SW SH DEST DX DY DW DH) - (RETURN)) (* ;;  -  -"Even if operation is REPLACE, don't know if destination is inexpensively readable (e.g. Interpress stream. SO, this is the general case here." -) - (while (GREATERP DH 0) - do (SETQ H (MIN SH DH)) (* ;; "") - (SETQ RW DW) - (SETQ RX DX) (* ;; "") - (* ;; "Fill rows") - (* ;; "") - (while (GREATERP RW 0) - do (SETQ W (MIN SW RW)) - (BITBLT SRCE SX SY DEST RX DY W H NIL OPER) - (SETQ RW (DIFFERENCE RW W)) - (SETQ RX (PLUS RX W))) (* ;; "") - (SETQ DH (DIFFERENCE DH H)) - (SETQ DY (PLUS DY H]) - -(BLTPATTERN.REPLACEDISPLAY - [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH) (* N.H.Briggs " 4-Sep-87 15:11") - (* ;;  -  -"This routine only replaces the destination with the source, and assumes the destination itself can be easily read from and blt'ed to." -) (* ;;  -  -"Put initial bitmap into destination. Source should not be within destination area, otherwise it will be overwritten." -) - (LET (RX RY RW RH W H) (* ; "R's are remaining area.") - (SETQ W (MIN SW DW)) - (SETQ H (MIN SH DH)) - (BLTSHADE WHITESHADE DEST DX DY W H (QUOTE REPLACE)) - (BITBLT SRCE SX SY DEST DX DY W H NIL (QUOTE REPLACE)) - (SETQ RX (PLUS DX W)) - (SETQ RW (DIFFERENCE DW W)) (* ;; "Now power up until width is full.") - (while (GREATERP RW 0) - do (SETQ W (MIN SW RW)) - (BITBLT DEST DX DY DEST RX DY W H NIL (QUOTE REPLACE)) - (SETQ RW (DIFFERENCE RW W)) (* ; "Reduce remaining width") - (SETQ RX (PLUS RX W)) (* ; "Set next starting position") - (SETQ SW (PLUS SW SW)) (* ; "Can now use 2x area.")) - (* ;; "") - (SETQ RY (PLUS DY H)) - (SETQ RH (DIFFERENCE DH H)) - (SETQ SH H) - (SETQ W DW) (* ;; "Now power up until height is full.") - (while (GREATERP RH 0) - do (SETQ H (MIN SH RH)) - (BITBLT DEST DX DY DEST DX RY W H NIL (QUOTE REPLACE)) - (SETQ RH (DIFFERENCE RH H)) (* ; "Reduce remaining width") - (SETQ RY (PLUS RY H)) (* ; "Set next starting position") - (SETQ SH (PLUS SH SH)) (* ; "Can now use 2x area.")]) -) -(DEFINEQ - -(EXPANDBITMAP - [LAMBDA (BITMAP WIDTHFACTOR HEIGHTFACTOR) (* N.H.Briggs "16-Nov-87 17:10") - (* ;;  -  -"Returns a new bitmap which is WidthFactor and HeightFactor bigger.") - (* ;;  -  -"FS: This slow piece of code has been replaced with a much faster, general one, EXPAND.l ") - (LET (WIDTH HEIGHT BITSPERPIXEL NEWWIDTH NEWHEIGHT NEWX NEWY NEWBITMAP) - (OR WIDTHFACTOR (SETQ WIDTHFACTOR 1)) - (OR HEIGHTFACTOR (SETQ HEIGHTFACTOR 1)) - (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) - (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) - (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) - (SETQ NEWWIDTH (ITIMES WIDTHFACTOR WIDTH)) - (SETQ NEWHEIGHT (ITIMES HEIGHTFACTOR HEIGHT)) - (SETQ NEWBITMAP (BITMAPCREATE NEWWIDTH NEWHEIGHT BITSPERPIXEL)) - (* ;; "OLD code commented out here.") - - (* LET NIL (* Expand in x-direction. *) (SETQ NEWX 0) (for X from 0 to (SUB1 WIDTH) do (for I from 1 to WIDTHFACTOR - do (BITBLT BITMAP X 0 NEWBITMAP NEWX 0 1 HEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (add NEWX 1)))  - (* Expand in y-direction. *) (SETQ NEWY (SUB1 NEWHEIGHT)) (for Y from (SUB1 HEIGHT) to 0 by -1 do  - (for I from 1 to HEIGHTFACTOR do (BITBLT NEWBITMAP 0 Y NEWBITMAP 0 NEWY NEWWIDTH 1 (QUOTE INPUT)  - (QUOTE REPLACE)) (add NEWY -1)))) - - - (EXPANDBM BITMAP 0 0 WIDTH HEIGHT NEWBITMAP 0 0 NEWWIDTH NEWHEIGHT WIDTHFACTOR - HEIGHTFACTOR WIDTHFACTOR HEIGHTFACTOR) - NEWBITMAP]) - -(EXPANDBM - [LAMBDA (SRCEBM SRCEX SRCEY SRCEW SRCEH DESTBM DESTX DESTY DESTW DESTH XSCALE YSCALE XSPACE YSPACE) - (* N.H.Briggs " 4-Sep-87 15:18") - (* ;;  -  -"Expands a region of SrceBM by X&Y scale into a region of DestBM, spaced Xspace by YSpace apart (space must be larger than scale). SrceBM cannot be the same bitmap as DestBM. The entire region inside DestBM is cleared." -) - (PROG (XSTEPS YSTEPS POWER) (* ;; "Check parameters, apply defaults") - (if (NUMBERP SRCEX) - else (SETQ SRCEX 0)) - (if (NUMBERP SRCEY) - else (SETQ SRCEY 0)) - (if (NUMBERP SRCEW) - else (SETQ SRCEW (BITMAPWIDTH SRCEBM))) - (if (NUMBERP SRCEH) - else (SETQ SRCEH (BITMAPHEIGHT SRCEBM))) - (if (NUMBERP DESTX) - else (SETQ SRCEX 0)) - (if (NUMBERP DESTY) - else (SETQ SRCEY 0)) (* ;;  - "Save effort by considering min of srce and dest.") - [SETQ DESTW (IMIN DESTW (TIMES SRCEW (IMAX XSCALE XSPACE] - [SETQ DESTH (IMIN DESTH (TIMES SRCEH (IMAX YSCALE YSPACE] - [SETQ SRCEW (IMIN SRCEW (PLUS 1 (IQUOTIENT DESTW (IMAX XSCALE XSPACE] - [SETQ SRCEH (IMIN SRCEH (PLUS 1 (IQUOTIENT DESTH (IMAX YSCALE YSPACE] - (BLTSHADE WHITESHADE DESTBM DESTX DESTY DESTW DESTH) - (if (AND (EQP XSPACE 1) - (EQP YSPACE 1)) - then (BITBLT SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEW SRCEH) - (RETURN DESTBM)) (* ;; "") - (* ;; "Do X Direction Smearing.") - (* ;; "============") - (* ;;  -  -"Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") - (if (EQP XSPACE 1) - then (* ;;  -  -"Don't fill destination, instead use srce in YSmear loop.") - (* ;;  -  -"(BITBLT SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEW SRCEH)") - - else (* ;;  -  -"Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") - (for I from (SUB1 SRCEW) to 0 by -1 - do (BITBLT SRCEBM (PLUS SRCEX I) - SRCEY DESTBM (PLUS DESTX (TIMES I XSPACE)) - DESTY 1 SRCEH))) (* ;;  -  -"Now smear by scalefactor. Each step smears out a power of two. LSH is in ucode.") - [if (EQP XSCALE 1) - else (SETQ POWER 1) - (while (ILEQ POWER (LSH XSCALE -1)) - do (* ;;  -  -"In the X direction, only need to blt SRCEH bits high, and must shorten W to remain within DESTW") - (BITBLT DESTBM DESTX DESTY DESTBM (PLUS DESTX POWER) - DESTY - (DIFFERENCE DESTW POWER) - SRCEH NIL (QUOTE PAINT)) - (SETQ POWER (PLUS POWER POWER))) - (* ;; "Clean up for non power of two.") - (if (ZEROP (DIFFERENCE XSCALE POWER)) - else (BITBLT DESTBM DESTX DESTY DESTBM (PLUS DESTX (DIFFERENCE XSCALE - POWER)) - DESTY - (DIFFERENCE DESTW (DIFFERENCE XSCALE POWER)) - SRCEH NIL (QUOTE PAINT] - (* ;; "") - (* ;; "Do Y Direction Smearing.") - (* ;; "============") - (* ;;  -  -"Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") - [if (EQP YSPACE 1) - else (if (EQP XSPACE 1) - then (* ;;  -  -"Didn't need to paint in destination, so can avoid second loop by blting from SRCBM instead of DESTBM.") - (for J from (SUB1 SRCEH) to 0 by -1 - do (BITBLT SRCEBM SRCEX (PLUS SRCEY J) - DESTBM DESTX (PLUS DESTY (TIMES J YSPACE)) - DESTW 1)) - else (for J from (SUB1 SRCEH) to 0 by -1 - do (BITBLT DESTBM DESTX (PLUS DESTY J) - DESTBM DESTX (PLUS DESTY (TIMES J YSPACE)) - DESTW 1)) (* ;;  -  -"Since we reused DESTBM, parts of the dest have bits in them but shouldn't. So, clear them.") - (for J from 0 to SRCEH by YSPACE - do (BLTSHADE WHITESHADE DESTBM DESTX (PLUS DESTY J 1) - DESTW - (SUB1 YSPACE] - (* ;;  -  -"Now smear correctly. Each step smears out a power of two. LSH is in ucode.") - [if (EQP YSCALE 1) - else (SETQ POWER 1) - (while (ILEQ POWER (LSH YSCALE -1)) - do (BITBLT DESTBM DESTX DESTY DESTBM DESTX (PLUS DESTY POWER) - DESTW - (DIFFERENCE DESTH POWER) - NIL - (QUOTE PAINT)) - (SETQ POWER (PLUS POWER POWER))) - (* ;; "Clean up for non power of two.") - (if (ZEROP (DIFFERENCE YSCALE POWER)) - else (BITBLT DESTBM DESTX DESTY DESTBM DESTX (PLUS DESTY - (DIFFERENCE YSCALE - POWER)) - DESTW DESTH NIL (QUOTE PAINT] - (* ;; "") - (* ;;  - "Return the temporary bitmap for recycling purposes.") - DESTBM]) -) -(PUTPROPS FASTEDITBM COPYRIGHT ("Xerox Corporation" 1987)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (1041 4849 (GRID 1051 . 4847)) (4850 52348 (EDITBM 4860 . 13712) (EDITBMCLOSEFN 13714 . -14345) (TILEAREA 14347 . 14779) (EDITBMBUTTONFN 14781 . 29731) (EDITBMSCROLLFN 29733 . 40923) ( -\EDITBM/PUTUP/DISPLAY 40925 . 41674) (EDITBMRESHAPEFN 41676 . 47657) (EDITBMREPAINTFN.NEW 47659 . -47983) (EDITBMREPAINTFN 47985 . 49598) (RESETGRID.NEW 49600 . 52346)) (52349 59854 (SCALEBM 52359 . -54995) (BLTPATTERN 54997 . 57709) (BLTPATTERN.REPLACEDISPLAY 57711 . 59852)) (59855 68063 ( -EXPANDBITMAP 59865 . 61694) (EXPANDBM 61696 . 68061))))) -STOP diff --git a/obsolete/lispusers/FONTDECLS b/obsolete/lispusers/FONTDECLS deleted file mode 100644 index eeaf3c9e..00000000 --- a/obsolete/lispusers/FONTDECLS +++ /dev/null @@ -1,207 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 10) -(FILECREATED "27-Sep-87 16:13:36" {DSK}FONTDECLS.;7 10151 - - changes to%: (VARS FONTDECLSCOMS) - - previous date%: "25-Sep-87 22:24:36" {DSK}FONTDECLS.;6) - - -(PRETTYCOMPRINT FONTDECLSCOMS) - -(RPAQQ FONTDECLSCOMS ((PROP MAKEFILE-ENVIRONMENT FONTDECLS) - (RECORDS FONTDESCRIPTOR CHARSETINFO) - (CONSTANTS WORDSPERCELL \MAXCHARSET \MAXTHINCHAR) - (MACROS FOLDHI UNFOLD \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR - \FGETIMAGEWIDTH \FGETOFFSET \FGETWIDTH \FSETIMAGEWIDTH \FSETOFFSET - \FSETWIDTH \GETCHARSETINFO \SETCHARSETINFO))) - -(PUTPROPS FONTDECLS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10)) -(DECLARE%: EVAL@COMPILE - -(DATATYPE FONTDESCRIPTOR ((FONTDEVICE POINTER) - (\SFObsolete1 POINTER) (* WAS CHARACTERBITMAP) - (* Bitmap containing the character - images, indexed by \SFOffsets) - (FONTFAMILY POINTER) - (FONTSIZE POINTER) - (FONTFACE POINTER) - (\SFObsolete2 POINTER) (* Was \SFWidths) - - (* The advance-width of each character, an array indexed by charcode. - Usually the same as the imagewidth, but can differ for accents, kerns kerns. - This is what should be used for stringwidth calculations.) - - (\SFObsolete3 POINTER) (* WAS \SFOffsets) - - (* Offset of each character into the image bitmap; - X value of left edge) - - (\SFObsolete4 POINTER) (* Was \SFWidthsY) - (\SFObsolete5 WORD) (* WAS FIRSTCHAR) - - (* Charcode of the first character that exists in the font) - - (\SFObsolete6 WORD) (* WAS LASTCHAR) - - (* Charcode of the last character that exists in the font) - - (\SFAscent WORD) - (\SFDescent WORD) - (\SFHeight WORD) - (ROTATION WORD) - (FBBOX SIGNEDWORD) - (FBBOY SIGNEDWORD) - (FBBDX SIGNEDWORD) - (FBBDY SIGNEDWORD) - (\SFFACECODE BITS 8) - (\SFLKerns POINTER) - (\SFRWidths POINTER) - (FONTDEVICESPEC POINTER) - - (* Holds the spec by which the font is known to the printing device, if - coercion has been done) - - (OTHERDEVICEFONTPROPS POINTER) (* For individual devices to hang - special information) - (FONTSCALE POINTER) - (FONTAVGCHARWIDTH WORD) - - (* Set in FONTCREATE, used to fix up the linelength when DSPFONT is called) - - (FONTIMAGEWIDTHS POINTER) - - (* This is the image width, as opposed to the advanced width; - initial hack for accents, kerning. Fields is referenced by FONTCREATE.) - - (FONTCHARSETVECTOR POINTER) - - (* A 256-pointer block, with one pointer per "character set" --each group of - 256 character codes. Each pointer is either NIL if there's no info for that - charset, or is a CHARSETINFO, containing widths, char bitmap, etc for the - characters in that charset.) - - (FONTEXTRAFIELD2 POINTER)) - FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR)) - -(DATATYPE CHARSETINFO (WIDTHS - - (* The advance-width of each character, an array indexed by charcode. - Usually the same as the imagewidth, but can differ for accents, kerns kerns. - This is what should be used for stringwidth calculations.) - - OFFSETS - - (* Offset of each character into the image bitmap; - X value of left edge) - - IMAGEWIDTHS - - (* imagewidths is not automagically allocated since it is not always needed) - - CHARSETBITMAP (* Bitmap containing the character - images, indexed by OFFSETS) - YWIDTHS - (CHARSETASCENT WORD) (* Max ascent for all characters in - this CHARSET) - (CHARSETDESCENT WORD) (* Max descent for all characters in - this CHARSET) - ) - WIDTHS _ (\CREATECSINFOELEMENT) - OFFSETS _ (\CREATECSINFOELEMENT)) -) -(/DECLAREDATATYPE 'FONTDESCRIPTOR - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD - WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD (BITS 8) - POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER) - '((FONTDESCRIPTOR 0 POINTER) - (FONTDESCRIPTOR 2 POINTER) - (FONTDESCRIPTOR 4 POINTER) - (FONTDESCRIPTOR 6 POINTER) - (FONTDESCRIPTOR 8 POINTER) - (FONTDESCRIPTOR 10 POINTER) - (FONTDESCRIPTOR 12 POINTER) - (FONTDESCRIPTOR 14 POINTER) - (FONTDESCRIPTOR 16 (BITS . 15)) - (FONTDESCRIPTOR 17 (BITS . 15)) - (FONTDESCRIPTOR 18 (BITS . 15)) - (FONTDESCRIPTOR 19 (BITS . 15)) - (FONTDESCRIPTOR 20 (BITS . 15)) - (FONTDESCRIPTOR 21 (BITS . 15)) - (FONTDESCRIPTOR 22 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 23 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 24 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 25 (SIGNEDBITS . 15)) - (FONTDESCRIPTOR 14 (BITS . 7)) - (FONTDESCRIPTOR 26 POINTER) - (FONTDESCRIPTOR 28 POINTER) - (FONTDESCRIPTOR 30 POINTER) - (FONTDESCRIPTOR 32 POINTER) - (FONTDESCRIPTOR 34 POINTER) - (FONTDESCRIPTOR 36 (BITS . 15)) - (FONTDESCRIPTOR 38 POINTER) - (FONTDESCRIPTOR 40 POINTER) - (FONTDESCRIPTOR 42 POINTER)) - '44) -(/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD) - '((CHARSETINFO 0 POINTER) - (CHARSETINFO 2 POINTER) - (CHARSETINFO 4 POINTER) - (CHARSETINFO 6 POINTER) - (CHARSETINFO 8 POINTER) - (CHARSETINFO 10 (BITS . 15)) - (CHARSETINFO 11 (BITS . 15))) - '12) -(DECLARE%: EVAL@COMPILE - -(RPAQQ WORDSPERCELL 2) - -(RPAQQ \MAXCHARSET 255) - -(RPAQQ \MAXTHINCHAR 255) - -(CONSTANTS WORDSPERCELL \MAXCHARSET \MAXTHINCHAR) -) -(DECLARE%: EVAL@COMPILE -[PUTPROPS FOLDHI MACRO (X (PROG [(FORM (CAR X)) - (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X] - (OR (AND DIVISOR (POWEROFTWOP DIVISOR)) - (\ILLEGAL.ARG (CADR X))) - (RETURN (LIST 'LRSH (LIST 'IPLUS FORM (SUB1 DIVISOR)) - (SUB1 (INTEGERLENGTH DIVISOR] -[PUTPROPS UNFOLD MACRO (X (PROG [(FORM (CAR X)) - (DIVISOR (CAR (CONSTANTEXPRESSIONP (CADR X] - (OR (AND DIVISOR (POWEROFTWOP DIVISOR)) - (\ILLEGAL.ARG (CADR X))) - (RETURN (LIST 'LLSH FORM (SUB1 (INTEGERLENGTH DIVISOR] -[PUTPROPS \CREATECSINFOELEMENT MACRO (NIL (\ALLOCBLOCK (FOLDHI (IPLUS \MAXTHINCHAR 3) - WORDSPERCELL] -(PUTPROPS \CREATEFONTCHARSETVECTOR MACRO (NIL (* Allocates a block for the character set records) - (\ALLOCBLOCK (ADD1 \MAXCHARSET) - T))) -(PUTPROPS \FGETIMAGEWIDTH MACRO ((IMAGEWIDTHSBLOCK CHAR8CODE) - (\GETBASE IMAGEWIDTHSBLOCK CHAR8CODE))) -(PUTPROPS \FGETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE) - (\GETBASE OFFSETSBLOCK CHAR8CODE))) -(PUTPROPS \FGETWIDTH DMACRO ((WIDTHSBLOCK CHAR8CODE) - (\GETBASE WIDTHSBLOCK CHAR8CODE))) -(PUTPROPS \FSETIMAGEWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) - (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) -(PUTPROPS \FSETOFFSET DMACRO ((OFFSETSBLOCK CHAR8CODE OFFSET) - (\PUTBASE OFFSETSBLOCK CHAR8CODE OFFSET))) -(PUTPROPS \FSETWIDTH DMACRO ((WIDTHSBLOCK INDEX WIDTH) - (\PUTBASE WIDTHSBLOCK INDEX WIDTH))) -[PUTPROPS \GETCHARSETINFO MACRO ((CHARSET FONTDESC NOSLUG?) - (* * fetches the charsetinfo for charset CHARSET in fontdescriptor - FONTDESC. If NIL, then creates the required charset.) - (* * NOSLUG? means don't create an empty (slug) - csinfo if the charset is not found, just return NIL) - (OR (\GETBASEPTR (ffetch FONTCHARSETVECTOR of FONTDESC) - (UNFOLD CHARSET 2)) - (\CREATECHARSET CHARSET FONTDESC NOSLUG?] -(PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO) - (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2) - CSINFO))) -) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/lispusers/HGRAPH b/obsolete/lispusers/HGRAPH deleted file mode 100644 index 31e16306..00000000 --- a/obsolete/lispusers/HGRAPH +++ /dev/null @@ -1,281 +0,0 @@ -(FILECREATED "24-Apr-87 19:08:21" {ERIS}KOTO>HGRAPH.;2 12562 - - changes to: (FNS HARDCOPYWHOLEGRAPH) - - previous date: "27-Jan-87 14:35:21" {PHYLUM}KOTO>HGRAPH.;1) - - -(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT HGRAPHCOMS) - -(RPAQQ HGRAPHCOMS ((FNS CEILING HARDCOPYDISPLAYGRAPH HARDCOPYWHOLEGRAPH) - (P (MOVD (QUOTE HARDCOPYGRAPH) - (QUOTE OLDHARDCOPYGRAPH)) - (MOVD (QUOTE HARDCOPYWHOLEGRAPH) - (QUOTE HARDCOPYGRAPH))) - (* This is in order to fix the problem with borders on Interpress printers. I\t - seems that you cannot bitblt anything thinner than 36 pixel onto an - Interpress stream, why? Anyway, this fixes the problem by setting the border - width to 36))) -(DEFINEQ - -(CEILING - [LAMBDA (NUMBER) - (COND - ((EQP (FIX NUMBER) - NUMBER) - NUMBER) - (T (ADD1 (FIX NUMBER]) - -(HARDCOPYDISPLAYGRAPH - [LAMBDA (GRAPH STREAM CLIP/REG TRANS) (* bbb "27-Jan-87 11:52") - - (* 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.) - - (* This function is to be used together with  - HARDCOPYWHOLEGRAPH\, it assumes that the scaling of  - the graph is done already, for efficiency.) - (PROG (SCALE (LINEWIDTH 1)) - [OR (type? POSITION TRANS) - (SETQ TRANS (CONSTANT (create POSITION - XCOORD _ 0 - YCOORD _ 0] - (SETQ STREAM (GETSTREAM STREAM (QUOTE 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 TRANS (create POSITION - XCOORD _ (FIXR (FTIMES SCALE (fetch XCOORD - of TRANS))) - YCOORD _ (FIXR (FTIMES SCALE (fetch YCOORD - of TRANS] - (SETQ LINEWIDTH SCALE))) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) - do (DISPLAYNODELINKS N TRANS STREAM GRAPH T LINEWIDTH)) - (for N in (fetch (GRAPH GRAPHNODES) of GRAPH) do (PRINTDISPLAYNODE N TRANS - STREAM - CLIP/REG]) - -(HARDCOPYWHOLEGRAPH - [LAMBDA (GraphOrWindow File ImageType Translation NoAlignmentDots DontCloseStream) - (* N.H.Briggs "24-Apr-87 19:07") - - (* * Hardcopy \a whole graph from \a window using as many pages as necessary) - - (* fix: moved SCALE/GRAPH outside the for loops for  - effiency.) - (* fix: moved SCALE.REGION inline, in order to avoid  - the LOADFNS in the COMS list.) - (LET ((Stream (OR (AND File (OPENP File (QUOTE OUTPUT)) - File) - (OPENIMAGESTREAM File ImageType))) - (Graph (COND - ((WINDOWP GraphOrWindow) - (WINDOWPROP GraphOrWindow (QUOTE GRAPH))) - (T GraphOrWindow))) - GraphUnitsPerPageUnit PageUnitsPerGraphUnit GraphRegionInGraphUnits GraphRegionInPageUnits - PageRegion PageWidthInGraphUnits PageHeightInGraphUnits GraphWidthInGraphUnits - GraphHeightInGraphUnits CornerXOffsetInGraphUnits CornerYOffsetInGraphUnits PageScale - LeftCenteringOffsetInGraphUnits BottomCenteringOffsetInGraphUnits PageNumberFont - NumberOfXPages NumberOfYPages XPageNumberPositionInPageUnits YPageNumberPositionInPageUnits - LeftXAlignmentInPageUnits RightXAlignmentInPageUnits LowerYAlignmentInPageUnits - UpperYAlignmentInPageUnits PageUnitsPerInch) - (SETQ PageScale (DSPSCALE NIL Stream)) - (SETQ GraphUnitsPerPageUnit (FQUOTIENT 1.0 PageScale)) - (SETQ PageUnitsPerGraphUnit PageScale) (* 72 screen points per inch.) - (SETQ PageUnitsPerInch (TIMES PageScale 72)) - (SETQ GraphRegionInGraphUnits (GRAPHREGION Graph)) - (SETQ CornerXOffsetInGraphUnits (MINUS (fetch (REGION LEFT) of - GraphRegionInGraphUnits))) - (SETQ CornerYOffsetInGraphUnits (MINUS (fetch (REGION BOTTOM) of - GraphRegionInGraphUnits))) - (* fix: moved SCALE.REGION inline, in order to avoid  - the LOADFNS in the COMS list.) - [SETQ GraphRegionInPageUnits (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT) - of - GraphRegionInGraphUnits) - GraphUnitsPerPageUnit)) - (FIXR (QUOTIENT (fetch (REGION BOTTOM) - of - GraphRegionInGraphUnits) - GraphUnitsPerPageUnit)) - (FIXR (QUOTIENT (fetch (REGION WIDTH) - of - GraphRegionInGraphUnits) - GraphUnitsPerPageUnit)) - (FIXR (QUOTIENT (fetch (REGION HEIGHT) - of - GraphRegionInGraphUnits) - GraphUnitsPerPageUnit] - (SELECTQ (IMAGESTREAMTYPE Stream) - [INTERPRESS - - (* * Make the clipping region be the whole page on Interpress streams) - - - (DSPCLIPPINGREGION (CREATEREGION 0 0 (FIXR (TIMES - PageUnitsPerInch 8.5) - ) - (FIXR (TIMES - PageUnitsPerInch - 11.0))) - Stream) - - (* * Get rid of 1 inch margins except .5 inch at right and top) - - - (SETQ PageRegion (CREATEREGION 0 0 (FIXR (TIMES - PageUnitsPerInch 8.0) - ) - (FIXR (TIMES PageUnitsPerInch - 10.5] - [PRESS - - (* * Make the clipping region be the whole page on Press streams) - - - (DSPCLIPPINGREGION (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch - 8.5)) - (FIXR (TIMES PageUnitsPerInch - 11.0))) - Stream) - - (* * Get rid of 1 inch margins except 1 inch at right and top) - - - (SETQ PageRegion (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch - 7.5)) - (FIXR (TIMES PageUnitsPerInch 10.0] - (SETQ PageRegion (DSPCLIPPINGREGION NIL Stream))) - (SETQ PageWidthInGraphUnits (TIMES (fetch (REGION WIDTH) of PageRegion) - GraphUnitsPerPageUnit)) - (SETQ PageHeightInGraphUnits (TIMES (fetch (REGION HEIGHT) of PageRegion) - GraphUnitsPerPageUnit)) - (SETQ GraphWidthInGraphUnits (fetch (REGION WIDTH) of GraphRegionInGraphUnits)) - (SETQ GraphHeightInGraphUnits (fetch (REGION HEIGHT) of GraphRegionInGraphUnits)) - (SETQ BottomCenteringOffsetInGraphUnits (QUOTIENT (DIFFERENCE PageHeightInGraphUnits - (REMAINDER - GraphHeightInGraphUnits - PageHeightInGraphUnits)) - 1.75)) - (SETQ LeftCenteringOffsetInGraphUnits (QUOTIENT (DIFFERENCE PageWidthInGraphUnits - (REMAINDER - GraphWidthInGraphUnits - PageWidthInGraphUnits)) - 1.75)) - (SETQ NumberOfYPages (CEILING (QUOTIENT GraphHeightInGraphUnits PageHeightInGraphUnits) - )) - (SETQ NumberOfXPages (CEILING (QUOTIENT GraphWidthInGraphUnits PageWidthInGraphUnits))) - (SETQ PageNumberFont (FONTCREATE (QUOTE MODERN) - 6)) - - (* * The page numbers are \a quarter of in after the edge of the printing edge and are in the upper right hand  - corner of the page. The pages are printed row-wise and no page numbers are printed on the last page. - The page numbers are positioned .25 inch to the right of the right edge of the page region and .35 inch up from the - top of the page region. The alignment dots are .25 inch to the right of the right edge of the page region and .25  - inch up from the page region.) - - - (SETQ XPageNumberPositionInPageUnits (PLUS (fetch (REGION RIGHT) of PageRegion) - (TIMES PageUnitsPerInch .25))) - (SETQ YPageNumberPositionInPageUnits (PLUS (fetch (REGION TOP) of PageRegion) - (TIMES PageUnitsPerInch .35))) - (SETQ LeftXAlignmentInPageUnits (TIMES PageUnitsPerInch .25)) - (SETQ RightXAlignmentInPageUnits (PLUS (fetch (REGION RIGHT) of PageRegion) - (TIMES PageUnitsPerInch .25))) - (SETQ LowerYAlignmentInPageUnits (TIMES PageUnitsPerInch .25)) - (SETQ UpperYAlignmentInPageUnits (PLUS (fetch (REGION TOP) of PageRegion) - (TIMES PageUnitsPerInch .25))) - (* Latest fix: moved SCALE/GRAPH outside the for loops - for effiency.) - (SETQ Graph (SCALE/GRAPH Graph Stream PageScale)) - [for BottomOfPageInGraphUnits from 0 to GraphHeightInGraphUnits by - PageHeightInGraphUnits - as YPageNumber from 1 - do (for LeftOfPageInGraphUnits from 0 to GraphWidthInGraphUnits by - PageWidthInGraphUnits - as XPageNumber from 1 - do [HARDCOPYDISPLAYGRAPH Graph Stream (DSPCLIPPINGREGION NIL Stream) - (create POSITION - XCOORD _ (FIXR (PLUS - CornerXOffsetInGraphUnits - LeftCenteringOffsetInGraphUnits - (MINUS - LeftOfPageInGraphUnits))) - YCOORD _ (FIXR (PLUS - BottomCenteringOffsetInGraphUnits - CornerYOffsetInGraphUnits - (MINUS - BottomOfPageInGraphUnits] - - (* * Print the alignment points) - - - [COND - ((NOT NoAlignmentDots) - - (* * The lower left page should not have \a dot in the lower left corner. Similarly for other corner pages.) - - - (COND - ((NOT (AND (EQ XPageNumber 1) - (EQ YPageNumber 1))) - (MOVETO LeftXAlignmentInPageUnits LowerYAlignmentInPageUnits - Stream) - (printout Stream "."))) - (COND - ((NOT (AND (EQ XPageNumber NumberOfXPages) - (EQ YPageNumber 1))) - (MOVETO RightXAlignmentInPageUnits LowerYAlignmentInPageUnits - Stream) - (printout Stream "."))) - (COND - ((NOT (AND (EQ YPageNumber NumberOfYPages) - (EQ XPageNumber 1))) - (MOVETO LeftXAlignmentInPageUnits UpperYAlignmentInPageUnits - Stream) - (printout Stream "."))) - (COND - ((NOT (AND (EQ XPageNumber NumberOfXPages) - (EQ YPageNumber NumberOfYPages))) - (MOVETO RightXAlignmentInPageUnits UpperYAlignmentInPageUnits - Stream) - (printout Stream "."] - (COND - ((NOT (AND (EQ XPageNumber NumberOfXPages) - (EQ YPageNumber NumberOfYPages))) - (* Not on the very last page) - (DSPFONT PageNumberFont Stream) - (MOVETO XPageNumberPositionInPageUnits YPageNumberPositionInPageUnits - Stream) - (printout Stream XPageNumber "," YPageNumber) - (* Print the page number) - (DSPNEWPAGE Stream] - (COND - ((NOT DontCloseStream) - (CLOSEF Stream]) -) -(MOVD (QUOTE HARDCOPYGRAPH) - (QUOTE OLDHARDCOPYGRAPH)) -(MOVD (QUOTE HARDCOPYWHOLEGRAPH) - (QUOTE HARDCOPYGRAPH)) - - - -(* This is in order to fix the problem with borders on Interpress printers. I\t seems that you - cannot bitblt anything thinner than 36 pixel onto an Interpress stream, why? Anyway, this -fixes the problem by setting the border width to 36) - -(PUTPROPS HGRAPH COPYRIGHT ("Xerox Corporation" 1987)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (779 12115 (CEILING 789 . 928) (HARDCOPYDISPLAYGRAPH 930 . 2653) (HARDCOPYWHOLEGRAPH -2655 . 12113))))) -STOP diff --git a/obsolete/lispusers/HGRAPH.LCOM b/obsolete/lispusers/HGRAPH.LCOM deleted file mode 100644 index e4620f4e..00000000 Binary files a/obsolete/lispusers/HGRAPH.LCOM and /dev/null differ diff --git a/obsolete/lispusers/HOSTUP b/obsolete/lispusers/HOSTUP deleted file mode 100644 index 2327173c..00000000 --- a/obsolete/lispusers/HOSTUP +++ /dev/null @@ -1,185 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "19-Oct-89 17:18:44" {ICE}LISPUSERS>MEDLEY>HOSTUP.;1 9510 - - changes to%: (VARS HOSTUPCOMS) - - previous date%: "19-Oct-89 16:52:50" {ICE}LISPUSERS>MEDLEY>HOSTUP.;1) - - -(* " -Copyright (c) 1988, 1989 by Johannes A. G. M. Koomen. All rights reserved. -") - -(PRETTYCOMPRINT HOSTUPCOMS) - -(RPAQQ HOSTUPCOMS - ((FNS HOSTUP?) - (INITVARS (HOSTUP.TIMEOUT 15000) - (HOSTUP.RETRYCNT 5)) - (GLOBALVARS HOSTUP.TIMEOUT HOSTUP.RETRYCNT) - (DECLARE%: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE - (FILES SYSEDIT [FROM VALUEOF (for D in LISPUSERSDIRECTORIES until - (INFILEP (PACKFILENAME 'NAME 'LLNSDECLS 'BODY - (SETQ $$VAL - (PACKFILENAME - 'HOST - (FILENAMEFIELD D 'HOST) - 'DIRECTORY - (CONCAT "LISP>" MAKESYSNAME - ">SOURCES"] - LLNSDECLS - (LOADCOMP) - LLNS)))) -(DEFINEQ - -(HOSTUP? - [LAMBDA (name) (* ; "Edited 19-Oct-89 16:51 by koomen") - - (* ;; "Adapted from FILECACHE function \FCACHE.HOSTUP?") - - (* ;; "Uses the globalvar HOSTUP.TIMEOUT (default: 15,000 msecs) to limit total wait time, and the globalvar HOSTUP.RETRYCNT (default: 5 times) to limit the number of retries") - (* smL " 3-Sep-86 16:04") - -(* ;;; "Try to determine if the host if able to respond") - - (LET* [(DEV (\GETDEVICEFROMNAME name T NIL)) - (retryCount (MAX 1 (FIX HOSTUP.RETRYCNT))) - (initialInterval (FIX (QUOTIENT (MAX 1000 HOSTUP.TIMEOUT) - (SUB1 (LSH 1 retryCount] - (SELECTQ (if DEV - then - - (* ;; "use real DEV to determine the DEV type") - - (SELECTQ (fetch OPENFILE of DEV) - ((\LEAF.OPENFILE \FTP.OPENFILE) - 'LEAF) - (\NSFILING.OPENFILE - 'NSFILING) - (fetch DEVICENAME of DEV)) - else - - (* ;; - "the FDEV doesn't exist, and we can't create one for it, so it must be down") - - 'NOFDEV) - (LEAF - (* ;; "We think its a LEAF server, so try PUP.ECHOUSER") - - (RESETLST - (PROG ((i 1) - (interval initialInterval) - (PORT (BESTPUPADDRESS name PROMPTWINDOW)) - (SOC (OPENPUPSOCKET)) - echo OPUP IPUP ECHOPUPLENGTH) - (RESETSAVE NIL (LIST 'CLOSEPUPSOCKET SOC)) - (OR PORT (RETURN NIL)) - TryAgain - (if (IGREATERP i retryCount) - then (RETURN NIL)) - (SETQ OPUP (ALLOCATE.PUP)) - (SETUPPUP OPUP PORT \PUPSOCKET.ECHO \PT.ECHOME NIL SOC T) - (PUTPUPWORD OPUP 0 1) - (add (fetch PUPLENGTH of OPUP) - BYTESPERWORD) - (SETQ ECHOPUPLENGTH (fetch PUPLENGTH of OPUP)) - (SENDPUP SOC OPUP) - [COND - ((SETQ IPUP (GETPUP SOC interval)) - (COND - ((PROG1 (AND (EQ (fetch PUPTYPE of IPUP) - \PT.IAMECHO) - (EQ (fetch PUPIDHI of IPUP) - (fetch PUPIDHI of OPUP)) - (EQ (fetch PUPIDLO of IPUP) - (fetch PUPIDLO of OPUP)) - (EQ (fetch PUPLENGTH of IPUP) - ECHOPUPLENGTH) - (IEQP (GETPUPWORD IPUP 0) - 1)) - (RELEASE.PUP IPUP)) - (RETURN T] - (SETQ i (ADD1 i)) - (SETQ interval (ITIMES interval 2)) - (GO TryAgain)))) - (NSFILING (* ; - "We think its an NSFILING server, so try NS.ECHOUSER") - (RESETLST - (PROG ((i 1) - (interval initialInterval) - (ECHOADDRESS (OR (COERCE-TO-NSADDRESS name \NS.WKS.Echo) - (\ILLEGAL.ARG name))) - NSOC OXIP ECHOXIPLENGTH IXIP) - (OR ECHOADDRESS (RETURN NIL)) - [RESETSAVE NIL (LIST 'CLOSENSOCKET (SETQ NSOC (OPENNSOCKET] - (if (IGREATERP i retryCount) - then (RETURN NIL)) - (SETQ OXIP (\FILLINXIP \XIPT.ECHO NSOC ECHOADDRESS)) - (XIPAPPEND.WORD OXIP \XECHO.OP.REQUEST) - (XIPAPPEND.WORD OXIP 1) - (SETQ ECHOXIPLENGTH (fetch XIPLENGTH of OXIP)) - TryAgain - (if (IGREATERP i retryCount) - then (RETURN NIL)) - (SENDXIP NSOC OXIP) - [COND - ((SETQ IXIP (GETXIP NSOC interval)) - (COND - ((PROG1 (AND (EQ (fetch XIPTYPE of IXIP) - \XIPT.ECHO) - (EQ (fetch XIPLENGTH of IXIP) - ECHOXIPLENGTH) - (EQ (\GETBASE (fetch XIPCONTENTS - of IXIP) - 0) - \XECHO.OP.REPLY)) - (RELEASE.XIP IXIP)) - (RETURN T] - (SETQ i (ADD1 i)) - (SETQ interval (LLSH interval 1)) - (GO TryAgain)))) - (FLOPPY - (* ;; "the FLOPPY disk") - - (* ;; - "Should be (FLOPPY.CAN.READP) but this triggers a bug in the Floppy handler") - - T) - (TCP - (* ;; "A TCP device. Punt on them") - - T) - (NOFDEV - (* ;; "we can't create an FDEV for the device, so it can't be up") - - NIL) - T]) -) - -(RPAQ? HOSTUP.TIMEOUT 15000) - -(RPAQ? HOSTUP.RETRYCNT 5) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS HOSTUP.TIMEOUT HOSTUP.RETRYCNT) -) -(DECLARE%: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE - -(FILESLOAD SYSEDIT [FROM VALUEOF (for D in LISPUSERSDIRECTORIES - until (INFILEP (PACKFILENAME 'NAME 'LLNSDECLS - 'BODY - (SETQ $$VAL - (PACKFILENAME 'HOST - (FILENAMEFIELD D - 'HOST) - 'DIRECTORY - (CONCAT "LISP>" MAKESYSNAME - ">SOURCES"] - LLNSDECLS - (LOADCOMP) - LLNS) -) -(PUTPROPS HOSTUP COPYRIGHT ("Johannes A. G. M. Koomen" 1988 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1512 8312 (HOSTUP? 1522 . 8310))))) -STOP diff --git a/obsolete/lispusers/HOSTUP.TEDIT b/obsolete/lispusers/HOSTUP.TEDIT deleted file mode 100644 index 5f8fb3db..00000000 Binary files a/obsolete/lispusers/HOSTUP.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/INDEX b/obsolete/lispusers/INDEX deleted file mode 100644 index fdfbeab1..00000000 --- a/obsolete/lispusers/INDEX +++ /dev/null @@ -1,588 +0,0 @@ -(FILECREATED "18-Feb-87 15:44:37" {SUMEX-AIM}PS:INDEX.;4 23471 - - changes to: (FNS INSERT.KNOWN.INDEX) - - previous date: "17-Feb-87 14:27:45" {SUMEX-AIM}PS:INDEX.;5) - - -(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) - -(PRETTYCOMPRINT INDEXCOMS) - -(RPAQQ INDEXCOMS ((* Developed under support from NIH grant RR-00785.) - (* Written by Frank Gilmurray and Sami Shaio.) - (FNS INDEXOBJ INDEXOBJP INDEX.DISPLAYFN INDEX.IMAGEBOXFN INDEX.PUTFN INDEX.GETFN - INDEX.BUTTONEVENTINFN CHANGE.INDEX CHANGE.INDEXENTRY INDEX.WHENDELETEDFN) - (FNS ADD.NEW.INDEX INDEX.STRING INSERT.INDEX INSERT.INDEXENTRY - GET.INDEXENTRY.NUMBER INSERT.KNOWN.INDEX INDEX.LIST.REFS - LIST.OF.INDEXENTRIES CREATE.INDEX.FILE VIEW.INDEX.FILE GET.INDEX.FILE - WRITE.INDEX.FILE WRITE.INDEX.PAGENUMBERS) - (RECORDS INDEX.ENTRY.RECORD))) - - - -(* Developed under support from NIH grant RR-00785.) - - - - -(* Written by Frank Gilmurray and Sami Shaio.) - -(DEFINEQ - -(INDEXOBJ - (LAMBDA (KEY INDEXENTRY.PARMS) (* fsg "15-Jan-87 09:53") - - (* * Create an instance of an Index or IndexEntry imageobject. The difference between the two is the OBJECTDATUM. - For a simple Index, OBJECTDATUM is NIL. For an IndexEntry, OBJECTDATUM is a record containing the Entry, Entry's  - font, and Number option. In either case, the INDEX.KEY property is the hash key and is also the text to index for a - simple Index.) - - - (LET ((NEWOBJ (IMAGEOBJCREATE INDEXENTRY.PARMS (IMAGEFNSCREATE (FUNCTION INDEX.DISPLAYFN) - (FUNCTION INDEX.IMAGEBOXFN) - (FUNCTION INDEX.PUTFN) - (FUNCTION INDEX.GETFN) - (FUNCTION NILL) - (FUNCTION - INDEX.BUTTONEVENTINFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION - INDEX.WHENDELETEDFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL))))) - (IMAGEOBJPROP NEWOBJ 'INDEX.KEY - KEY) - (IMAGEOBJPROP NEWOBJ 'TYPE - 'INDEXOBJ) - NEWOBJ))) - -(INDEXOBJP - (LAMBDA (OBJ) (* fsg "15-Jan-87 09:55") - - (* * Tests an imageobject to see if it an Index or IndexEntry imageobject. By convention, testing functions for an  - imageobject are named .) - - - (AND OBJ (EQ (IMAGEOBJPROP OBJ 'TYPE) - 'INDEXOBJ)))) - -(INDEX.DISPLAYFN - (LAMBDA (OBJ STREAM) (* fsg "17-Feb-87 10:18") - - (* * Display an Index or IndexEntry imageobject. If the output is to the display imagestream, then just type Index  - or IndexEntry followed by their args. Otherwise the output is to a hardcopy imagestream. In this case type nothing  - and replace the CAR of the hash array entry with a list of page numbers in which this index entry appears. -  is the current TEdit page number iff doing a hardcopy.) - - - (LET ((WINDOW (CAR (fetch \WINDOW of TEXTOBJ))) - PGS/IMOBJS CURRENT.PAGE) - (SELECTQ (IMAGESTREAMTYPE STREAM) - (DISPLAY (PROGN (DSPFONT GP.DefaultFont STREAM) - (PRIN3 (INDEX.STRING OBJ) - STREAM))) - (PROGN (SETQ PGS/IMOBJS (GETHASH (MKATOM (IMAGEOBJPROP OBJ - 'INDEX.KEY)) - (WINDOWPROP WINDOW - 'TSP.INDEX.ARRAY))) - (SETQ CURRENT.PAGE (CAR FORMATTINGSTATE)) - (COND - (PGS/IMOBJS (COND - ((LISTP (CAR PGS/IMOBJS)) - (OR (MEMBER CURRENT.PAGE (CAR PGS/IMOBJS)) - (RPLACA PGS/IMOBJS - (SORT (APPEND (CAR PGS/IMOBJS) - (LIST CURRENT.PAGE) - ) - 'ILESSP)))) - (T (RPLACA PGS/IMOBJS (LIST CURRENT.PAGE))))) - (T (SHOULDNT "No array entry for this INDEX")))))))) - -(INDEX.IMAGEBOXFN - (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* fsg "15-Feb-87 14:37") - - (* * Return the ImageBox for an Index or IndexEntry request.) - - - (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) (* fsg "11-Feb-87 11:07") - - (* * Puts the Index or IndexEntry imageobject in a file.) - - - (LET ((DATUM (fetch OBJECTDATUM of OBJ))) - (PRIN2 (COND - (DATUM (LIST 'IndexEntry - (IMAGEOBJPROP OBJ 'INDEX.KEY) - DATUM)) - (T (LIST 'Index - (IMAGEOBJPROP OBJ 'INDEX.KEY)))) - STREAM)))) - -(INDEX.GETFN - (LAMBDA (STREAM) (* fsg "11-Feb-87 10:42") - - (* * Create the Index or IndexEntry imageobject when it is read from file.) - - - (LET* ((INDEX.ARGS (CDR (READ STREAM))) - (NEWOBJ (APPLY 'INDEXOBJ - INDEX.ARGS)) - (WINDOW (PROCESSPROP (THIS.PROCESS) - 'WINDOW))) - (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) - (TSP.FMMENU (TEXTSTREAM WINDOW))) - (ADD.NEW.INDEX WINDOW (CAR INDEX.ARGS) - NEWOBJ) - NEWOBJ))) - -(INDEX.BUTTONEVENTINFN - (LAMBDA (OBJ STREAM SEL RELX RELY WINDOW HOSTSTREAM BUTTON) - (* fsg "15-Jan-87 11:26") - - (* * Process the MIDDLE button pressed inside an Index or IndexEntry imageobject. This means the user wants to  - Change this index.) - - - (AND (MOUSESTATE MIDDLE) - (MENU (create MENU - ITEMS _ '((Change 'CHANGE - "Change this Index or IndexEntry")) - CENTERFLG _ T)) - (LET* ((OBJDATUM (fetch OBJECTDATUM of OBJ)) - (NEW.INDEX (COND - (OBJDATUM (CHANGE.INDEXENTRY OBJ STREAM OBJDATUM)) - (T (CHANGE.INDEX OBJ STREAM))))) - (AND (CAR NEW.INDEX) - (PROGN (INDEX.WHENDELETEDFN OBJ STREAM) - (IMAGEOBJPROP OBJ 'INDEX.KEY - (CAR NEW.INDEX)) - (AND OBJDATUM (replace OBJECTDATUM of OBJ - with (CADR NEW.INDEX))) - (ADD.NEW.INDEX WINDOW (CAR NEW.INDEX) - OBJ) - 'CHANGED)))))) - -(CHANGE.INDEX - (LAMBDA (OBJ STREAM) (* fsg "15-Jan-87 10:54") - - (* * Here when CHANGE buttoned inside an Index ImageObject.) - - - (LIST (MKATOM (TEDIT.GETINPUT STREAM (CONCAT "Change Index name %"" - (IMAGEOBJPROP OBJ 'INDEX.KEY) - "%" to: ")))))) - -(CHANGE.INDEXENTRY - (LAMBDA (OBJ STREAM OBJDATUM) (* fsg "15-Jan-87 11:17") - - (* * Here when CHANGE buttoned inside an IndexEntry ImageObject.) - - - (LET ((WINDOW (\TEDIT.MAINW STREAM)) - NEWINDEX.KEY NEWINDEX.ENTRY NEWINDEX.FONT NEWINDEX.NUMBER) - (COND - ((SETQ NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM (CONCAT - "Change IndexEntry Key %"" - (IMAGEOBJPROP - OBJ - 'INDEX.KEY) - "%" to: ")))) - (SETQ NEWINDEX.ENTRY (OR (MKATOM (TEDIT.GETINPUT STREAM - (CONCAT - "Change IndexEntry Entry %"" - (fetch INDEX.ENTRY - of OBJDATUM) - "%" to: "))) - (fetch INDEX.ENTRY of OBJDATUM))) - (TEDIT.PROMPTPRINT STREAM (CONCAT "Change IndexEntry Entry font %"" - (ABBREVIATE.FONT (fetch INDEX.ENTRYFONT - of OBJDATUM)) - "%" to...") - T) - (until (SETQ NEWINDEX.FONT (GET.TSP.FONT WINDOW (OR (fetch INDEX.ENTRYFONT - of OBJDATUM) - GP.DefaultFont))) - do (TEDIT.PROMPTPRINT STREAM "Invalid font specification...try again." T)) - (TEDIT.PROMPTPRINT STREAM (CONCAT "Change IndexEntry Number option %"" - (fetch INDEX.NUMBER of OBJDATUM) - "%" to...") - T) - (SETQ NEWINDEX.NUMBER (GET.INDEXENTRY.NUMBER WINDOW (fetch INDEX.NUMBER - of OBJDATUM))) - (TEDIT.PROMPTPRINT STREAM "" T) - (LIST NEWINDEX.KEY (create INDEX.ENTRY.RECORD - INDEX.ENTRY _ NEWINDEX.ENTRY - INDEX.ENTRYFONT _ NEWINDEX.FONT - INDEX.NUMBER _ NEWINDEX.NUMBER))) - (T (LIST NEWINDEX.KEY)))))) - -(INDEX.WHENDELETEDFN - (LAMBDA (OBJ WINDOW) (* fsg "15-Jan-87 11:30") - - (* * Delete the selected Index or IndexEntry 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))) -) -(DEFINEQ - -(ADD.NEW.INDEX - (LAMBDA (WINDOW INDEXKEY OBJ) (* fsg "28-Jan-87 11:37") - - (* * Add an Index or IndexEntry 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 IndexEntry 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 '"[Pages (?)]" - INDEX.OBJS ENTRY.OBJS) - CODE.ARRAY)))) - -(INDEX.STRING - (LAMBDA (OBJ) (* fsg "15-Feb-87 14:40") - - (* * Returns the display imagestream text for an Index or IndexEntry ImageObject.) - - - (LET ((OBJDATUM (fetch OBJECTDATUM of OBJ)) - INDEXNUMBER) - (COND - (OBJDATUM (CONCAT "[Index Key=" (MKATOM (IMAGEOBJPROP OBJ 'INDEX.KEY)) - ",Entry=" - (fetch INDEX.ENTRY of OBJDATUM) - (COND - ((EQ (SETQ INDEXNUMBER (fetch INDEX.NUMBER of OBJDATUM)) - 'YES) - ",Number]") - ((NUMBERP INDEXNUMBER) - (CONCAT ",Number=" INDEXNUMBER "]")) - (T "]")))) - (T (CONCAT "[Index " (MKATOM (IMAGEOBJPROP OBJ 'INDEX.KEY)) - "]")))))) - -(INSERT.INDEX - (LAMBDA (STREAM WINDOW) (* fsg "15-Jan-87 11:37") - - (* * Process the "Index" function in the ImageObjects menu.) - - - (LET ((NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM "Index Key: ")))) - (TEDIT.PROMPTPRINT STREAM "" T) - (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)))))) - -(INSERT.INDEXENTRY - (LAMBDA (STREAM WINDOW) (* fsg "15-Jan-87 11:39") - - (* * Process the "IndexEntry" function in the ImageObjects menu.) - - - (LET ((NEWINDEX.KEY (MKATOM (TEDIT.GETINPUT STREAM "IndexEntry Key: "))) - NEWINDEX.ENTRY NEWINDEX.FONT NEWINDEX.NUMBER) - (COND - (NEWINDEX.KEY (SETQ NEWINDEX.ENTRY (OR (MKATOM (TEDIT.GETINPUT STREAM - "IndexEntry Entry: " - (MKSTRING - NEWINDEX.KEY))) - NEWINDEX.KEY)) - (TEDIT.PROMPTPRINT STREAM "IndexEntry Entry font..." T) - (until (SETQ NEWINDEX.FONT (GET.TSP.FONT WINDOW GP.DefaultFont)) - do (TEDIT.PROMPTPRINT STREAM - "Invalid font specification...try again." - T)) - (TEDIT.PROMPTPRINT STREAM "IndexEntry Number option..." T) - (SETQ NEWINDEX.NUMBER (GET.INDEXENTRY.NUMBER WINDOW)) - (TEDIT.PROMPTPRINT STREAM "" T) - (LET ((NEW.INDEX.OBJ (INDEXOBJ NEWINDEX.KEY - (create INDEX.ENTRY.RECORD - INDEX.ENTRY _ NEWINDEX.ENTRY - INDEX.ENTRYFONT _ NEWINDEX.FONT - INDEX.NUMBER _ NEWINDEX.NUMBER)))) - (ADD.NEW.INDEX WINDOW NEWINDEX.KEY NEW.INDEX.OBJ) - (TEDIT.INSERT.OBJECT NEW.INDEX.OBJ STREAM))) - (T (TEDIT.PROMPTPRINT STREAM "" T)))))) - -(GET.INDEXENTRY.NUMBER - (LAMBDA (WINDOW DEFAULTNUMBER) (* fsg "15-Jan-87 11:43") - - (* * 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))) - -(INSERT.KNOWN.INDEX - (LAMBDA (STREAM WINDOW) (* fsg "18-Feb-87 14:48") - - (* * Process the "Known Indices" function in the ImageObjects menu. A menu of all the known Indices and  - IndexEntries pops up and the user may button one of these to insert the corrsponding Index or IndexEntry. - Any buttoning outside of this menu will make it disappear.) - - - (LET* ((PREVINDICES (INDEX.LIST.REFS WINDOW)) - (NEWINDEX.KEY (COND - (PREVINDICES (LET ((NMENU (create MENU - TITLE _ "Index Keys" - ITEMS _ PREVINDICES)) - MENU.SELECTION) - (SETQ MENU.SELECTION (MENU NMENU)) - (AND MENU.SELECTION (OR (LISTP MENU.SELECTION) - (LIST MENU.SELECTION))))) - (T (TEDIT.PROMPTPRINT STREAM - "There are no Indicies/IndexEntries 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)))))) - -(INDEX.LIST.REFS - (LAMBDA (WINDOW) (* fsg "15-Jan-87 11:46") - - (* * Return a sorted list of the Index and IndexEntry keys. Simple Index keys are just added to the list. - For an IndexEntry key, there are SUBITEMS for each IndexEntry 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 IndexEntry subitem." - (CONS 'SUBITEMS - (LIST.OF.INDEXENTRIES - KEY - (CADDR INDEX.VALUE)))))))) - (CDR INDEX.ITEMS)))) - -(LIST.OF.INDEXENTRIES - (LAMBDA (KEY OBJLIST) (* fsg "15-Jan-87 11:48") - - (* * Returns a list of the IndexEntries sorted by Entry) - - - (LET ((ENTRY.LIST (CONS)) - OBJDATUM) - (for OBJ in OBJLIST - do (SETQ OBJDATUM (fetch OBJECTDATUM of OBJ)) - (NCONC ENTRY.LIST (LIST (LIST (CONCAT (fetch INDEX.ENTRY of OBJDATUM) - ", " - (ABBREVIATE.FONT (fetch - INDEX.ENTRYFONT - of OBJDATUM)) - ", " - (fetch INDEX.NUMBER of OBJDATUM)) - (KWOTE (LIST KEY OBJDATUM)))))) - (SORT (INTERSECTION (CDR ENTRY.LIST) - (CDR ENTRY.LIST)) - (FUNCTION (LAMBDA (A B) - (UALPHORDER (CAADR (CADADR A)) - (CAADR (CADADR B))))))))) - -(CREATE.INDEX.FILE - (LAMBDA (STREAM WINDOW) (* fsg "15-Dec-86 13:22") - - (* * Writes the indices and their corresponding page numbers or strings 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 (AND INDEX.FILE (OPENTEXTSTREAM)))) - (COND - ((AND INDEX.LIST INDEX.FILE) - (TEDIT.PROMPTPRINT STREAM (CONCAT "Putting indices in: " INDEX.FILE "...") - T) - (WRITE.INDEX.FILE INDEX.STREAM INDEX.LIST INDEX.ARRAY) - (TEDIT.PROMPTPRINT STREAM "done") - (TEDIT.PUT INDEX.STREAM 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 in this document." T) - NIL))))) - -(VIEW.INDEX.FILE - (LAMBDA (STREAM WINDOW) (* fsg "15-Dec-86 15:22") - - (* * 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)) - (INDEX.FILEW (WINDOWPROP WINDOW 'INDEX.WINDOW))) - (AND INDEX.FILE (COND - ((WINDOWP INDEX.FILEW) - (COND - ((OPENWP INDEX.FILEW) - (TEDIT.GET (TEXTOBJ INDEX.FILEW) - INDEX.FILE)) - ((OPENW INDEX.FILEW) - (TEDIT INDEX.FILE INDEX.FILEW)))) - (T (WINDOWPROP WINDOW 'INDEX.WINDOW - (SETQ INDEX.FILEW (CREATEW NIL (CONCAT - "Viewing index file: " - INDEX.FILE)))) - (TEDIT INDEX.FILE INDEX.FILEW))))))) - -(GET.INDEX.FILE - (LAMBDA (MENUW) (* fsg "19-Aug-86 09:09") - - (* * Return the user specified index file name.) - - - (LET* ((ITEM (FM.ITEMFROMID MENUW 'INDEX.FILE)) - (FILENAME (FM.ITEMPROP ITEM 'LABEL))) - (COND - ((NOT (STREQUAL FILENAME "")) - (MKATOM FILENAME)))))) - -(WRITE.INDEX.FILE - (LAMBDA (INDEX.STREAM INDEX.LIST INDEX.ARRAY) (* fsg "28-Jan-87 13:31") - - (* * Do the output to the index file. For each Index, the Key is printed followed by the list of page numbers in  - which this Index Key appears. Each IndexEntry is printed on a separate line and the page number depends on the  - IndexEntry Number option. After all indices/indexentries are printed, the array page number list is converted back  - to a string. This insures that the next DISPLAYFN call will reconvert the string back to a page number list.) - - - (DSPFONT (FONTCREATE '(HELVETICA 14 BRR)) - INDEX.STREAM) - (PRINTOUT INDEX.STREAM "Index" T T) - (for INDEX.ITEM in INDEX.LIST - do (COND - ((LISTP INDEX.ITEM) - (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 (DSPFONT GP.DefaultFont INDEX.STREAM) - (LET ((PGS.AND.IMOBJS (GETHASH INDEX.ITEM INDEX.ARRAY))) - (COND - ((CAR PGS.AND.IMOBJS) - (PRINTOUT INDEX.STREAM (MKSTRING INDEX.ITEM)) - (WRITE.INDEX.PAGENUMBERS INDEX.STREAM PGS.AND.IMOBJS NIL) - (PRINTOUT INDEX.STREAM T)) - (T NIL)))))) - (for (INDEX.ITEM PAGES/IMOBJS) in INDEX.LIST - do (SETQ PAGES/IMOBJS (GETHASH (COND - ((LISTP INDEX.ITEM) - (CAR INDEX.ITEM)) - (T INDEX.ITEM)) - INDEX.ARRAY)) - (RPLACA PAGES/IMOBJS (COND - ((STRINGP (CAR PAGES/IMOBJS)) - (CAR PAGES/IMOBJS)) - (T (CONCAT "[Pages " (MKSTRING (CAR PAGES/IMOBJS)) - "]"))))))) - -(WRITE.INDEX.PAGENUMBERS - (LAMBDA (STREAM PAGES.AND.IMOBJS NUMBER.OPTION) (* fsg "15-Jan-87 11:53") - - (* * Here to write the actual page or pages nubers that this Index or IndexEntry appears in. - NUMBER.OPTION is the Number field of an IndexEntry.) - - - (DSPFONT GP.DefaultFont STREAM) - (LET ((PAGE.NBRS (COND - (NUMBER.OPTION (SELECTQ NUMBER.OPTION - (NO "") - (YES (CAR PAGES.AND.IMOBJS)) - (MKSTRING NUMBER.OPTION))) - (T (CAR PAGES.AND.IMOBJS)))) - (PAGE#.STRING " ")) - (COND - ((LISTP PAGE.NBRS) - (for PAGE in PAGE.NBRS do (SETQ PAGE#.STRING (CONCAT PAGE#.STRING " " - (MKSTRING PAGE))) - finally (PRINTOUT STREAM PAGE#.STRING))) - (T (PRINTOUT STREAM (CONCAT PAGE#.STRING PAGE.NBRS))))))) -) -[DECLARE: EVAL@COMPILE - -(RECORD INDEX.ENTRY.RECORD (INDEX.ENTRY INDEX.ENTRYFONT INDEX.NUMBER)) -] -(PUTPROPS INDEX COPYRIGHT ("Leland Stanford Junior University" 1987)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (1056 9971 (INDEXOBJ 1068 . 2331) (INDEXOBJP 2335 . 2718) (INDEX.DISPLAYFN 2722 . 4281) -(INDEX.IMAGEBOXFN 4285 . 4863) (INDEX.PUTFN 4867 . 5325) (INDEX.GETFN 5329 . 5903) ( -INDEX.BUTTONEVENTINFN 5907 . 6972) (CHANGE.INDEX 6976 . 7324) (CHANGE.INDEXENTRY 7328 . 9178) ( -INDEX.WHENDELETEDFN 9182 . 9968)) (9973 23270 (ADD.NEW.INDEX 9985 . 10986) (INDEX.STRING 10990 . 11779 -) (INSERT.INDEX 11783 . 12319) (INSERT.INDEXENTRY 12323 . 13738) (GET.INDEXENTRY.NUMBER 13742 . 14360) - (INSERT.KNOWN.INDEX 14364 . 15630) (INDEX.LIST.REFS 15634 . 16840) (LIST.OF.INDEXENTRIES 16844 . -17764) (CREATE.INDEX.FILE 17768 . 18867) (VIEW.INDEX.FILE 18871 . 19740) (GET.INDEX.FILE 19744 . 20129 -) (WRITE.INDEX.FILE 20133 . 22381) (WRITE.INDEX.PAGENUMBERS 22385 . 23267))))) -STOP diff --git a/obsolete/lispusers/IRIS.TEdit b/obsolete/lispusers/IRIS.TEdit deleted file mode 100644 index 69ac05ec..00000000 Binary files a/obsolete/lispusers/IRIS.TEdit and /dev/null differ diff --git a/obsolete/lispusers/IRISCONSTANTS b/obsolete/lispusers/IRISCONSTANTS deleted file mode 100644 index b5af99bc..00000000 --- a/obsolete/lispusers/IRISCONSTANTS +++ /dev/null @@ -1,1708 +0,0 @@ -(FILECREATED "24-Oct-85 18:17:51" {ERIS}KOTO>IRISCONSTANTS.;2 48027 - - changes to: (VARS IRISCONSTANTSCOMS) - - previous date: " 5-Sep-85 23:28:08" {ERIS}KOTO>IRISCONSTANTS.;1) - - -(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT IRISCONSTANTSCOMS) - -(RPAQQ IRISCONSTANTSCOMS [(COMS (* * gl.h) - (* Maximum X and Y screen coordinates) - (CONSTANTS (IRIS.XMAXSCREEN 1023) - (IRIS.YMAXSCREEN 767)) - (* Various hardware/software limits) - (CONSTANTS (IRIS.ATTRIBSTACKDEPTH 10) - (IRIS.VPSTACKDEPTH 8) - (IRIS.MATRIXSTACKDEPTH 32) - (IRIS.STARTTAG -2) - (IRIS.ENDTAG -3)) - (* Name for colors in color map loaded by IRIS.GINIT) - (CONSTANTS (IRIS.BACKGROUND 0) - (IRIS.BLACK 0) - (IRIS.RED 1) - (IRIS.GREEN 2) - (IRIS.YELLOW 3) - (IRIS.BLUE 4) - (IRIS.MAGENTA 5) - (IRIS.CYAN 6) - (IRIS.WHITE 7))) - (COMS (* * device.h) - (* Macros to test valuator and button numbers) - (MACROS IRIS.ISBUTTON IRIS.ISSCRBUTTON IRIS.ISVALUATOR IRIS.ISTIMER - IRIS.ISDIAL IRIS.ISLPEN IRIS.ISLPENBUT) - (* Include file with device definitions) - (CONSTANTS (IRIS.NULLDEV 0) - (IRIS.BUTOFFSET 1) - (IRIS.SBTOFFSET 200) - (IRIS.VALOFFSET 256) - (IRIS.KEYOFFSET 512) - (IRIS.TIMOFFSET 515) - (IRIS.BUTCOUNT 144) - (IRIS.SBTCOUNT 16) - (IRIS.VALCOUNT 14) - (IRIS.TIMCOUNT 8)) - (* Buttons) - (CONSTANTS (IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET)) - (IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET)) - (IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET)) - (IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET)) - (IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET)) - (IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET)) - (IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET)) - (IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET)) - (IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET)) - (IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET)) - (IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET)) - (IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET)) - (IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET)) - (IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET)) - (IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET)) - (IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET)) - (IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET)) - (IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET)) - (IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET)) - (IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET)) - (IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET)) - (IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET)) - (IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET)) - (IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET)) - (IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET)) - (IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET)) - (IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET)) - (IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET)) - (IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET)) - (IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET)) - (IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET)) - (IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET)) - (IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET)) - (IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET)) - (IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET)) - (IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET)) - (IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET)) - (IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET)) - (IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET)) - (IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET)) - (IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET)) - (IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET)) - (IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET)) - (IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET)) - (IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET)) - (IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET)) - (IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET)) - (IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET)) - (IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET)) - (IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET)) - (IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET)) - (IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET)) - (IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET)) - (IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET)) - (IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET)) - (IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET)) - (IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET)) - (IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET)) - (IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET)) - (IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET)) - (IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET)) - (IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET)) - (IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET)) - (IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET)) - (IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET)) - (IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET)) - (IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET)) - (IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET)) - (IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET)) - (IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET)) - (IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET)) - (IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET)) - (IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET)) - (IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET)) - (IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET)) - (IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET)) - (IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET)) - (IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET)) - (IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET)) - (IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET)) - (IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET)) - (IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET)) - (IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET)) - (IRIS.MAXKBDBUT IRIS.BUT82) - (IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET)) - (IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET)) - (IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET)) - (IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET)) - (IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET)) - (IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET)) - (IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET)) - (IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET)) - (IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET)) - (IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET)) - (IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET)) - (IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET)) - (IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET)) - (IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET)) - (IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET)) - (IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET)) - (IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET)) - (IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET)) - (IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET)) - (IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET)) - (IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET)) - (IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET)) - (IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET)) - (IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET)) - (IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET)) - (IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET)) - (IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET)) - (IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET)) - (IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET)) - (IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET)) - (IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET)) - (IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET)) - (IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET)) - (IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET)) - (IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET)) - (IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET)) - (IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET)) - (IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET)) - (IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET)) - (IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET)) - (IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET)) - (IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET)) - (IRIS.MOUSEBUTTON1 IRIS.BUT100) - (IRIS.MOUSEBUTTON2 IRIS.BUT101) - (IRIS.MOUSEBUTTON3 IRIS.BUT102) - (IRIS.MOUSE1 IRIS.BUT100) - (IRIS.MOUSE2 IRIS.BUT101) - (IRIS.MOUSE3 IRIS.BUT102) - (IRIS.LEFTMOUSEBUTTON IRIS.BUT102) - (IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101) - (IRIS.RIGHTMOUSEBUTTON IRIS.BUT100) - (IRIS.LEFTMOUSE IRIS.BUT102) - (IRIS.MIDDLEMOUSE IRIS.BUT101) - (IRIS.RIGHTMOUSE IRIS.BUT100) - (IRIS.LPENBUT 104)) - (* Switches) - (CONSTANTS (IRIS.SWBASE IRIS.BUT110) - (IRIS.SW0 (IPLUS IRIS.SWBASE 0)) - (IRIS.SW1 (IPLUS IRIS.SWBASE 1)) - (IRIS.SW2 (IPLUS IRIS.SWBASE 2)) - (IRIS.SW3 (IPLUS IRIS.SWBASE 3)) - (IRIS.SW4 (IPLUS IRIS.SWBASE 4)) - (IRIS.SW5 (IPLUS IRIS.SWBASE 5)) - (IRIS.SW6 (IPLUS IRIS.SWBASE 6)) - (IRIS.SW7 (IPLUS IRIS.SWBASE 7)) - (IRIS.SW8 (IPLUS IRIS.SWBASE 8)) - (IRIS.SW9 (IPLUS IRIS.SWBASE 9)) - (IRIS.SW10 (IPLUS IRIS.SWBASE 10)) - (IRIS.SW11 (IPLUS IRIS.SWBASE 11)) - (IRIS.SW12 (IPLUS IRIS.SWBASE 12)) - (IRIS.SW13 (IPLUS IRIS.SWBASE 13)) - (IRIS.SW14 (IPLUS IRIS.SWBASE 14)) - (IRIS.SW15 (IPLUS IRIS.SWBASE 15)) - (IRIS.SW16 (IPLUS IRIS.SWBASE 16)) - (IRIS.SW17 (IPLUS IRIS.SWBASE 17)) - (IRIS.SW18 (IPLUS IRIS.SWBASE 18)) - (IRIS.SW19 (IPLUS IRIS.SWBASE 19)) - (IRIS.SW20 (IPLUS IRIS.SWBASE 20)) - (IRIS.SW21 (IPLUS IRIS.SWBASE 21)) - (IRIS.SW22 (IPLUS IRIS.SWBASE 22)) - (IRIS.SW23 (IPLUS IRIS.SWBASE 23)) - (IRIS.SW24 (IPLUS IRIS.SWBASE 24)) - (IRIS.SW25 (IPLUS IRIS.SWBASE 25)) - (IRIS.SW26 (IPLUS IRIS.SWBASE 26)) - (IRIS.SW27 (IPLUS IRIS.SWBASE 27)) - (IRIS.SW28 (IPLUS IRIS.SWBASE 28)) - (IRIS.SW29 (IPLUS IRIS.SWBASE 29)) - (IRIS.SW30 (IPLUS IRIS.SWBASE 30)) - (IRIS.SW31 (IPLUS IRIS.SWBASE 31))) - (* Keys) - (CONSTANTS (IRIS.AKEY IRIS.BUT10) - (IRIS.BKEY IRIS.BUT35) - (IRIS.CKEY IRIS.BUT27) - (IRIS.DKEY IRIS.BUT17) - (IRIS.EKEY IRIS.BUT16) - (IRIS.FKEY IRIS.BUT18) - (IRIS.GKEY IRIS.BUT25) - (IRIS.HKEY IRIS.BUT26) - (IRIS.IKEY IRIS.BUT39) - (IRIS.JKEY IRIS.BUT33) - (IRIS.KKEY IRIS.BUT34) - (IRIS.LKEY IRIS.BUT41) - (IRIS.MKEY IRIS.BUT43) - (IRIS.NKEY IRIS.BUT36) - (IRIS.OKEY IRIS.BUT40) - (IRIS.PKEY IRIS.BUT47) - (IRIS.QKEY IRIS.BUT9) - (IRIS.RKEY IRIS.BUT23) - (IRIS.SKEY IRIS.BUT11) - (IRIS.TKEY IRIS.BUT24) - (IRIS.UKEY IRIS.BUT32) - (IRIS.VKEY IRIS.BUT28) - (IRIS.WKEY IRIS.BUT15) - (IRIS.XKEY IRIS.BUT20) - (IRIS.YKEY IRIS.BUT32) - (IRIS.ZKEY IRIS.BUT19) - (IRIS.ZEROKEY IRIS.BUT45) - (IRIS.ONEKEY IRIS.BUT7) - (IRIS.TWOKEY IRIS.BUT13) - (IRIS.THREEKEY IRIS.BUT14) - (IRIS.FOURKEY IRIS.BUT21) - (IRIS.FIVCEKEY IRIS.BUT22) - (IRIS.SIXKEY IRIS.BUT29) - (IRIS.SEVENKEY IRIS.BUT30) - (IRIS.EIGHTKEY IRIS.BUT37) - (IRIS.NINIKEY IRIS.BUT38) - (IRIS.BREAKKEY IRIS.BUT0) - (IRIS.SETUPKEY IRIS.BUT1) - (IRIS.CNTRLKEY IRIS.BUT2) - (IRIS.CAPSLOCKKEY IRIS.BUT3) - (IRIS.RIGHTSHIFTKEY IRIS.BUT4) - (IRIS.LEFTSHIFTKEY IRIS.BUT5) - (IRIS.NOSCRLKEY IRIS.BUT12) - (IRIS.ESCKEY IRIS.BUT6) - (IRIS.TABKEY IRIS.BUT8) - (IRIS.RETURNKEY IRIS.BUT50) - (IRIS.SPACEKKEY IRIS.BUT82) - (IRIS.LINEFEEDKEY IRIS.BUT59) - (IRIS.BACKSPACEKEY IRIS.BUT60) - (IRIS.DELETEKEY IRIS.BUT61) - (IRIS.SEMICOLONKEY IRIS.BUT42) - (IRIS.PERIODKEY IRIS.BUT51) - (IRIS.COMMAKEY IRIS.BUT44) - (IRIS.QUOTEKEY IRIS.BUT49) - (IRIS.ACCENTGRAVEKEY IRIS.BUT54) - (IRIS.MINUSKEY IRIS.BUT46) - (IRIS.VIRGULEKEY IRIS.BUT52) - (IRIS.BACKSLASHKEY IRIS.BUT56) - (IRIS.EQUALKEY IRIS.BUT53) - (IRIS.LEFTBRACKETKEY IRIS.BUT48) - (IRIS.RIGHTBRACKETKEY IRIS.BUT55) - (IRIS.LEFTARROWKEY IRIS.BUT72) - (IRIS.DOWNARROWKEY IRIS.BUT73) - (IRIS.UPARROWKEY IRIS.BUT80) - (IRIS.PAD0 IRIS.BUT58) - (IRIS.PAD1 IRIS.BUT57) - (IRIS.PAD2 IRIS.BUT63) - (IRIS.PAD3 IRIS.BUT64) - (IRIS.PAD4 IRIS.BUT62) - (IRIS.PAD5 IRIS.BUT68) - (IRIS.PAD6 IRIS.BUT69) - (IRIS.PAD8 IRIS.BUT67) - (IRIS.PAD9 IRIS.BUT74) - (IRIS.PADPF1 IRIS.BUT71) - (IRIS.PADPF2 IRIS.BUT70) - (IRIS.PADPF3 IRIS.BUT78) - (IRIS.PADPF4 IRIS.BUT77) - (IRIS.PADPERIOD IRIS.BUT65) - (IRIS.PADMINUS IRIS.BUT75) - (IRIS.PADCOMMA IRIS.BUT76) - (IRIS.PADENTER IRIS.BUT81)) - (* Screen buttons) - (CONSTANTS (IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0)) - (IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1)) - (IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2)) - (IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3)) - (IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4)) - (IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5)) - (IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6)) - (IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7)) - (IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8)) - (IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9)) - (IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10)) - (IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11)) - (IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12)) - (IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13)) - (IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14)) - (IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15)) - (IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16))) - (* Valuators) - (CONSTANTS (IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET)) - (IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET)) - (IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET)) - (IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET)) - (IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET)) - (IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET)) - (IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET)) - (IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET)) - (IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET)) - (IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET)) - (IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET)) - (IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET)) - (IRIS.LPENX (PLUS 12 IRIS.VALOFFSET)) - (IRIS.PLENY (PLUS 13 IRIS.VALOFFSET)) - (IRIS.NULLX (PLUS 14 IRIS.VALOFFSET)) - (IRIS.NULLY (PLUS 15 IRIS.VALOFFSET))) - (* Timers) - (CONSTANTS (IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0)) - (IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1)) - (IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2)) - (IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3)) - (IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4)) - (IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5)) - (IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6)) - (IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7))) - (* Misc devices) - (CONSTANTS (IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET)) - (IRIS.CURSORX 526) - (* cursor x pseudo valuator) - (IRIS.CURSORY 527) - (* cursor y pseudo valuator) - (IRIS.VALMARK 523) - (* valuator mark) - (IRIS.GERROR 524) - (* errors device) - (IRIS.REDRAW 528) - (* used by port manager to signal redraws) - (IRIS.WMSEND 529) - (* data in proc's shmem) - (IRIS.WMREPLY 530) - (* reply from port manager) - (IRIS.WMGFCLOSE 531) - (* gf # is no longer being used) - (IRIS.WMTXCLOSE 532) - (* tx # is no longer being used) - (IRIS.MODECHANGE 533) - (* the display mode has changed) - (IRIS.INPUTCHANGE 534) - (* input connected or disconnected) - (IRIS.QFULL 535) - (* queue was filled)) - (* * get.h) - (* Values returned by IRIS.GETBUFFER) - (CONSTANTS (IRIS.NEITHERBUFFER 0) - (IRIS.BACKBUFFER 1) - (IRIS.FRONTBUFFER 2) - (IRIS.BOTHBUFFERS 3) - (IRIS.NOBUFFER 0) - (IRIS.BCKBUFFER 1) - (IRIS.FRNTBUFFER 2)) - (* Values returned by IRIS.GETCMMODE) - (CONSTANTS (IRIS.MULTIMAP 0) - (IRIS.ONEMAP 1) - (IRIS.CMAPMULTI 0) - (IRIS.CMAPONE 1)) - (* Values returned by IRIS.GETDISPLAYMODE) - (CONSTANTS (IRIS.RGBMODE 0) - (IRIS.SINGLEBUFFER 1) - (IRIS.DOUBLEBUFFER 2) - (IRIS.DMRGB 0) - (IRIS.DMSINGLE 1) - (IRIS.DMDOUBLE 2)) - (* Values returned by IRIS.GETDISPLAYMODE) - (CONSTANTS (IRIS.HZ30 0) - (IRIS.HZ60 1) - (IRIS.NTSC 2) - (IRIS.PAL 2) - (IRIS.HZ50 3) - (IRIS.MONA 5) - (IRIS.MONB 6) - (IRIS.MONC 7) - (IRIS.MOND 8) - (IRIS.MONSPECIAL 16)) - (* Individual hit bits returned by IRIS.HITCODE) - (CONSTANTS (IRIS.LEFTPLANE 1) - (IRIS.RIGHTPLANE 2) - (IRIS.BOTTOMPLANE 4) - (IRIS.TOPPLANE 8) - (IRIS.NEARPLANE 16) - (IRIS.FARPLANE 32)) - (* * constants for rotation) - (CONSTANTS (IRIS.XAXIS (CHARCODE X)) - (IRIS.YAXIS (CHARCODE Y)) - (IRIS.ZAXIS (CHARCODE Z))) - (* * Other stuff) - (* Approximate interval between retraces in milliseconds) - (CONSTANTS (IRIS.RETRACEINTERVAL 33.33333]) - (* * gl.h) - - - - -(* Maximum X and Y screen coordinates) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.XMAXSCREEN 1023) - -(RPAQQ IRIS.YMAXSCREEN 767) - -(CONSTANTS (IRIS.XMAXSCREEN 1023) - (IRIS.YMAXSCREEN 767)) -) - - - -(* Various hardware/software limits) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.ATTRIBSTACKDEPTH 10) - -(RPAQQ IRIS.VPSTACKDEPTH 8) - -(RPAQQ IRIS.MATRIXSTACKDEPTH 32) - -(RPAQQ IRIS.STARTTAG -2) - -(RPAQQ IRIS.ENDTAG -3) - -(CONSTANTS (IRIS.ATTRIBSTACKDEPTH 10) - (IRIS.VPSTACKDEPTH 8) - (IRIS.MATRIXSTACKDEPTH 32) - (IRIS.STARTTAG -2) - (IRIS.ENDTAG -3)) -) - - - -(* Name for colors in color map loaded by IRIS.GINIT) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.BACKGROUND 0) - -(RPAQQ IRIS.BLACK 0) - -(RPAQQ IRIS.RED 1) - -(RPAQQ IRIS.GREEN 2) - -(RPAQQ IRIS.YELLOW 3) - -(RPAQQ IRIS.BLUE 4) - -(RPAQQ IRIS.MAGENTA 5) - -(RPAQQ IRIS.CYAN 6) - -(RPAQQ IRIS.WHITE 7) - -(CONSTANTS (IRIS.BACKGROUND 0) - (IRIS.BLACK 0) - (IRIS.RED 1) - (IRIS.GREEN 2) - (IRIS.YELLOW 3) - (IRIS.BLUE 4) - (IRIS.MAGENTA 5) - (IRIS.CYAN 6) - (IRIS.WHITE 7)) -) - (* * device.h) - - - - -(* Macros to test valuator and button numbers) - -(DECLARE: EVAL@COMPILE -[PUTPROPS IRIS.ISBUTTON MACRO ((b) - (AND (GEQ b IRIS.BUTOFFSET) - (LESSP b (PLUS IRIS.BUTCOUNT IRIS.BUTOFFSET] -[PUTPROPS IRIS.ISSCRBUTTON MACRO ((b) - (AND (GEQ b IRIS.SBTOFFSET) - (LESSP b (IPLUS IRIS.SBTCOUNT IRIS.SBTOFFSET] -[PUTPROPS IRIS.ISVALUATOR MACRO ((v) - (AND (GEQ v IRIS.VALOFFSET) - (LESSP v (IPLUS IRIS.VALCOUNT IRIS.VALOFFSET] -[PUTPROPS IRIS.ISTIMER MACRO ((t) - (AND (GEQ t IRIS.TIMOFFSET) - (LESSP t (IPLUS IRIS.TIMCOUNT IRIS.TIMOFFSET] -[PUTPROPS IRIS.ISDIAL MACRO ((t) - (AND (GEQ t IRIS.DIAL0) - (LEQ t IRIS.DIAL8] -[PUTPROPS IRIS.ISLPEN MACRO ((t) - (OR (EQP t IRIS.LPENX) - (EQP t IRIS.LPENY] -(PUTPROPS IRIS.ISLPENBUT MACRO ((t) - (EQP t IRIS.LPENBUT))) -) - - - -(* Include file with device definitions) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.NULLDEV 0) - -(RPAQQ IRIS.BUTOFFSET 1) - -(RPAQQ IRIS.SBTOFFSET 200) - -(RPAQQ IRIS.VALOFFSET 256) - -(RPAQQ IRIS.KEYOFFSET 512) - -(RPAQQ IRIS.TIMOFFSET 515) - -(RPAQQ IRIS.BUTCOUNT 144) - -(RPAQQ IRIS.SBTCOUNT 16) - -(RPAQQ IRIS.VALCOUNT 14) - -(RPAQQ IRIS.TIMCOUNT 8) - -(CONSTANTS (IRIS.NULLDEV 0) - (IRIS.BUTOFFSET 1) - (IRIS.SBTOFFSET 200) - (IRIS.VALOFFSET 256) - (IRIS.KEYOFFSET 512) - (IRIS.TIMOFFSET 515) - (IRIS.BUTCOUNT 144) - (IRIS.SBTCOUNT 16) - (IRIS.VALCOUNT 14) - (IRIS.TIMCOUNT 8)) -) - - - -(* Buttons) - -(DECLARE: EVAL@COMPILE - -(RPAQ IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET)) - -(RPAQ IRIS.MAXKBDBUT IRIS.BUT82) - -(RPAQ IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET)) - -(RPAQ IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET)) - -(RPAQ IRIS.MOUSEBUTTON1 IRIS.BUT100) - -(RPAQ IRIS.MOUSEBUTTON2 IRIS.BUT101) - -(RPAQ IRIS.MOUSEBUTTON3 IRIS.BUT102) - -(RPAQ IRIS.MOUSE1 IRIS.BUT100) - -(RPAQ IRIS.MOUSE2 IRIS.BUT101) - -(RPAQ IRIS.MOUSE3 IRIS.BUT102) - -(RPAQ IRIS.LEFTMOUSEBUTTON IRIS.BUT102) - -(RPAQ IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101) - -(RPAQ IRIS.RIGHTMOUSEBUTTON IRIS.BUT100) - -(RPAQ IRIS.LEFTMOUSE IRIS.BUT102) - -(RPAQ IRIS.MIDDLEMOUSE IRIS.BUT101) - -(RPAQ IRIS.RIGHTMOUSE IRIS.BUT100) - -(RPAQQ IRIS.LPENBUT 104) - -(CONSTANTS (IRIS.BUT0 (IPLUS 0 IRIS.BUTOFFSET)) - (IRIS.BUT1 (IPLUS 1 IRIS.BUTOFFSET)) - (IRIS.BUT2 (IPLUS 2 IRIS.BUTOFFSET)) - (IRIS.BUT3 (IPLUS 3 IRIS.BUTOFFSET)) - (IRIS.BUT4 (IPLUS 4 IRIS.BUTOFFSET)) - (IRIS.BUT5 (IPLUS 5 IRIS.BUTOFFSET)) - (IRIS.BUT6 (IPLUS 6 IRIS.BUTOFFSET)) - (IRIS.BUT7 (IPLUS 7 IRIS.BUTOFFSET)) - (IRIS.BUT8 (IPLUS 8 IRIS.BUTOFFSET)) - (IRIS.BUT9 (IPLUS 9 IRIS.BUTOFFSET)) - (IRIS.BUT10 (IPLUS 10 IRIS.BUTOFFSET)) - (IRIS.BUT11 (IPLUS 11 IRIS.BUTOFFSET)) - (IRIS.BUT12 (IPLUS 12 IRIS.BUTOFFSET)) - (IRIS.BUT13 (IPLUS 13 IRIS.BUTOFFSET)) - (IRIS.BUT14 (IPLUS 14 IRIS.BUTOFFSET)) - (IRIS.BUT15 (IPLUS 15 IRIS.BUTOFFSET)) - (IRIS.BUT16 (IPLUS 16 IRIS.BUTOFFSET)) - (IRIS.BUT17 (IPLUS 17 IRIS.BUTOFFSET)) - (IRIS.BUT18 (IPLUS 18 IRIS.BUTOFFSET)) - (IRIS.BUT19 (IPLUS 19 IRIS.BUTOFFSET)) - (IRIS.BUT20 (IPLUS 20 IRIS.BUTOFFSET)) - (IRIS.BUT21 (IPLUS 21 IRIS.BUTOFFSET)) - (IRIS.BUT22 (IPLUS 22 IRIS.BUTOFFSET)) - (IRIS.BUT23 (IPLUS 23 IRIS.BUTOFFSET)) - (IRIS.BUT24 (IPLUS 24 IRIS.BUTOFFSET)) - (IRIS.BUT25 (IPLUS 25 IRIS.BUTOFFSET)) - (IRIS.BUT26 (IPLUS 26 IRIS.BUTOFFSET)) - (IRIS.BUT27 (IPLUS 27 IRIS.BUTOFFSET)) - (IRIS.BUT28 (IPLUS 28 IRIS.BUTOFFSET)) - (IRIS.BUT29 (IPLUS 29 IRIS.BUTOFFSET)) - (IRIS.BUT30 (IPLUS 30 IRIS.BUTOFFSET)) - (IRIS.BUT31 (IPLUS 31 IRIS.BUTOFFSET)) - (IRIS.BUT32 (IPLUS 32 IRIS.BUTOFFSET)) - (IRIS.BUT33 (IPLUS 33 IRIS.BUTOFFSET)) - (IRIS.BUT34 (IPLUS 34 IRIS.BUTOFFSET)) - (IRIS.BUT35 (IPLUS 35 IRIS.BUTOFFSET)) - (IRIS.BUT36 (IPLUS 36 IRIS.BUTOFFSET)) - (IRIS.BUT37 (IPLUS 37 IRIS.BUTOFFSET)) - (IRIS.BUT38 (IPLUS 38 IRIS.BUTOFFSET)) - (IRIS.BUT39 (IPLUS 39 IRIS.BUTOFFSET)) - (IRIS.BUT40 (IPLUS 40 IRIS.BUTOFFSET)) - (IRIS.BUT41 (IPLUS 41 IRIS.BUTOFFSET)) - (IRIS.BUT42 (IPLUS 42 IRIS.BUTOFFSET)) - (IRIS.BUT43 (IPLUS 43 IRIS.BUTOFFSET)) - (IRIS.BUT44 (IPLUS 44 IRIS.BUTOFFSET)) - (IRIS.BUT45 (IPLUS 45 IRIS.BUTOFFSET)) - (IRIS.BUT46 (IPLUS 46 IRIS.BUTOFFSET)) - (IRIS.BUT47 (IPLUS 47 IRIS.BUTOFFSET)) - (IRIS.BUT48 (IPLUS 48 IRIS.BUTOFFSET)) - (IRIS.BUT49 (IPLUS 49 IRIS.BUTOFFSET)) - (IRIS.BUT50 (IPLUS 50 IRIS.BUTOFFSET)) - (IRIS.BUT51 (IPLUS 51 IRIS.BUTOFFSET)) - (IRIS.BUT52 (IPLUS 52 IRIS.BUTOFFSET)) - (IRIS.BUT53 (IPLUS 53 IRIS.BUTOFFSET)) - (IRIS.BUT54 (IPLUS 54 IRIS.BUTOFFSET)) - (IRIS.BUT55 (IPLUS 55 IRIS.BUTOFFSET)) - (IRIS.BUT56 (IPLUS 56 IRIS.BUTOFFSET)) - (IRIS.BUT57 (IPLUS 57 IRIS.BUTOFFSET)) - (IRIS.BUT58 (IPLUS 58 IRIS.BUTOFFSET)) - (IRIS.BUT59 (IPLUS 59 IRIS.BUTOFFSET)) - (IRIS.BUT60 (IPLUS 60 IRIS.BUTOFFSET)) - (IRIS.BUT61 (IPLUS 61 IRIS.BUTOFFSET)) - (IRIS.BUT62 (IPLUS 62 IRIS.BUTOFFSET)) - (IRIS.BUT63 (IPLUS 63 IRIS.BUTOFFSET)) - (IRIS.BUT64 (IPLUS 64 IRIS.BUTOFFSET)) - (IRIS.BUT65 (IPLUS 65 IRIS.BUTOFFSET)) - (IRIS.BUT66 (IPLUS 66 IRIS.BUTOFFSET)) - (IRIS.BUT67 (IPLUS 67 IRIS.BUTOFFSET)) - (IRIS.BUT68 (IPLUS 68 IRIS.BUTOFFSET)) - (IRIS.BUT69 (IPLUS 69 IRIS.BUTOFFSET)) - (IRIS.BUT70 (IPLUS 70 IRIS.BUTOFFSET)) - (IRIS.BUT71 (IPLUS 71 IRIS.BUTOFFSET)) - (IRIS.BUT72 (IPLUS 72 IRIS.BUTOFFSET)) - (IRIS.BUT73 (IPLUS 73 IRIS.BUTOFFSET)) - (IRIS.BUT74 (IPLUS 74 IRIS.BUTOFFSET)) - (IRIS.BUT75 (IPLUS 75 IRIS.BUTOFFSET)) - (IRIS.BUT76 (IPLUS 76 IRIS.BUTOFFSET)) - (IRIS.BUT77 (IPLUS 77 IRIS.BUTOFFSET)) - (IRIS.BUT78 (IPLUS 78 IRIS.BUTOFFSET)) - (IRIS.BUT79 (IPLUS 79 IRIS.BUTOFFSET)) - (IRIS.BUT80 (IPLUS 80 IRIS.BUTOFFSET)) - (IRIS.BUT81 (IPLUS 81 IRIS.BUTOFFSET)) - (IRIS.BUT82 (IPLUS 82 IRIS.BUTOFFSET)) - (IRIS.MAXKBDBUT IRIS.BUT82) - (IRIS.BUT100 (IPLUS 100 IRIS.BUTOFFSET)) - (IRIS.BUT101 (IPLUS 101 IRIS.BUTOFFSET)) - (IRIS.BUT102 (IPLUS 102 IRIS.BUTOFFSET)) - (IRIS.BUT103 (IPLUS 103 IRIS.BUTOFFSET)) - (IRIS.BUT104 (IPLUS 104 IRIS.BUTOFFSET)) - (IRIS.BUT105 (IPLUS 105 IRIS.BUTOFFSET)) - (IRIS.BUT106 (IPLUS 106 IRIS.BUTOFFSET)) - (IRIS.BUT107 (IPLUS 107 IRIS.BUTOFFSET)) - (IRIS.BUT108 (IPLUS 108 IRIS.BUTOFFSET)) - (IRIS.BUT109 (IPLUS 109 IRIS.BUTOFFSET)) - (IRIS.BUT110 (IPLUS 110 IRIS.BUTOFFSET)) - (IRIS.BUT111 (IPLUS 111 IRIS.BUTOFFSET)) - (IRIS.BUT112 (IPLUS 112 IRIS.BUTOFFSET)) - (IRIS.BUT113 (IPLUS 113 IRIS.BUTOFFSET)) - (IRIS.BUT114 (IPLUS 114 IRIS.BUTOFFSET)) - (IRIS.BUT115 (IPLUS 115 IRIS.BUTOFFSET)) - (IRIS.BUT116 (IPLUS 116 IRIS.BUTOFFSET)) - (IRIS.BUT117 (IPLUS 117 IRIS.BUTOFFSET)) - (IRIS.BUT118 (IPLUS 118 IRIS.BUTOFFSET)) - (IRIS.BUT119 (IPLUS 119 IRIS.BUTOFFSET)) - (IRIS.BUT120 (IPLUS 120 IRIS.BUTOFFSET)) - (IRIS.BUT121 (IPLUS 121 IRIS.BUTOFFSET)) - (IRIS.BUT122 (IPLUS 122 IRIS.BUTOFFSET)) - (IRIS.BUT123 (IPLUS 123 IRIS.BUTOFFSET)) - (IRIS.BUT124 (IPLUS 124 IRIS.BUTOFFSET)) - (IRIS.BUT125 (IPLUS 125 IRIS.BUTOFFSET)) - (IRIS.BUT126 (IPLUS 126 IRIS.BUTOFFSET)) - (IRIS.BUT127 (IPLUS 127 IRIS.BUTOFFSET)) - (IRIS.BUT128 (IPLUS 128 IRIS.BUTOFFSET)) - (IRIS.BUT129 (IPLUS 129 IRIS.BUTOFFSET)) - (IRIS.BUT130 (IPLUS 130 IRIS.BUTOFFSET)) - (IRIS.BUT131 (IPLUS 131 IRIS.BUTOFFSET)) - (IRIS.BUT132 (IPLUS 132 IRIS.BUTOFFSET)) - (IRIS.BUT133 (IPLUS 133 IRIS.BUTOFFSET)) - (IRIS.BUT134 (IPLUS 134 IRIS.BUTOFFSET)) - (IRIS.BUT135 (IPLUS 135 IRIS.BUTOFFSET)) - (IRIS.BUT136 (IPLUS 136 IRIS.BUTOFFSET)) - (IRIS.BUT137 (IPLUS 137 IRIS.BUTOFFSET)) - (IRIS.BUT138 (IPLUS 138 IRIS.BUTOFFSET)) - (IRIS.BUT139 (IPLUS 139 IRIS.BUTOFFSET)) - (IRIS.BUT140 (IPLUS 140 IRIS.BUTOFFSET)) - (IRIS.BUT141 (IPLUS 141 IRIS.BUTOFFSET)) - (IRIS.MOUSEBUTTON1 IRIS.BUT100) - (IRIS.MOUSEBUTTON2 IRIS.BUT101) - (IRIS.MOUSEBUTTON3 IRIS.BUT102) - (IRIS.MOUSE1 IRIS.BUT100) - (IRIS.MOUSE2 IRIS.BUT101) - (IRIS.MOUSE3 IRIS.BUT102) - (IRIS.LEFTMOUSEBUTTON IRIS.BUT102) - (IRIS.MIDDLEMOUSEBUTTON IRIS.BUT101) - (IRIS.RIGHTMOUSEBUTTON IRIS.BUT100) - (IRIS.LEFTMOUSE IRIS.BUT102) - (IRIS.MIDDLEMOUSE IRIS.BUT101) - (IRIS.RIGHTMOUSE IRIS.BUT100) - (IRIS.LPENBUT 104)) -) - - - -(* Switches) - -(DECLARE: EVAL@COMPILE - -(RPAQ IRIS.SWBASE IRIS.BUT110) - -(RPAQ IRIS.SW0 (IPLUS IRIS.SWBASE 0)) - -(RPAQ IRIS.SW1 (IPLUS IRIS.SWBASE 1)) - -(RPAQ IRIS.SW2 (IPLUS IRIS.SWBASE 2)) - -(RPAQ IRIS.SW3 (IPLUS IRIS.SWBASE 3)) - -(RPAQ IRIS.SW4 (IPLUS IRIS.SWBASE 4)) - -(RPAQ IRIS.SW5 (IPLUS IRIS.SWBASE 5)) - -(RPAQ IRIS.SW6 (IPLUS IRIS.SWBASE 6)) - -(RPAQ IRIS.SW7 (IPLUS IRIS.SWBASE 7)) - -(RPAQ IRIS.SW8 (IPLUS IRIS.SWBASE 8)) - -(RPAQ IRIS.SW9 (IPLUS IRIS.SWBASE 9)) - -(RPAQ IRIS.SW10 (IPLUS IRIS.SWBASE 10)) - -(RPAQ IRIS.SW11 (IPLUS IRIS.SWBASE 11)) - -(RPAQ IRIS.SW12 (IPLUS IRIS.SWBASE 12)) - -(RPAQ IRIS.SW13 (IPLUS IRIS.SWBASE 13)) - -(RPAQ IRIS.SW14 (IPLUS IRIS.SWBASE 14)) - -(RPAQ IRIS.SW15 (IPLUS IRIS.SWBASE 15)) - -(RPAQ IRIS.SW16 (IPLUS IRIS.SWBASE 16)) - -(RPAQ IRIS.SW17 (IPLUS IRIS.SWBASE 17)) - -(RPAQ IRIS.SW18 (IPLUS IRIS.SWBASE 18)) - -(RPAQ IRIS.SW19 (IPLUS IRIS.SWBASE 19)) - -(RPAQ IRIS.SW20 (IPLUS IRIS.SWBASE 20)) - -(RPAQ IRIS.SW21 (IPLUS IRIS.SWBASE 21)) - -(RPAQ IRIS.SW22 (IPLUS IRIS.SWBASE 22)) - -(RPAQ IRIS.SW23 (IPLUS IRIS.SWBASE 23)) - -(RPAQ IRIS.SW24 (IPLUS IRIS.SWBASE 24)) - -(RPAQ IRIS.SW25 (IPLUS IRIS.SWBASE 25)) - -(RPAQ IRIS.SW26 (IPLUS IRIS.SWBASE 26)) - -(RPAQ IRIS.SW27 (IPLUS IRIS.SWBASE 27)) - -(RPAQ IRIS.SW28 (IPLUS IRIS.SWBASE 28)) - -(RPAQ IRIS.SW29 (IPLUS IRIS.SWBASE 29)) - -(RPAQ IRIS.SW30 (IPLUS IRIS.SWBASE 30)) - -(RPAQ IRIS.SW31 (IPLUS IRIS.SWBASE 31)) - -(CONSTANTS (IRIS.SWBASE IRIS.BUT110) - (IRIS.SW0 (IPLUS IRIS.SWBASE 0)) - (IRIS.SW1 (IPLUS IRIS.SWBASE 1)) - (IRIS.SW2 (IPLUS IRIS.SWBASE 2)) - (IRIS.SW3 (IPLUS IRIS.SWBASE 3)) - (IRIS.SW4 (IPLUS IRIS.SWBASE 4)) - (IRIS.SW5 (IPLUS IRIS.SWBASE 5)) - (IRIS.SW6 (IPLUS IRIS.SWBASE 6)) - (IRIS.SW7 (IPLUS IRIS.SWBASE 7)) - (IRIS.SW8 (IPLUS IRIS.SWBASE 8)) - (IRIS.SW9 (IPLUS IRIS.SWBASE 9)) - (IRIS.SW10 (IPLUS IRIS.SWBASE 10)) - (IRIS.SW11 (IPLUS IRIS.SWBASE 11)) - (IRIS.SW12 (IPLUS IRIS.SWBASE 12)) - (IRIS.SW13 (IPLUS IRIS.SWBASE 13)) - (IRIS.SW14 (IPLUS IRIS.SWBASE 14)) - (IRIS.SW15 (IPLUS IRIS.SWBASE 15)) - (IRIS.SW16 (IPLUS IRIS.SWBASE 16)) - (IRIS.SW17 (IPLUS IRIS.SWBASE 17)) - (IRIS.SW18 (IPLUS IRIS.SWBASE 18)) - (IRIS.SW19 (IPLUS IRIS.SWBASE 19)) - (IRIS.SW20 (IPLUS IRIS.SWBASE 20)) - (IRIS.SW21 (IPLUS IRIS.SWBASE 21)) - (IRIS.SW22 (IPLUS IRIS.SWBASE 22)) - (IRIS.SW23 (IPLUS IRIS.SWBASE 23)) - (IRIS.SW24 (IPLUS IRIS.SWBASE 24)) - (IRIS.SW25 (IPLUS IRIS.SWBASE 25)) - (IRIS.SW26 (IPLUS IRIS.SWBASE 26)) - (IRIS.SW27 (IPLUS IRIS.SWBASE 27)) - (IRIS.SW28 (IPLUS IRIS.SWBASE 28)) - (IRIS.SW29 (IPLUS IRIS.SWBASE 29)) - (IRIS.SW30 (IPLUS IRIS.SWBASE 30)) - (IRIS.SW31 (IPLUS IRIS.SWBASE 31))) -) - - - -(* Keys) - -(DECLARE: EVAL@COMPILE - -(RPAQ IRIS.AKEY IRIS.BUT10) - -(RPAQ IRIS.BKEY IRIS.BUT35) - -(RPAQ IRIS.CKEY IRIS.BUT27) - -(RPAQ IRIS.DKEY IRIS.BUT17) - -(RPAQ IRIS.EKEY IRIS.BUT16) - -(RPAQ IRIS.FKEY IRIS.BUT18) - -(RPAQ IRIS.GKEY IRIS.BUT25) - -(RPAQ IRIS.HKEY IRIS.BUT26) - -(RPAQ IRIS.IKEY IRIS.BUT39) - -(RPAQ IRIS.JKEY IRIS.BUT33) - -(RPAQ IRIS.KKEY IRIS.BUT34) - -(RPAQ IRIS.LKEY IRIS.BUT41) - -(RPAQ IRIS.MKEY IRIS.BUT43) - -(RPAQ IRIS.NKEY IRIS.BUT36) - -(RPAQ IRIS.OKEY IRIS.BUT40) - -(RPAQ IRIS.PKEY IRIS.BUT47) - -(RPAQ IRIS.QKEY IRIS.BUT9) - -(RPAQ IRIS.RKEY IRIS.BUT23) - -(RPAQ IRIS.SKEY IRIS.BUT11) - -(RPAQ IRIS.TKEY IRIS.BUT24) - -(RPAQ IRIS.UKEY IRIS.BUT32) - -(RPAQ IRIS.VKEY IRIS.BUT28) - -(RPAQ IRIS.WKEY IRIS.BUT15) - -(RPAQ IRIS.XKEY IRIS.BUT20) - -(RPAQ IRIS.YKEY IRIS.BUT32) - -(RPAQ IRIS.ZKEY IRIS.BUT19) - -(RPAQ IRIS.ZEROKEY IRIS.BUT45) - -(RPAQ IRIS.ONEKEY IRIS.BUT7) - -(RPAQ IRIS.TWOKEY IRIS.BUT13) - -(RPAQ IRIS.THREEKEY IRIS.BUT14) - -(RPAQ IRIS.FOURKEY IRIS.BUT21) - -(RPAQ IRIS.FIVCEKEY IRIS.BUT22) - -(RPAQ IRIS.SIXKEY IRIS.BUT29) - -(RPAQ IRIS.SEVENKEY IRIS.BUT30) - -(RPAQ IRIS.EIGHTKEY IRIS.BUT37) - -(RPAQ IRIS.NINIKEY IRIS.BUT38) - -(RPAQ IRIS.BREAKKEY IRIS.BUT0) - -(RPAQ IRIS.SETUPKEY IRIS.BUT1) - -(RPAQ IRIS.CNTRLKEY IRIS.BUT2) - -(RPAQ IRIS.CAPSLOCKKEY IRIS.BUT3) - -(RPAQ IRIS.RIGHTSHIFTKEY IRIS.BUT4) - -(RPAQ IRIS.LEFTSHIFTKEY IRIS.BUT5) - -(RPAQ IRIS.NOSCRLKEY IRIS.BUT12) - -(RPAQ IRIS.ESCKEY IRIS.BUT6) - -(RPAQ IRIS.TABKEY IRIS.BUT8) - -(RPAQ IRIS.RETURNKEY IRIS.BUT50) - -(RPAQ IRIS.SPACEKKEY IRIS.BUT82) - -(RPAQ IRIS.LINEFEEDKEY IRIS.BUT59) - -(RPAQ IRIS.BACKSPACEKEY IRIS.BUT60) - -(RPAQ IRIS.DELETEKEY IRIS.BUT61) - -(RPAQ IRIS.SEMICOLONKEY IRIS.BUT42) - -(RPAQ IRIS.PERIODKEY IRIS.BUT51) - -(RPAQ IRIS.COMMAKEY IRIS.BUT44) - -(RPAQ IRIS.QUOTEKEY IRIS.BUT49) - -(RPAQ IRIS.ACCENTGRAVEKEY IRIS.BUT54) - -(RPAQ IRIS.MINUSKEY IRIS.BUT46) - -(RPAQ IRIS.VIRGULEKEY IRIS.BUT52) - -(RPAQ IRIS.BACKSLASHKEY IRIS.BUT56) - -(RPAQ IRIS.EQUALKEY IRIS.BUT53) - -(RPAQ IRIS.LEFTBRACKETKEY IRIS.BUT48) - -(RPAQ IRIS.RIGHTBRACKETKEY IRIS.BUT55) - -(RPAQ IRIS.LEFTARROWKEY IRIS.BUT72) - -(RPAQ IRIS.DOWNARROWKEY IRIS.BUT73) - -(RPAQ IRIS.UPARROWKEY IRIS.BUT80) - -(RPAQ IRIS.PAD0 IRIS.BUT58) - -(RPAQ IRIS.PAD1 IRIS.BUT57) - -(RPAQ IRIS.PAD2 IRIS.BUT63) - -(RPAQ IRIS.PAD3 IRIS.BUT64) - -(RPAQ IRIS.PAD4 IRIS.BUT62) - -(RPAQ IRIS.PAD5 IRIS.BUT68) - -(RPAQ IRIS.PAD6 IRIS.BUT69) - -(RPAQ IRIS.PAD8 IRIS.BUT67) - -(RPAQ IRIS.PAD9 IRIS.BUT74) - -(RPAQ IRIS.PADPF1 IRIS.BUT71) - -(RPAQ IRIS.PADPF2 IRIS.BUT70) - -(RPAQ IRIS.PADPF3 IRIS.BUT78) - -(RPAQ IRIS.PADPF4 IRIS.BUT77) - -(RPAQ IRIS.PADPERIOD IRIS.BUT65) - -(RPAQ IRIS.PADMINUS IRIS.BUT75) - -(RPAQ IRIS.PADCOMMA IRIS.BUT76) - -(RPAQ IRIS.PADENTER IRIS.BUT81) - -(CONSTANTS (IRIS.AKEY IRIS.BUT10) - (IRIS.BKEY IRIS.BUT35) - (IRIS.CKEY IRIS.BUT27) - (IRIS.DKEY IRIS.BUT17) - (IRIS.EKEY IRIS.BUT16) - (IRIS.FKEY IRIS.BUT18) - (IRIS.GKEY IRIS.BUT25) - (IRIS.HKEY IRIS.BUT26) - (IRIS.IKEY IRIS.BUT39) - (IRIS.JKEY IRIS.BUT33) - (IRIS.KKEY IRIS.BUT34) - (IRIS.LKEY IRIS.BUT41) - (IRIS.MKEY IRIS.BUT43) - (IRIS.NKEY IRIS.BUT36) - (IRIS.OKEY IRIS.BUT40) - (IRIS.PKEY IRIS.BUT47) - (IRIS.QKEY IRIS.BUT9) - (IRIS.RKEY IRIS.BUT23) - (IRIS.SKEY IRIS.BUT11) - (IRIS.TKEY IRIS.BUT24) - (IRIS.UKEY IRIS.BUT32) - (IRIS.VKEY IRIS.BUT28) - (IRIS.WKEY IRIS.BUT15) - (IRIS.XKEY IRIS.BUT20) - (IRIS.YKEY IRIS.BUT32) - (IRIS.ZKEY IRIS.BUT19) - (IRIS.ZEROKEY IRIS.BUT45) - (IRIS.ONEKEY IRIS.BUT7) - (IRIS.TWOKEY IRIS.BUT13) - (IRIS.THREEKEY IRIS.BUT14) - (IRIS.FOURKEY IRIS.BUT21) - (IRIS.FIVCEKEY IRIS.BUT22) - (IRIS.SIXKEY IRIS.BUT29) - (IRIS.SEVENKEY IRIS.BUT30) - (IRIS.EIGHTKEY IRIS.BUT37) - (IRIS.NINIKEY IRIS.BUT38) - (IRIS.BREAKKEY IRIS.BUT0) - (IRIS.SETUPKEY IRIS.BUT1) - (IRIS.CNTRLKEY IRIS.BUT2) - (IRIS.CAPSLOCKKEY IRIS.BUT3) - (IRIS.RIGHTSHIFTKEY IRIS.BUT4) - (IRIS.LEFTSHIFTKEY IRIS.BUT5) - (IRIS.NOSCRLKEY IRIS.BUT12) - (IRIS.ESCKEY IRIS.BUT6) - (IRIS.TABKEY IRIS.BUT8) - (IRIS.RETURNKEY IRIS.BUT50) - (IRIS.SPACEKKEY IRIS.BUT82) - (IRIS.LINEFEEDKEY IRIS.BUT59) - (IRIS.BACKSPACEKEY IRIS.BUT60) - (IRIS.DELETEKEY IRIS.BUT61) - (IRIS.SEMICOLONKEY IRIS.BUT42) - (IRIS.PERIODKEY IRIS.BUT51) - (IRIS.COMMAKEY IRIS.BUT44) - (IRIS.QUOTEKEY IRIS.BUT49) - (IRIS.ACCENTGRAVEKEY IRIS.BUT54) - (IRIS.MINUSKEY IRIS.BUT46) - (IRIS.VIRGULEKEY IRIS.BUT52) - (IRIS.BACKSLASHKEY IRIS.BUT56) - (IRIS.EQUALKEY IRIS.BUT53) - (IRIS.LEFTBRACKETKEY IRIS.BUT48) - (IRIS.RIGHTBRACKETKEY IRIS.BUT55) - (IRIS.LEFTARROWKEY IRIS.BUT72) - (IRIS.DOWNARROWKEY IRIS.BUT73) - (IRIS.UPARROWKEY IRIS.BUT80) - (IRIS.PAD0 IRIS.BUT58) - (IRIS.PAD1 IRIS.BUT57) - (IRIS.PAD2 IRIS.BUT63) - (IRIS.PAD3 IRIS.BUT64) - (IRIS.PAD4 IRIS.BUT62) - (IRIS.PAD5 IRIS.BUT68) - (IRIS.PAD6 IRIS.BUT69) - (IRIS.PAD8 IRIS.BUT67) - (IRIS.PAD9 IRIS.BUT74) - (IRIS.PADPF1 IRIS.BUT71) - (IRIS.PADPF2 IRIS.BUT70) - (IRIS.PADPF3 IRIS.BUT78) - (IRIS.PADPF4 IRIS.BUT77) - (IRIS.PADPERIOD IRIS.BUT65) - (IRIS.PADMINUS IRIS.BUT75) - (IRIS.PADCOMMA IRIS.BUT76) - (IRIS.PADENTER IRIS.BUT81)) -) - - - -(* Screen buttons) - -(DECLARE: EVAL@COMPILE - -(RPAQ IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0)) - -(RPAQ IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1)) - -(RPAQ IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2)) - -(RPAQ IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3)) - -(RPAQ IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4)) - -(RPAQ IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5)) - -(RPAQ IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6)) - -(RPAQ IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7)) - -(RPAQ IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8)) - -(RPAQ IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9)) - -(RPAQ IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10)) - -(RPAQ IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11)) - -(RPAQ IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12)) - -(RPAQ IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13)) - -(RPAQ IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14)) - -(RPAQ IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15)) - -(RPAQ IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16)) - -(CONSTANTS (IRIS.SCRBUT0 (IPLUS IRIS.SBTOFFSET 0)) - (IRIS.SCRBUT1 (IPLUS IRIS.SBTOFFSET 1)) - (IRIS.SCRBUT2 (IPLUS IRIS.SBTOFFSET 2)) - (IRIS.SCRBUT3 (IPLUS IRIS.SBTOFFSET 3)) - (IRIS.SCRBUT4 (IPLUS IRIS.SBTOFFSET 4)) - (IRIS.SCRBUT5 (IPLUS IRIS.SBTOFFSET 5)) - (IRIS.SCRBUT6 (IPLUS IRIS.SBTOFFSET 6)) - (IRIS.SCRBUT7 (IPLUS IRIS.SBTOFFSET 7)) - (IRIS.SCRBUT8 (IPLUS IRIS.SBTOFFSET 8)) - (IRIS.SCRBUT9 (IPLUS IRIS.SBTOFFSET 9)) - (IRIS.SCRBUT10 (IPLUS IRIS.SBTOFFSET 10)) - (IRIS.SCRBUT11 (IPLUS IRIS.SBTOFFSET 11)) - (IRIS.SCRBUT12 (IPLUS IRIS.SBTOFFSET 12)) - (IRIS.SCRBUT13 (IPLUS IRIS.SBTOFFSET 13)) - (IRIS.SCRBUT14 (IPLUS IRIS.SBTOFFSET 14)) - (IRIS.SCRBUT15 (IPLUS IRIS.SBTOFFSET 15)) - (IRIS.SCRBUT16 (IPLUS IRIS.SBTOFFSET 16))) -) - - - -(* Valuators) - -(DECLARE: EVAL@COMPILE - -(RPAQ IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET)) - -(RPAQ IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET)) - -(RPAQ IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET)) - -(RPAQ IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET)) - -(RPAQ IRIS.LPENX (PLUS 12 IRIS.VALOFFSET)) - -(RPAQ IRIS.PLENY (PLUS 13 IRIS.VALOFFSET)) - -(RPAQ IRIS.NULLX (PLUS 14 IRIS.VALOFFSET)) - -(RPAQ IRIS.NULLY (PLUS 15 IRIS.VALOFFSET)) - -(CONSTANTS (IRIS.SGIRESERVED (IPLUS 0 IRIS.VALOFFSET)) - (IRIS.DIAL0 (PLUS 1 IRIS.VALOFFSET)) - (IRIS.DIAL1 (PLUS 2 IRIS.VALOFFSET)) - (IRIS.DIAL2 (PLUS 3 IRIS.VALOFFSET)) - (IRIS.DIAL3 (PLUS 4 IRIS.VALOFFSET)) - (IRIS.DIAL4 (PLUS 5 IRIS.VALOFFSET)) - (IRIS.DIAL5 (PLUS 6 IRIS.VALOFFSET)) - (IRIS.DIAL6 (PLUS 7 IRIS.VALOFFSET)) - (IRIS.DIAL7 (PLUS 8 IRIS.VALOFFSET)) - (IRIS.DIAL8 (PLUS 9 IRIS.VALOFFSET)) - (IRIS.MOUSEX (PLUS 10 IRIS.VALOFFSET)) - (IRIS.MOUSEY (PLUS 11 IRIS.VALOFFSET)) - (IRIS.LPENX (PLUS 12 IRIS.VALOFFSET)) - (IRIS.PLENY (PLUS 13 IRIS.VALOFFSET)) - (IRIS.NULLX (PLUS 14 IRIS.VALOFFSET)) - (IRIS.NULLY (PLUS 15 IRIS.VALOFFSET))) -) - - - -(* Timers) - -(DECLARE: EVAL@COMPILE - -(RPAQ IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0)) - -(RPAQ IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1)) - -(RPAQ IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2)) - -(RPAQ IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3)) - -(RPAQ IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4)) - -(RPAQ IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5)) - -(RPAQ IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6)) - -(RPAQ IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7)) - -(CONSTANTS (IRIS.TIMER0 (IPLUS IRIS.TIMOFFSET 0)) - (IRIS.TIMER1 (IPLUS IRIS.TIMOFFSET 1)) - (IRIS.TIMER2 (IPLUS IRIS.TIMOFFSET 2)) - (IRIS.TIMER3 (IPLUS IRIS.TIMOFFSET 3)) - (IRIS.TIMER4 (IPLUS IRIS.TIMOFFSET 4)) - (IRIS.TIMER5 (IPLUS IRIS.TIMOFFSET 5)) - (IRIS.TIMER6 (IPLUS IRIS.TIMOFFSET 6)) - (IRIS.TIMER7 (IPLUS IRIS.TIMOFFSET 7))) -) - - - -(* Misc devices) - -(DECLARE: EVAL@COMPILE - -(RPAQ IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET)) - -(RPAQQ IRIS.CURSORX 526) - -(RPAQQ IRIS.CURSORY 527) - -(RPAQQ IRIS.VALMARK 523) - -(RPAQQ IRIS.GERROR 524) - -(RPAQQ IRIS.REDRAW 528) - -(RPAQQ IRIS.WMSEND 529) - -(RPAQQ IRIS.WMREPLY 530) - -(RPAQQ IRIS.WMGFCLOSE 531) - -(RPAQQ IRIS.WMTXCLOSE 532) - -(RPAQQ IRIS.MODECHANGE 533) - -(RPAQQ IRIS.INPUTCHANGE 534) - -(RPAQQ IRIS.QFULL 535) - -(CONSTANTS (IRIS.KEYBD (IPLUS 1 IRIS.KEYOFFSET)) - (IRIS.CURSORX 526) - (IRIS.CURSORY 527) - (IRIS.VALMARK 523) - (IRIS.GERROR 524) - (IRIS.REDRAW 528) - (IRIS.WMSEND 529) - (IRIS.WMREPLY 530) - (IRIS.WMGFCLOSE 531) - (IRIS.WMTXCLOSE 532) - (IRIS.MODECHANGE 533) - (IRIS.INPUTCHANGE 534) - (IRIS.QFULL 535)) -) - (* * get.h) - - - - -(* Values returned by IRIS.GETBUFFER) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.NEITHERBUFFER 0) - -(RPAQQ IRIS.BACKBUFFER 1) - -(RPAQQ IRIS.FRONTBUFFER 2) - -(RPAQQ IRIS.BOTHBUFFERS 3) - -(RPAQQ IRIS.NOBUFFER 0) - -(RPAQQ IRIS.BCKBUFFER 1) - -(RPAQQ IRIS.FRNTBUFFER 2) - -(CONSTANTS (IRIS.NEITHERBUFFER 0) - (IRIS.BACKBUFFER 1) - (IRIS.FRONTBUFFER 2) - (IRIS.BOTHBUFFERS 3) - (IRIS.NOBUFFER 0) - (IRIS.BCKBUFFER 1) - (IRIS.FRNTBUFFER 2)) -) - - - -(* Values returned by IRIS.GETCMMODE) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.MULTIMAP 0) - -(RPAQQ IRIS.ONEMAP 1) - -(RPAQQ IRIS.CMAPMULTI 0) - -(RPAQQ IRIS.CMAPONE 1) - -(CONSTANTS (IRIS.MULTIMAP 0) - (IRIS.ONEMAP 1) - (IRIS.CMAPMULTI 0) - (IRIS.CMAPONE 1)) -) - - - -(* Values returned by IRIS.GETDISPLAYMODE) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.RGBMODE 0) - -(RPAQQ IRIS.SINGLEBUFFER 1) - -(RPAQQ IRIS.DOUBLEBUFFER 2) - -(RPAQQ IRIS.DMRGB 0) - -(RPAQQ IRIS.DMSINGLE 1) - -(RPAQQ IRIS.DMDOUBLE 2) - -(CONSTANTS (IRIS.RGBMODE 0) - (IRIS.SINGLEBUFFER 1) - (IRIS.DOUBLEBUFFER 2) - (IRIS.DMRGB 0) - (IRIS.DMSINGLE 1) - (IRIS.DMDOUBLE 2)) -) - - - -(* Values returned by IRIS.GETDISPLAYMODE) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.HZ30 0) - -(RPAQQ IRIS.HZ60 1) - -(RPAQQ IRIS.NTSC 2) - -(RPAQQ IRIS.PAL 2) - -(RPAQQ IRIS.HZ50 3) - -(RPAQQ IRIS.MONA 5) - -(RPAQQ IRIS.MONB 6) - -(RPAQQ IRIS.MONC 7) - -(RPAQQ IRIS.MOND 8) - -(RPAQQ IRIS.MONSPECIAL 16) - -(CONSTANTS (IRIS.HZ30 0) - (IRIS.HZ60 1) - (IRIS.NTSC 2) - (IRIS.PAL 2) - (IRIS.HZ50 3) - (IRIS.MONA 5) - (IRIS.MONB 6) - (IRIS.MONC 7) - (IRIS.MOND 8) - (IRIS.MONSPECIAL 16)) -) - - - -(* Individual hit bits returned by IRIS.HITCODE) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.LEFTPLANE 1) - -(RPAQQ IRIS.RIGHTPLANE 2) - -(RPAQQ IRIS.BOTTOMPLANE 4) - -(RPAQQ IRIS.TOPPLANE 8) - -(RPAQQ IRIS.NEARPLANE 16) - -(RPAQQ IRIS.FARPLANE 32) - -(CONSTANTS (IRIS.LEFTPLANE 1) - (IRIS.RIGHTPLANE 2) - (IRIS.BOTTOMPLANE 4) - (IRIS.TOPPLANE 8) - (IRIS.NEARPLANE 16) - (IRIS.FARPLANE 32)) -) - (* * constants for rotation) - -(DECLARE: EVAL@COMPILE - -(RPAQ IRIS.XAXIS (CHARCODE X)) - -(RPAQ IRIS.YAXIS (CHARCODE Y)) - -(RPAQ IRIS.ZAXIS (CHARCODE Z)) - -(CONSTANTS (IRIS.XAXIS (CHARCODE X)) - (IRIS.YAXIS (CHARCODE Y)) - (IRIS.ZAXIS (CHARCODE Z))) -) - (* * Other stuff) - - - - -(* Approximate interval between retraces in milliseconds) - -(DECLARE: EVAL@COMPILE - -(RPAQQ IRIS.RETRACEINTERVAL 33.33333) - -(CONSTANTS (IRIS.RETRACEINTERVAL 33.33333)) -) -(PUTPROPS IRISCONSTANTS COPYRIGHT ("Xerox Corporation" 1985)) -(DECLARE: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/lispusers/IRISDEMOFNS b/obsolete/lispusers/IRISDEMOFNS deleted file mode 100644 index ed1509c0..00000000 --- a/obsolete/lispusers/IRISDEMOFNS +++ /dev/null @@ -1,469 +0,0 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED " 2-Feb-87 21:13:01" {ERIS}NEXT>IRISDEMOFNS.;10 21478 - - changes to%: (VARS IRISDEMOFNSCOMS) - (FNS TETRA TETRA.DRAW.FACE TETRA.OBJ) - - previous date%: " 4-Mar-86 10:57:38" {ERIS}NEXT>IRISDEMOFNS.;8) - - -(PRETTYCOMPRINT IRISDEMOFNSCOMS) - -(RPAQQ IRISDEMOFNSCOMS [(FNS IRIS.DEGREES SNOW SPHERE TETRA TETRA.COLOR TETRA.DRAW.FACE TETRA.OBJ - TETRA.TILT.AND.RECURSE) - (VARS IRIS.TILT TETRA.COLOR TETRA.EDGE.COLOR TETRA.SHRINK TETRA.TILT - IV.DEFAULT.STYLE) - - - (* ;; "minimal 3-d support for the tetra demo") - - (RECORDS 3POINT) - (FNS 3DOT 3DRAWTO 3MOVETO 3NORMALIZE 3PLUS 3POINT 3UNITCROSSPRODUCT - 3DIFFERENCE 3CROSSPRODUCT 3LENGTH 3LINE 3TIMES DRAW.FACE? IRIS.XLATE) - (VARS \IRIS.DUMMYBUFFER \IRIS.FEEDBACKBUFFER) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - (ADDVARS (NLAMA) - (NLAML) - (LAMA TETRA]) -(DEFINEQ - -(IRIS.DEGREES - [LAMBDA (DEGREES) (* edited%: "13-Dec-85 18:32") - - (* Takes an angle in degrees and returns an angle as the iris likes it - (tenths)) - - (FIX (TIMES DEGREES 10]) - -(SNOW - [LAMBDA (N) (* edited%: "11-Dec-85 23:12") - (for I to (OR N (RAND 5 20)) do (IRIS.PUSHMATRIX) - (IRIS.TRANSLATE (RAND 0 SCREENWIDTH) - (RAND 0 SCREENHEIGHT) - 0 \IRISSTREAM) - (IRIS.ROTATE (RAND 0 1800) - 88) - (IRIS.ROTATE (RAND 0 1800) - 89) - (IRIS.ROTATE (RAND 0 1800) - 90) - (IRIS.SCALE (RAND 0.1 1) - (RAND 0.1 1) - (RAND 0.1 1)) - (SPHERE " Noel" (RAND 5 90) - (RAND 1 3)) - (IRIS.POPMATRIX]) - -(SPHERE - [LAMBDA (MSG THETA COUNT) (* edited%: "11-Dec-85 15:24") - (IRIS.PUSHMATRIX) - (OR THETA (SETQ THETA 30)) - (OR COUNT (SETQ COUNT 3)) - (DSPCOLOR 'RED \IRISSTREAM) - (IRIS.PUSHMATRIX) - (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM) - (DSPCOLOR (IMOD I 7) - \IRISSTREAM) - (IRIS.ROTATE (ITIMES 10 THETA) - IRIS.ZAXIS) - (PRINTOUT \IRISSTREAM MSG)) - (IRIS.POPMATRIX) - (IRIS.PUSHMATRIX) - (IRIS.ROTATE 900 IRIS.YAXIS) - (DSPCOLOR 'BLACK \IRISSTREAM) - (SELECTQ COUNT - (1 NIL) - (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM) - (DSPCOLOR (IMOD I 7) - \IRISSTREAM) - (IRIS.ROTATE (ITIMES 10 THETA) - IRIS.ZAXIS) - (PRINTOUT \IRISSTREAM MSG))) - (IRIS.POPMATRIX) - (DSPCOLOR 'CYAN \IRISSTREAM) - (IRIS.ROTATE 900 IRIS.XAXIS) - (SELECTQ COUNT - ((1 2) - NIL) - (for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM) - (DSPCOLOR (IMOD I 7) - \IRISSTREAM) - (IRIS.ROTATE (ITIMES 10 THETA) - IRIS.ZAXIS) - (PRINTOUT \IRISSTREAM MSG))) - (IRIS.POPMATRIX]) - -(TETRA - [CL:LAMBDA (&OPTIONAL (SIDE-LENGTH 200) - (RECURSIVE-DEPTH 3) - (SHRINK-FACTOR TETRA.SHRINK) - (STYLE 'WIREFRAME) - (DONTBASERECURSE NIL)) (* ; "Edited 31-Jan-87 17:29 by gbn") - -(* ;;; "Draws a recursive tetrahedron. shrinkfactor is the ratio of side length of parent and child. style is one of 'wireframe, polygon or normal.") - - (LET ((RECURSIVE-DEPTH (OR RECURSIVE-DEPTH 5)) - (SHRINK-FACTOR (OR SHRINK-FACTOR TETRA.SHRINK)) - (STYLE (OR STYLE IV.DEFAULT.STYLE))) - (if (EQ 0 RECURSIVE-DEPTH) - then (* ; "done") - NIL - else (TETRA.OBJ SIDE-LENGTH (TETRA.COLOR RECURSIVE-DEPTH) - STYLE DONTBASERECURSE) - (if (NOT DONTBASERECURSE) - then (IRIS.PUSHMATRIX) - (IRIS.ROTATE (IRIS.DEGREES 180) - IRIS.YAXIS) - (IRIS.ROTATE (IRIS.DEGREES (MINUS TETRA.TILT)) - IRIS.XAXIS) - (IRIS.TRANSLATE 0 (QUOTIENT SIDE-LENGTH (SQRT 3)) - 0) - (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE - ) - (IRIS.POPMATRIX)) - (IRIS.PUSHMATRIX) - (IRIS.TRANSLATE 0 (QUOTIENT SIDE-LENGTH (SQRT 3)) - 0) (* ; - "move the origin to the middle of the base of the tetrahedron") - (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE) - (IRIS.ROTATE (IRIS.DEGREES 120) - IRIS.ZAXIS) - (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE) - (IRIS.ROTATE (IRIS.DEGREES 120) - IRIS.ZAXIS) - (TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE) - - (* ;; "(IRIS.TRANSLATE 0 (MINUS (QUOTIENT X (SQRT 3))) 0) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.XAXIS) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.ZAXIS) (TETRA.TILT.AND.RECURSE X RECDEPTH)") - - (IRIS.POPMATRIX]) - -(TETRA.COLOR - [LAMBDA (COLOR) (* gbn "21-Feb-86 17:11") - (IMOD COLOR 8]) - -(TETRA.DRAW.FACE - [LAMBDA (STYLE COLOR LEFT RIGHT TOP) (* ; "Edited 31-Jan-87 18:44 by gbn") - - (* ;; "handles drawing a single face. Left right and top are just logical names for the points of the triangle. They need not correspond to Tetra's interpretation of those names.") - - (SELECTQ STYLE - (WIREFRAME) - ((POLYGON NORMALS BACKFACES) - (if (NOT DONTBASERECURSE) - then (IRIS.POLF 3 (LIST LEFT RIGHT FRONT))) - (DSPCOLOR COLOR \IRISSTREAM) - (IRIS.POLF 3 (LIST LEFT RIGHT TOP)) (* ; - "(IRIS.POLF 3 (LIST FRONT RIGHT TOP)) (IRIS.POLF 3 (LIST FRONT LEFT TOP))") - (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM) - (3MOVETO \IRISSTREAM LEFT) - (3DRAWTO \IRISSTREAM RIGHT) - (3DRAWTO \IRISSTREAM TOP) - (3DRAWTO \IRISSTREAM LEFT) - (SELECTQ STYLE - (POLYGON) - (NORMALS (* ; - "compute and draw a normal to the face") - [LET* ((LEFTTOP (3DIFFERENCE TOP LEFT)) - (LEFTRIGHT (3DIFFERENCE RIGHT LEFT)) - (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT)) - (NORMAL (3DIFFERENCE NORMALENDPT LEFT))) - (3LINE LEFT (3PLUS LEFT (3TIMES (3NORMALIZE NORMAL) - 50]) - (BACKFACES (* ; - "compute and draw a normal to the face") - (LET* ((LEFTTOP (3DIFFERENCE TOP LEFT)) - (LEFTRIGHT (3DIFFERENCE RIGHT LEFT)) - (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT)) - (NORMAL (3DIFFERENCE NORMALENDPT LEFT)) - (EYEVECTOR (3DIFFERENCE (IRIS.XLATE IV.VIEWPT) - LEFT))) - (if (LESSP (3DOT EYEVECTOR NORMAL) - 0.0) - then (* ; "this is not a backface so drawit") - (DSPCOLOR COLOR \IRISSTREAM) - (IRIS.POLF 3 (LIST LEFT RIGHT TOP)) - (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM) - (3MOVETO \IRISSTREAM LEFT) - (3DRAWTO \IRISSTREAM RIGHT) - (3DRAWTO \IRISSTREAM TOP) - (3DRAWTO \IRISSTREAM LEFT)))) - (ERROR "Unknown drawing style: " STYLE))) - (ERROR "Unknown drawing style: " STYLE]) - -(TETRA.OBJ - [LAMBDA (X COLOR STYLE DONTBASERECURSE) (* ; "Edited 31-Jan-87 17:35 by gbn") - -(* ;;; "The function that draws a single tetrahedron (and optionally, it's faces.)") - - (LET ([TOP (3POINT 0 (QUOTIENT X (SQRT 3)) - (SQRT (TIMES (TIMES X X) - (QUOTIENT 8 3.0] - (LEFT (3POINT (MINUS X) - 0 0)) - (RIGHT (3POINT X 0 0)) - (FRONT (3POINT 0 (TIMES (SQRT 3) - X) - 0))) - (IRIS.PUSHATTRIBUTES) - (SELECTQ STYLE - (WIREFRAME (DSPCOLOR COLOR \IRISSTREAM) - (3MOVETO \IRISSTREAM LEFT) - (3DRAWTO \IRISSTREAM RIGHT) - (3DRAWTO \IRISSTREAM FRONT) - (3DRAWTO \IRISSTREAM LEFT) - (3DRAWTO \IRISSTREAM TOP) - (3DRAWTO \IRISSTREAM RIGHT) - (3MOVETO \IRISSTREAM FRONT) - (3DRAWTO \IRISSTREAM TOP)) - ((POLYGON NORMALS BACKFACES) - (DSPCOLOR COLOR \IRISSTREAM) - (if (NOT DONTBASERECURSE) - then (TETRA.DRAW.FACE STYLE COLOR LEFT RIGHT FRONT)) - (TETRA.DRAW.FACE STYLE COLOR LEFT RIGHT TOP) - (TETRA.DRAW.FACE STYLE COLOR RIGHT FRONT TOP) - (TETRA.DRAW.FACE STYLE COLOR FRONT LEFT TOP)) - (ERROR "Unknown drawing style: " STYLE)) - (IRIS.POPATTRIBUTES]) - -(TETRA.TILT.AND.RECURSE - [LAMBDA (X RECDEPTH SHRINKFACTOR STYLE) (* edited%: "16-Dec-85 17:41") - - (* * sets up the transformations to recurse, and calls tetra) - - (* * called with 0 0 0 already placed at the "bottom edge" on the face of the - larger tetra) - - (* BOTTOMY is the y component of the point BOTTOM, which is not explicitly - calculated) - - (LET [(BOTTOMY (QUOTIENT X (SQRT 3] - (IRIS.PUSHMATRIX) - (IRIS.TRANSLATE 0 (MINUS (QUOTIENT X (SQRT 3))) - 0) - (IRIS.ROTATE (IRIS.DEGREES TETRA.TILT) - IRIS.XAXIS) - (IRIS.TRANSLATE 0 (DIFFERENCE BOTTOMY (TIMES BOTTOMY SHRINKFACTOR)) - 0) - (IRIS.SCALE SHRINKFACTOR SHRINKFACTOR SHRINKFACTOR) - (TETRA (TIMES SHRINKFACTOR X) - (SUB1 RECDEPTH) - SHRINKFACTOR STYLE T) (* IRIS.TRANSLATE 0 (MINUS BOTTOMY) 0) - - (* put 0 0 0 back on the edge of the larger tetra) - - (IRIS.POPMATRIX]) -) - -(RPAQQ IRIS.TILT 70.52878) - -(RPAQQ TETRA.COLOR BLUE) - -(RPAQQ TETRA.EDGE.COLOR BLACK) - -(RPAQQ TETRA.SHRINK 0.7) - -(RPAQQ TETRA.TILT 70.52878) - -(RPAQQ IV.DEFAULT.STYLE WIREFRAME) - - - -(* ;; "minimal 3-d support for the tetra demo") - -(DECLARE%: EVAL@COMPILE - -(RECORD 3POINT (|3X| |3Y| |3Z|)) -) -(DEFINEQ - -(3DOT - [LAMBDA (A B) (* gbn " 3-Mar-86 17:54") - (PLUS (TIMES (fetch |3X| of A) - (fetch |3X| of B)) - (TIMES (fetch |3Y| of A) - (fetch |3Y| of B)) - (TIMES (fetch |3Z| of A) - (fetch |3Z| of B]) - -(3DRAWTO - [LAMBDA (STREAM XOR3PT Y Z) (* edited%: "13-Dec-85 16:16") - (if (NUMBERP XOR3PT) - then (IRIS.DRAW XOR3PT Y Z STREAM) - else (IRIS.DRAW (fetch |3X| of XOR3PT) - (fetch |3Y| of XOR3PT) - (fetch |3Z| of XOR3PT) - STREAM]) - -(3MOVETO - [LAMBDA (STREAM XOR3PT Y Z) (* edited%: "13-Dec-85 16:16") - (if (NUMBERP XOR3PT) - then (IRIS.MOVE XOR3PT Y Z STREAM) - else (IRIS.MOVE (fetch |3X| of XOR3PT) - (fetch |3Y| of XOR3PT) - (fetch |3Z| of XOR3PT) - STREAM]) - -(3NORMALIZE - [LAMBDA (3VECTOR) (* gbn " 3-Mar-86 15:51") - - (* * Produces a vector with the same direction but unit magnitude as 3VECTOR) - - (LET ((LENGTH (3LENGTH 3VECTOR))) - (3POINT (QUOTIENT (fetch |3X| of 3VECTOR) - LENGTH) - (QUOTIENT (fetch |3Y| of 3VECTOR) - LENGTH) - (QUOTIENT (fetch |3Z| of 3VECTOR) - LENGTH]) - -(3PLUS - [LAMBDA (A B) (* gbn " 3-Mar-86 14:46") - (* vector sum of a and b) - (3POINT (PLUS (fetch |3X| of A) - (fetch |3X| of B)) - (PLUS (fetch |3Y| of A) - (fetch |3Y| of B)) - (PLUS (fetch |3Z| of A) - (fetch |3Z| of B]) - -(3POINT - [LAMBDA (X Y Z) (* edited%: "13-Dec-85 16:02") - (* creates a |3-d| point) - (create 3POINT - |3X| _ X - |3Y| _ Y - |3Z| _ Z]) - -(3UNITCROSSPRODUCT - [LAMBDA (A B) (* gbn " 3-Mar-86 15:51") - (LET* ((NORMAL (3CROSSPRODUCT A B)) - (LENGTH (3LENGTH NORMAL))) - (replace |3X| of NORMAL with (QUOTIENT (fetch |3X| of NORMAL) - LENGTH)) - (replace |3Y| of NORMAL with (QUOTIENT (fetch |3Y| of NORMAL) - LENGTH)) - (replace |3Z| of NORMAL with (QUOTIENT (fetch |3Z| of NORMAL) - LENGTH)) - NORMAL]) - -(3DIFFERENCE - [LAMBDA (DEST SOURCE) (* gbn "28-Feb-86 17:13") - (* vector difference from source to - dest) - (3POINT (DIFFERENCE (fetch |3X| of DEST) - (fetch |3X| of SOURCE)) - (DIFFERENCE (fetch |3Y| of DEST) - (fetch |3Z| of SOURCE)) - (DIFFERENCE (fetch |3Z| of DEST) - (fetch |3Z| of SOURCE]) - -(3CROSSPRODUCT - [LAMBDA (A B) (* gbn "28-Feb-86 17:17") - (3POINT (DIFFERENCE (TIMES (fetch |3Y| of A) - (fetch |3Z| of B)) - (TIMES (fetch |3Z| of A) - (fetch |3Y| of B))) - (DIFFERENCE (TIMES (fetch |3Z| of A) - (fetch |3X| of B)) - (TIMES (fetch |3X| of A) - (fetch |3Z| of B))) - (DIFFERENCE (TIMES (fetch |3X| of A) - (fetch |3Y| of B)) - (TIMES (fetch |3Y| of A) - (fetch |3X| of B]) - -(3LENGTH - [LAMBDA (A) (* gbn " 3-Mar-86 15:36") - - (* * returns the euclidean norm of the |3d| vector) - - (SQRT (PLUS (TIMES (fetch |3X| of A) - (fetch |3X| of A)) - (TIMES (fetch |3Y| of A) - (fetch |3Y| of A)) - (TIMES (fetch |3Z| of A) - (fetch |3Z| of A]) - -(3LINE - [LAMBDA (A B) (* gbn "28-Feb-86 17:22") - (3MOVETO \IRISSTREAM A) - (3DRAWTO \IRISSTREAM B]) - -(3TIMES - [LAMBDA (VECTOR SCALAR) (* gbn " 3-Mar-86 14:47") - (3POINT (TIMES (fetch |3X| of VECTOR) - SCALAR) - (TIMES (fetch |3Y| of VECTOR) - SCALAR) - (TIMES (fetch |3Z| of VECTOR) - SCALAR]) - -(DRAW.FACE? - [LAMBDA (LEFT RIGHT TOP COLOR) (* gbn " 3-Mar-86 18:45") - - (* handles drawing a single face. Left right and top are just logical names for - the points of the triangle. They need not correspond to Tetra's interpretation - of those names.) - - (LET* ((LEFTTOP (3DIFFERENCE TOP LEFT)) - (LEFTRIGHT (3DIFFERENCE RIGHT LEFT)) - (NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT)) - (NORMAL (3DIFFERENCE NORMALENDPT LEFT)) - (EYEVECTOR (3DIFFERENCE (IRIS.XLATE IV.VIEWPT) - LEFT))) - (if (GREATERP (3DOT EYEVECTOR NORMAL) - 0.0) - then (* this is not a backface so drawit) - (DSPCOLOR (OR COLOR 'CYAN) - \IRISSTREAM) - (IRIS.POLF 3 (LIST LEFT RIGHT TOP)) - (DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM) - (3MOVETO \IRISSTREAM LEFT) - (3DRAWTO \IRISSTREAM RIGHT) - (3DRAWTO \IRISSTREAM TOP) - (3DRAWTO \IRISSTREAM LEFT]) - -(IRIS.XLATE - [LAMBDA (3VECTOR) (* gbn " 3-Mar-86 17:18") - (IRIS.FEEDBACK \IRIS.DUMMYBUFFER 9) - (IRIS.XFPT (fetch |3X| of 3VECTOR) - (fetch |3Y| of 3VECTOR) - (fetch |3Z| of 3VECTOR)) - (if (NOT (EQUAL (IRIS.ENDFEEDBACK \IRIS.FEEDBACKBUFFER) - 9)) - then (HELP "NINE ITEMS NOT RETURNED")) - (3POINT (create FLOATP - HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 2) - LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 3)) - (create FLOATP - HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 4) - LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 5)) - (create FLOATP - HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 6) - LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 7]) -) - -(RPAQ \IRIS.DUMMYBUFFER (READARRAY 9 (QUOTE FIXP) 1)) -(1 1 1 1 1 1 1 1 1 NIL -) - -(RPAQ \IRIS.FEEDBACKBUFFER (READARRAY 9 (QUOTE FIXP) 1)) -(56 17275 9800 17288 8544 17585 41814 17585 41814 NIL -) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA TETRA) -) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1291 13248 (IRIS.DEGREES 1301 . 1568) (SNOW 1570 . 2622) (SPHERE 2624 . 4537) (TETRA -4539 . 7134) (TETRA.COLOR 7136 . 7267) (TETRA.DRAW.FACE 7269 . 10466) (TETRA.OBJ 10468 . 12107) ( -TETRA.TILT.AND.RECURSE 12109 . 13246)) (13570 21123 (3DOT 13580 . 13945) (3DRAWTO 13947 . 14317) ( -3MOVETO 14319 . 14689) (3NORMALIZE 14691 . 15221) (3PLUS 15223 . 15686) (3POINT 15688 . 15975) ( -3UNITCROSSPRODUCT 15977 . 16640) (3DIFFERENCE 16642 . 17238) (3CROSSPRODUCT 17240 . 18011) (3LENGTH -18013 . 18495) (3LINE 18497 . 18667) (3TIMES 18669 . 19007) (DRAW.FACE? 19009 . 20260) (IRIS.XLATE -20262 . 21121))))) -STOP diff --git a/obsolete/lispusers/IRISIO b/obsolete/lispusers/IRISIO deleted file mode 100644 index e70744cb..00000000 --- a/obsolete/lispusers/IRISIO +++ /dev/null @@ -1,574 +0,0 @@ -(FILECREATED "12-Nov-85 19:11:43" {ERIS}KOTO>IRISIO.;2 21026 - - changes to: (VARS IRISIOCOMS) - (FNS IRIS.SENDFS) - - previous date: " 9-Sep-85 13:47:28" {ERIS}KOTO>IRISIO.;1) - - -(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT IRISIOCOMS) - -(RPAQQ IRISIOCOMS [(COMS (* User level primitives) - (FNS IRIS.GEXIT IRIS.GFLUSH IRIS.GINIT IRIS.GRESET) - (MACROS IRIS.GFLUSH)) - (COMS (* Lower level primitives) - (FNS IRIS.RECBS IRIS.RECFS IRIS.RECLS IRIS.RECSS IRIS.SENDBS IRIS.SENDFS IRIS.SENDLS - IRIS.SENDQS IRIS.SENDSS IRIS.SETFASTCOM) - (MACROS IRIS.DOSYNC IRIS.ECHOFF IRIS.ECHOON IRIS.FLUSHG IRIS.GCMD IRIS.GETGCHAR - IRIS.GEXIT IRIS.GFINISH IRIS.PUTGCHAR IRIS.REC32 IRIS.REC6 IRIS.RECB IRIS.RECCR - IRIS.RECF IRIS.RECL IRIS.RECO IRIS.RECOS IRIS.RECS IRIS.SEND6 IRIS.SEND8 - IRIS.SENDB IRIS.SENDC IRIS.SENDF IRIS.SENDL IRIS.SENDO IRIS.SENDS - SPPINPUTSTREAM SPPSTREAM?) - (CONSTANTS (STDERR T) - (IRIS\AESC 46) - (IRIS\RESC 126) - (IRIS\TESC 16))) - [DECLARE: EVAL@LOAD DONTCOPY (P (LOADDEF (QUOTE FLOATP) - (QUOTE RECORD) - (QUOTE LLARITH] - (INITVARS (IRISCONN) - (IRISSPPON T)) - (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA]) - - - -(* User level primitives) - -(DEFINEQ - -(IRIS.GEXIT - (LAMBDA (stream) - (if stream - then (IRIS.FLUSHG stream) - else (IRIS.FLUSHG IRISCONN)))) - -(IRIS.GFLUSH - (LAMBDA (stream) - (if stream - then (IRIS.FLUSHG stream) - else (IRIS.FLUSHG IRISCONN)))) - -(IRIS.GINIT - (LAMBDA (STREAM) (* LeL, " 3-Sep-85 17:18") - (if (NOT STREAM) - then (SETQ STREAM IRISCONN)) - (IRIS.SETFASTCOM STREAM) (* Assumes that we communicate on the net) - (IRIS.XGINIT STREAM) - (IRIS.FLUSHG STREAM))) - -(IRIS.GRESET - (LAMBDA (STREAM) (* LeL, " 3-Sep-85 17:18") - (IRIS.XGRESET STREAM) - (IRIS.FLUSHG STREAM))) -) -(DECLARE: EVAL@COMPILE -[PUTPROPS IRIS.GFLUSH MACRO (arg? (* Just for speed...) - (if arg? then (CONS (QUOTE IRIS.FLUSHG) - arg?) - else - (QUOTE (IRIS.FLUSHG IRISCONN] -) - - - -(* Lower level primitives) - -(DEFINEQ - -(IRIS.RECBS - (LAMBDA (values stream) (* LeL, " 6-Sep-85 14:15") - (* Receive an array of bytes and fill VALUES) - (PROG (nLongs nBytes) - (SETQ nLongs (LRSH (IPLUS (SETQ nBytes (IRIS.RECL stream)) - 3) - 2)) (* Number of longs - - FIXP - - to recieve) - (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream)) - then (PRINT "IRIS.RECBS: error in array transport" STDERR) - (while (SPP.READP stream) do (BIN stream)) - (* Flush input) - (RETURN)) - (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 3 - bind aLong (arrayMax _(IPLUS (ARRAYORIG values) - nVals)) - do (SETQ aLong (IRIS.REC32 stream)) (* Recieve 6 six-bits words to make a long) - (if (IRIS.DOSYNC i) - then (IRIS.GETGCHAR stream) - (IRIS.PUTGCHAR IRIS\AESC stream) - (IRIS.FLUSHG stream)) - (for j from 0 to 2 when (LEQ (IPLUS ptr j) - arrayMax) - do (SETA values (IPLUS ptr j) - (LOGAND 255 (LRSH aLong (LLSH j 3)))))) - (IRIS.GETGCHAR stream)))) - -(IRIS.RECFS - (LAMBDA (values stream) (* LeL, " 6-Sep-85 12:50") - (* Common subroutine to IRIS.RECFS and IRIS.RECLS) - (PROG (nLongs) - (SETQ nLongs (IRIS.RECL stream)) - (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream)) - then (printout STDERR "IRIS.RECFLS: error in array transport" T) - (while (SPP.READP stream) do (BIN stream)) - (* Empty the stream buffer) - (RETURN)) - (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) - bind aLong (aFloat _(NCREATE 'FLOATP)) - do (SETQ aLong (IRIS.REC32 stream)) - (if (IRIS.DOSYNC i) - then (IRIS.GETGCHAR stream) - (IRIS.PUTGCHAR IRIS\AESC stream) - (IRIS.FLUSHG stream)) - (replace (FLOATP HIWORD) of aFloat with (LRSH aLong 16)) - (replace (FLOATP LOWORD) of aFloat with (LOGAND aLong 65535)) - (SETA values ptr aFloat)) - (IRIS.GETGCHAR stream)))) - -(IRIS.RECLS - (LAMBDA (values STREAM) (* LeL, " 6-Sep-85 10:22") - (* Recieve an array of longs) - (PROG (nLongs) - (SETQ nLongs (IRIS.RECL STREAM)) - (if (NEQ IRIS\RESC (IRIS.GETGCHAR STREAM)) - then (PRINT "IRIS.RECLS: error in array transport" STDERR) - (while (SPP.READP stream) do (BIN stream)) - (RETURN)) - (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) bind aLong - do (SETQ aLong (IRIS.REC32 STREAM)) - (if (IRIS.DOSYNC i) - then (IRIS.GETGCHAR STREAM) - (IRIS.PUTGCHAR IRIS\AESC STREAM) - (IRIS.FLUSHG STREAM)) - (SETA values ptr aLong)) - (IRIS.GETGCHAR STREAM)))) - -(IRIS.RECSS - (LAMBDA (values stream) (* LeL, " 6-Sep-85 14:17") - (* Recieve an array of SMALL INTEGERS) - (PROG (nLongs nShorts) - (SETQ nLongs (LRSH (ADD1 (SETQ nShorts (IRIS.RECL stream))) - 1)) - (if (NEQ IRIS\RESC (IRIS.GETGCHAR stream)) - then (PRINT "IRIS.RECSS: error in array transport" STDERR) - (while (SPP.READP stream) do (BIN stream)) - (RETURN)) - (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 2 bind aLong - do (SETQ aLong (IRIS.REC32 stream)) - (if (IRIS.DOSYNC i) - then (IRIS.GETGCHAR stream) - (IRIS.PUTGCHAR IRIS\AESC stream) - (IRIS.FLUSHG stream)) - (SETA values ptr (LRSH aLong 16)) - (if (OR (LESSP i (SUB1 nLongs)) - (EVENP nShorts)) - then (SETA values (ADD1 ptr) - (LOGAND 65535 aLong)))) - (IRIS.GETGCHAR stream)))) - -(IRIS.SENDBS - (LAMBDA (values nVals stream) (* LeL, " 9-Sep-85 05:29") - (* Send an array of bytes) - (PROG (nLongs) - (SETQ nLongs (LRSH (IPLUS nVals 3) - 2)) - (COND - ((ARRAYP values) - (IRIS.SENDL nVals stream) (* Fill a 32 bits word starting from highest byte :) - (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 4 - bind aLong (arrayMax _(IPLUS (ARRAYORIG values) - nVals)) - do (SETQ aLong (for j from 0 to 4 when (LEQ (IPLUS ptr j) - arrayMax) - sum (LLSH (ELT values (IPLUS ptr j)) - (LLSH j 3)))) - (if (IRIS.DOSYNC i) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL aLong stream))) - ((LISTP values) - (IRIS.SENDL nVals stream) - (for i from 0 to (SUB1 nLongs) bind (ptr _ values) - do (SETQ aLong (for j from 24 to 0 by -8 when ptr sum (LLSH (pop ptr) - j))) - (if (IRIS.DOSYNC i) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL aLong stream))))))) - -(IRIS.SENDFS - [LAMBDA (values nVals stream) (* gbn "11-Nov-85 19:48") - - (* * Sends an array or (possibly two-layered) list of numbers) - - - (COND - ([AND (ARRAYP values) - (NUMBERP (ELT values (ARRAYORIG values] - (* An array of numbers) - (IRIS.SENDL (LLSH nVals 2) - stream) - (for i from 0 to (SUB1 nVals) as ptr from (ARRAYORIG values) - do (if (IRIS.DOSYNC i) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDF (ELT values ptr) - stream))) - ((AND (LISTP values) - (NUMBERP (CAR values))) (* A list of numbers) - (IRIS.SENDL (LLSH nVals 2) - stream) - (for i in values as counter from 0 - do (if (IRIS.DOSYNC counter) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDF i stream))) - ((AND (LISTP values) - (POSITIONP (CAR values)) - (NUMBERP (CAAR values))) (* A list of positions) - (IRIS.SENDL (LLSH nVals 2) - stream) - (for i in values bind (counter _ -1) - do (if (IRIS.DOSYNC (add counter 1)) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDF (CAR i) - stream) - (if (IRIS.DOSYNC (add counter 1)) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDF (CDR i) - stream))) - [(AND (LISTP values) - (LISTP (CAR values)) - (NUMBERP (CAAR values))) (* A list of list of numbers) - (IRIS.SENDL (LLSH nVals 2) - stream) - (for i in values bind (counter _ -1) do (for j in i eachtime (add counter 1) - do (if (IRIS.DOSYNC counter) - then (IRIS.PUTGCHAR IRIS\AESC - stream)) - (IRIS.SENDF j stream] - (T (ERROR values "-- is not an list [of list]/array of numbers"]) - -(IRIS.SENDLS - (LAMBDA (values nVals stream) (* LeL, " 9-Sep-85 02:14") - - (* * Sends an array or (possibly two-layered) list of numbers) - - - (COND - ((AND (ARRAYP values) - (NUMBERP (ELT values (ARRAYORIG values)))) (* An array of numbers) - (IRIS.SENDL (LLSH nVals 2) - stream) - (for i from 0 to (SUB1 nVals) as ptr from (ARRAYORIG values) - do (if (IRIS.DOSYNC i) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL (ELT values ptr) - stream))) - ((AND (LISTP values) - (NUMBERP (CAR values))) (* A list of numbers) - (IRIS.SENDL (LLSH nVals 2) - stream) - (for i in values as counter from 0 - do (if (IRIS.DOSYNC counter) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL i stream))) - ((AND (LISTP values) - (LISTP (CAR values)) - (NUMBERP (CAAR values))) (* A list of list of numbers) - (IRIS.SENDL (LLSH nVals 2) - stream) - (for i in values bind (counter _ -1) do (for j in i eachtime (add counter 1) - do (if (IRIS.DOSYNC counter) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL j stream)))) - (T (ERROR values "-- is not an list [of list]/array of numbers"))))) - -(IRIS.SENDQS - (LAMBDA (values nVals stream) (* LeL, " 2-Sep-85 12:47") - (IRIS.SENDL (LLSH nVals 3)) - (COND - ((ARRAYP values) - (for i from 0 to (LLSH nVals 1) by 2 as ptr from 0 by 8 - do (if (IRIS.DOSYNC i) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL (LOGOR (LLSH (ELT values ptr) - 16) - (LLSH (ELT values (IPLUS ptr 1)) - 24) - (LLSH (ELT values (IPLUS ptr 2)) - 8) - (ELT values (IPLUS ptr 3))) - stream) - (if (IRIS.DOSYNC (IPLUS i 1)) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL (LOGOR (LLSH (ELT values (IPLUS ptr 4)) - 24) - (LLSH (ELT values (IPLUS ptr 5)) - 16) - (ELT values (IPLUS ptr 6)) - (LLSH (ELT values (IPLUS ptr 7)) - 8)) - stream))) - ((LISTP values) - (for i from 0 to (LLSH nVals 1) by 2 as ptr from values by 8 - do (if (IRIS.DOSYNC i) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL (LOGOR (LLSH (CAR values) - 16) - (LLSH (CADR values) - 24) - (LLSH (CADDR values) - 8) - (CADDDR values)) - stream) - (SETQ values (NTH values 5)) - (if (IRIS.DOSYNC (IPLUS i 1)) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL (LOGOR (LLSH (ELT values (CAR values)) - 24) - (LLSH (ELT values (CADR values)) - 16) - (CADDR values) - (LLSH (CADDDR values) - 8)) - stream) - (SETQ values (NTH values 5)))) - (T (ERROR values "-- neither an array nor a list"))))) - -(IRIS.SENDSS - (LAMBDA (values nVals stream) (* LeL, " 6-Sep-85 14:20") - - (* * Sends an array or list of numbers shorts (SMALLPs)) - - - (LET ((nLongs (LRSH nVals 1)) - (nBytes (LLSH nVals 1))) - (COND - ((AND (ARRAYP values) - (NUMBERP (ELT values (ARRAYORIG values)))) - (* An array of numbers) - (IRIS.SENDL nBytes stream) - (for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 2 bind aLong - do (SETQ aLong (ELT values ptr)) - (if (OR (LESSP i nLongs) - (EVENP nVals)) - then (add aLong (LLSH (ELT values (ADD1 ptr)) - 16))) - (if (IRIS.DOSYNC i) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL aLong stream))) - ((AND (LISTP values) - (NUMBERP (CAR values))) (* A list of numbers) - (IRIS.SENDL nBytes stream) - (for i from 0 to (SUB1 nLongs) bind aLong (pnt _ values) - do (SETQ aLong (pop pnt)) - (if pnt - then (add aLong (LLSH (pop pnt) - 16))) - (if (IRIS.DOSYNC i) - then (IRIS.PUTGCHAR IRIS\AESC stream)) - (IRIS.SENDL i stream))) - (T (ERROR values "-- is not an list [of list]/array of numbers")))))) - -(IRIS.SETFASTCOM - (LAMBDA (STREAM) (* gbn "19-Mar-85 21:02") - (IRIS.GCMD 1 STREAM))) -) -(DECLARE: EVAL@COMPILE -[PUTPROPS IRIS.DOSYNC MACRO ((i) - (COND ((EQ 0 (LOGAND i 7))) - (T NIL] -(PUTPROPS IRIS.ECHOFF MACRO ((STREAM) - (STREAMPROP STREAM (QUOTE IRIS\ECHOFLAG) - NIL))) -(PUTPROPS IRIS.ECHOON MACRO ((STREAM) - (STREAMPROP STREAM (QUOTE IRIS\ECHOFLAG) - T))) -(PUTPROPS IRIS.FLUSHG MACRO (= . SPP.FORCEOUTPUT)) -(PUTPROPS IRIS.GCMD MACRO ((CMD STREAM) - (* Sends a command) - (BOUT STREAM IRIS\TESC) - (* Escape character) - (IRIS.SEND6 CMD STREAM) - (* ...followed by the number in two six bits transmission) - (IRIS.SEND6 (LRSH CMD 6) - STREAM))) -[PUTPROPS IRIS.GETGCHAR MACRO ((STREAM) - (BIN (SPPINPUTSTREAM STREAM] -[PUTPROPS IRIS.GEXIT MACRO ((stream) - (if stream then (IRIS.FLUSHG stream) - else - (IRIS.FLUSHG IRISCONN] -(PUTPROPS IRIS.GFINISH MACRO ((stream) - (* null defn) - (IRIS.FLUSHG stream))) -(PUTPROPS IRIS.PUTGCHAR MACRO ((onechar SPPSTREAM) - (BOUT SPPSTREAM onechar))) -[PUTPROPS IRIS.REC32 MACRO ((stream) - (for j from 0 to 30 by 6 sum (LLSH (IRIS.REC6 stream) - j] -(PUTPROPS IRIS.REC6 MACRO ((STREAM) - (* Recieve a 6 bit word; we substract 32 because the other end add3s 32 to avoid sending - control characters) - (* NO LONGER ANDS 63) - (IDIFFERENCE (IRIS.GETGCHAR STREAM) - 32))) -[PUTPROPS IRIS.RECB MACRO (LAMBDA (STREAM) - (* Receive a byte) - (* is passed the spp outputstream, so must grab the input stream - from it) - (SETQ STREAM (SPPINPUTSTREAM STREAM)) - (while (NEQ IRIS\RESC (BIN STREAM))) - (LOGOR (IRIS.REC6 STREAM) - (LLSH (IRIS.REC6 STREAM) - 6] -[PUTPROPS IRIS.RECCR MACRO ((STREAM) - (* recieve a CarriageReturn) - (IRIS.GETGCHAR STREAM) - (* OR (EQ (IRIS.GETGCHAR STREAM) - (IPLUS 32 (CHARCODE CR))) - (ERROR "IRIS.RECCR received a non-carriage return from the IRIS"] -[PUTPROPS IRIS.RECF MACRO (LAMBDA (SPPSTREAM) - (* gbn "17-Jun-85 17:31") - (* receive a float. uses IRIS.RECL to receive a 32 bit word and - convert it to float) - (PROG (AFLOAT ALONG) - (SETQ ALONG (IRIS.RECL SPPSTREAM)) - (SETQ AFLOAT (NCREATE (QUOTE FLOATP))) - (replace (FLOATP HIWORD) - of AFLOAT with (LRSH ALONG 16)) - (replace (FLOATP LOWORD) - of AFLOAT with (LOGAND ALONG 65535)) - (RETURN AFLOAT] -(PUTPROPS IRIS.RECL MACRO ((stream) - (while (NEQ IRIS\RESC (IRIS.GETGCHAR stream)) - do NIL) - (IRIS.REC32 stream))) -(PUTPROPS IRIS.RECO MACRO ((STREAM) - (* Recieve a boolean) - (IRIS.RECB STREAM))) -(PUTPROPS IRIS.RECOS MACRO ((values STREAM) - (* Recieve an array of boolean) - (IRIS.RECBS values STREAM))) -[PUTPROPS IRIS.RECS MACRO ((stream) - (* Recieve a SMALL INTEGER) - (while (NEQ (IRIS.GETGCHAR stream) - IRIS\RESC) - do NIL) - (LET* ((1stbyte (IRIS.REC6 stream)) - (2ndbyte (IRIS.REC6 stream))) - (LOGOR 1stbyte (LLSH 2ndbyte 6) - (LLSH (IRIS.REC6 stream) - 12] -[PUTPROPS IRIS.SEND6 MACRO ((n STREAM) - (* Add 32 to avoid sending control characters) - (BOUT STREAM (IPLUS 32 (LOGAND 63 n] -(PUTPROPS IRIS.SEND8 MACRO ((n STREAM) - (BOUT STREAM n))) -(PUTPROPS IRIS.SENDB MACRO ((VALUE STREAM) - (* Send a byte) - (IRIS.SEND8 VALUE STREAM))) -(PUTPROPS IRIS.SENDC MACRO ((string stream) - (* Send a string of characters) - (* should probably allocate a global resource) - (IRIS.SENDBS (NCONC1 (CHCON string) - 0) - (ADD1 (NCHARS string)) - stream))) -[PUTPROPS IRIS.SENDF MACRO ((value stream) - (* Send a float) - (LET ((float (FLOAT value))) - (IRIS.SEND8 (\GETBASEBYTE float 0) - stream) - (IRIS.SEND8 (\GETBASEBYTE float 1) - stream) - (IRIS.SEND8 (\GETBASEBYTE float 2) - stream) - (IRIS.SEND8 (\GETBASEBYTE float 3) - stream] -[PUTPROPS IRIS.SENDL MACRO (LAMBDA (VALUE STREAM) - (* Sends a 32 bit integer) - (SELECTQ (TYPENAME VALUE) - (SMALLP (if (ILESSP VALUE 0) - then - (IRIS.SEND8 255 STREAM) - (IRIS.SEND8 255 STREAM) - else - (IRIS.SEND8 0 STREAM) - (IRIS.SEND8 0 STREAM)) - (IRIS.SEND8 (LOGAND (LRSH VALUE 8) - 255) - STREAM) - (IRIS.SEND8 (LOGAND VALUE 255) - STREAM)) - (FIXP (IRIS.SEND8 (\GETBASEBYTE VALUE 0) - STREAM) - (IRIS.SEND8 (\GETBASEBYTE VALUE 1) - STREAM) - (IRIS.SEND8 (\GETBASEBYTE VALUE 2) - STREAM) - (IRIS.SEND8 (\GETBASEBYTE VALUE 3) - STREAM)) - (ERROR VALUE - "can't be sent thru IRIS.SENDL (neither an FIXP nor a SMALLP)"] -(PUTPROPS IRIS.SENDO MACRO ((value STREAM) - (* send a boolean) - (IRIS.SENDB value STREAM))) -(PUTPROPS IRIS.SENDS MACRO ((value STREAM) - (* Send a SMALL INTEGER (16 bits)) - (IRIS.SEND8 (LOGAND 255 (LRSH value 8)) - STREAM) - (IRIS.SEND8 (LOGAND 255 value) - STREAM))) -[PUTPROPS SPPINPUTSTREAM MACRO ((OUTPUTSTREAM) - (* gbn "17-Jun-85 17:40") - (fetch (SPPCON SPPINPUTSTREAM) - of - (fetch (STREAM F1) - of OUTPUTSTREAM] -[PUTPROPS SPPSTREAM? MACRO (LAMBDA (STREAM) - (AND (TYPENAME STREAM (QUOTE STREAM)) - (TYPENAMEP (fetch F1 of STREAM) - (QUOTE SPPCON] -) -(DECLARE: EVAL@COMPILE - -(RPAQQ STDERR T) - -(RPAQQ IRIS\AESC 46) - -(RPAQQ IRIS\RESC 126) - -(RPAQQ IRIS\TESC 16) - -(CONSTANTS (STDERR T) - (IRIS\AESC 46) - (IRIS\RESC 126) - (IRIS\TESC 16)) -) -(DECLARE: EVAL@LOAD DONTCOPY -(LOADDEF (QUOTE FLOATP) - (QUOTE RECORD) - (QUOTE LLARITH)) -) - -(RPAQ? IRISCONN ) - -(RPAQ? IRISSPPON T) -(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA ) -) -(PUTPROPS IRISIO COPYRIGHT ("Xerox Corporation" 1985)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (1379 2155 (IRIS.GEXIT 1389 . 1514) (IRIS.GFLUSH 1516 . 1642) (IRIS.GINIT 1644 . 1986) ( -IRIS.GRESET 1988 . 2153)) (2392 15323 (IRIS.RECBS 2402 . 3820) (IRIS.RECFS 3822 . 4990) (IRIS.RECLS -4992 . 5841) (IRIS.RECSS 5843 . 6941) (IRIS.SENDBS 6943 . 8275) (IRIS.SENDFS 8277 . 10344) ( -IRIS.SENDLS 10346 . 11826) (IRIS.SENDQS 11828 . 13707) (IRIS.SENDSS 13709 . 15181) (IRIS.SETFASTCOM -15183 . 15321))))) -STOP diff --git a/obsolete/lispusers/IRISLIB b/obsolete/lispusers/IRISLIB deleted file mode 100644 index 44a0f4e2..00000000 --- a/obsolete/lispusers/IRISLIB +++ /dev/null @@ -1,3943 +0,0 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED " 2-Feb-87 23:35:29" {ERIS}NEXT>IRISLIB.;7 150378 - - changes to%: (VARS IRISLIBCOMS) - (FNS IRIS\ERROR) - - previous date%: " 9-Sep-85 05:32:30" {ERIS}NEXT>IRISLIB.;1) - - -(* " -Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT IRISLIBCOMS) - -(RPAQQ IRISLIBCOMS - ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES SPPDECLS (LOADCOMP) - IRISIO IRISSTREAM)) - (GLOBALVARS IRISCONN) - (FNS IRIS.XSETSLOWCOM IRIS.XSETFASTCOM IRIS.GVERSION IRIS.GDOWNLOAD IRIS.PAGECOLOR - IRIS.TEXTCOLOR IRIS.TEXTPORT IRIS.ARC IRIS.ARCF IRIS.ARCFI IRIS.ARCI IRIS.ATTACHCURSOR - IRIS.BACKBUFFER IRIS.BBOX2 IRIS.BBOX2I IRIS.BLINK IRIS.CALLOBJ IRIS.CHARSTR IRIS.CIRC - IRIS.CIRCF IRIS.CIRCFI IRIS.CIRCI IRIS.CLEAR IRIS.CLEARHITCODE IRIS.CLOSEOBJ IRIS.CMOV - IRIS.CMOV2 IRIS.CMOV2I IRIS.CMOVI IRIS.COLOR IRIS.CURSOFF IRIS.CURSON IRIS.CURVEIT - IRIS.DEFCURSOR IRIS.DEFLINESTYLE IRIS.DEFRASTERFONT IRIS.DELOBJ IRIS.DOUBLEBUFFER - IRIS.DRAW IRIS.DRAW2 IRIS.DRAW2I IRIS.DRAWI IRIS.EDITOBJ IRIS.ENDPICK IRIS.ENDSELECT - IRIS.FINISH IRIS.FONT IRIS.FRONTBUFFER IRIS.GCONFIG IRIS.GENOBJ IRIS.GENTAG - IRIS.GETBUFFER IRIS.GETBUTTON IRIS.GETCMMODE IRIS.GETCOLOR IRIS.GETCURSOR IRIS.GETDEPTH - IRIS.GETDISPLAYMODE IRIS.GETFONT IRIS.GETHEIGHT IRIS.GETHITCODE IRIS.GETLSBACKUP - IRIS.GETLSTYLE IRIS.GETLWIDTH IRIS.GETMAP IRIS.GETMATRIX IRIS.GETPLANES IRIS.GETRESETLS - IRIS.GETSCRMASK IRIS.GETVALUATOR IRIS.GETVIEWPORT IRIS.GETWRITEMASK IRIS.XGINIT - IRIS.XGRESET IRIS.GRGBCOLOR IRIS.GRGBCURSOR IRIS.GRGBMASK IRIS.ISOBJ IRIS.ISTAG - IRIS.LINEWIDTH IRIS.LOADMATRIX IRIS.LOOKAT IRIS.LSBACKUP IRIS.MAKEOBJ IRIS.MAKETAG - IRIS.MAPCOLOR IRIS.MAPW IRIS.MAPW2 IRIS.MOVE IRIS.MOVE2 IRIS.MOVE2I IRIS.MOVEI - IRIS.MULTIMAP IRIS.MULTMATRIX IRIS.NOISE IRIS.ONEMAP IRIS.ORTHO IRIS.ORTHO2 - IRIS.PERSPECTIVE IRIS.PICK IRIS.PICKSIZE IRIS.PNT IRIS.PNT2 IRIS.PNT2I IRIS.PNTI - IRIS.POLARVIEW IRIS.POLF IRIS.POLF2 IRIS.POLF2I IRIS.POLFI IRIS.POLY IRIS.POLY2 - IRIS.POLY2I IRIS.POLYI IRIS.POPATTRIBUTES IRIS.POPMATRIX IRIS.POPVIEWPORT - IRIS.PUSHATTRIBUTES IRIS.PUSHMATRIX IRIS.PUSHVIEWPORT IRIS.QENTER IRIS.QREAD IRIS.QRESET - IRIS.QTEST IRIS.READPIXELS IRIS.READRGB IRIS.RECT IRIS.RECTF IRIS.RECTFI IRIS.RECTI - IRIS.RESETLS IRIS.RGBCOLOR IRIS.RGBCURSOR IRIS.RGBMODE IRIS.RGBWRITEMASK IRIS.ROTATE - IRIS.SCALE IRIS.SCRMASK IRIS.SELECT IRIS.SETBUTTON IRIS.SETCURSOR IRIS.SETDEPTH - IRIS.SETLINESTYLE IRIS.SETMAP IRIS.SETVALUATOR IRIS.SINGLEBUFFER IRIS.STRWIDTH - IRIS.SWAPBUFFERS IRIS.SWAPINTERVAL IRIS.GSYNC IRIS.TIE IRIS.TRANSLATE IRIS.VIEWPORT - IRIS.WINDOW IRIS.WRITEMASK IRIS.WRITEPIXELS IRIS.WRITERGB IRIS.TPON IRIS.TPOFF - IRIS.TEXTWRITEMASK IRIS.XGEXIT IRIS.CLKON IRIS.CLKOFF IRIS.LAMPON IRIS.LAMPOFF - IRIS.SETBELL IRIS.RINGBELL IRIS.TADELAY IRIS.ARCFS IRIS.ARCS IRIS.BBOX2S - IRIS.BLANKSCREEN IRIS.BLKQREAD IRIS.GETMCOLOR IRIS.CALLFUNC IRIS.CHUNKSIZE IRIS.CIRCFS - IRIS.CIRCS IRIS.CMOV2S IRIS.CMOVS IRIS.COMPACTIFY IRIS.QDEVICE IRIS.UNQDEVICE - IRIS.CURVEBASIS IRIS.CURVEPRECISION IRIS.CRV IRIS.GETTP IRIS.GBEGIN IRIS.TEXTINIT - IRIS.CRVN IRIS.DEFBASIS IRIS.DELTAG IRIS.DEPTHCUE IRIS.DRAW2S IRIS.DRAWS - IRIS.ENDFEEDBACK IRIS.FEEDBACK IRIS.GETCPOS IRIS.GETDCM IRIS.GETGPOS IRIS.GETLSREPEAT - IRIS.GETMEM IRIS.GETMONITOR IRIS.GETOPENOBJ IRIS.GETZBUFFER IRIS.GEWRITE IRIS.INITNAMES - IRIS.LOADNAME IRIS.LSREPEAT IRIS.MOVE2S IRIS.MOVES IRIS.NEWTAG IRIS.PASSTHROUGH - IRIS.PATCHBASIS IRIS.PATCHPRECISION IRIS.PATCH IRIS.PCLOS IRIS.PDR IRIS.PDR2 IRIS.PDRI - IRIS.PDR2I IRIS.PDRS IRIS.PDR2S IRIS.POLF2S IRIS.POLFS IRIS.POLY2S IRIS.POLYS IRIS.PMV - IRIS.PMV2 IRIS.PMVI IRIS.PMV2I IRIS.PMVS IRIS.PMV2S IRIS.PNT2S IRIS.PNTS IRIS.POPNAME - IRIS.PUSHNAME IRIS.RDR IRIS.RDR2 IRIS.RDRI IRIS.RDR2I IRIS.RDRS IRIS.RDR2S IRIS.RECTCOPY - IRIS.RMV IRIS.RMV2 IRIS.RMVI IRIS.RMV2I IRIS.RMVS IRIS.RMV2S IRIS.RPDR IRIS.RPDR2 - IRIS.RPDRI IRIS.RPDR2I IRIS.RPDRS IRIS.RPDR2S IRIS.RPMV IRIS.RPMV2 IRIS.RPMVI - IRIS.RPMV2I IRIS.RPMVS IRIS.RPMV2S IRIS.SETDBLIGHTS IRIS.SETMONITOR IRIS.SETSHADE - IRIS.SHADERANGE IRIS.SPCLOS IRIS.SPLF IRIS.SPLF2 IRIS.SPLFI IRIS.SPLF2I IRIS.SPLFS - IRIS.SPLF2S IRIS.XFPT IRIS.XFPTI IRIS.XFPTS IRIS.XFPT2 IRIS.XFPT2I IRIS.XFPT2S - IRIS.XFPT4 IRIS.XFPT4I IRIS.XFPT4S IRIS.ZBUFFER IRIS.CHARST IRIS.STRWID IRIS.DEFPATTERN - IRIS.GETPATTERN IRIS.SETPATTERN IRIS.OBJINSERT IRIS.OBJDELETE IRIS.OBJREPLACE - IRIS.ZCLEAR IRIS.CURORIGIN IRIS.PAGEWRITEMASK IRIS.PATCHCURVES IRIS.DBTEXT IRIS.LASTONE - IRIS\ERROR))) -(DECLARE%: EVAL@COMPILE DONTCOPY -(FILESLOAD SPPDECLS (LOADCOMP) - IRISIO IRISSTREAM) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS IRISCONN) -) -(DEFINEQ - -(IRIS.XSETSLOWCOM - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 0 sppStream]) - -(IRIS.XSETFASTCOM - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 1 sppStream]) - -(IRIS.GVERSION - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 2 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GDOWNLOAD - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 3 sppStream]) - -(IRIS.PAGECOLOR - [LAMBDA (color sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if color - then (IRIS.GCMD 4 sppStream) - (IRIS.SENDS color sppStream) - else (IRIS\ERROR %'IRIS.PAGECOLOR %' (color]) - -(IRIS.TEXTCOLOR - [LAMBDA (color sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if color - then (IRIS.GCMD 5 sppStream) - (IRIS.SENDS color sppStream) - else (IRIS\ERROR %'IRIS.TEXTCOLOR %' (color]) - -(IRIS.TEXTPORT - [LAMBDA (left right top bottom sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right top bottom) - then (IRIS.GCMD 6 sppStream) - (IRIS.SENDS left sppStream) - (IRIS.SENDS right sppStream) - (IRIS.SENDS top sppStream) - (IRIS.SENDS bottom sppStream) - else (IRIS\ERROR %'IRIS.TEXTPORT %' (left right top bottom]) - -(IRIS.ARC - [LAMBDA (x y radius startang endang sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius startang endang) - then (IRIS.GCMD 7 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF radius sppStream) - (IRIS.SENDS startang sppStream) - (IRIS.SENDS endang sppStream) - else (IRIS\ERROR %'IRIS.ARC %' (x y radius startang endang]) - -(IRIS.ARCF - [LAMBDA (x y radius startang endang sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius startang endang) - then (IRIS.GCMD 8 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF radius sppStream) - (IRIS.SENDS startang sppStream) - (IRIS.SENDS endang sppStream) - else (IRIS\ERROR %'IRIS.ARCF %' (x y radius startang endang]) - -(IRIS.ARCFI - [LAMBDA (x y radius startang endang sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius startang endang) - then (IRIS.GCMD 9 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL radius sppStream) - (IRIS.SENDS startang sppStream) - (IRIS.SENDS endang sppStream) - else (IRIS\ERROR %'IRIS.ARCFI %' (x y radius startang endang]) - -(IRIS.ARCI - [LAMBDA (x y radius startang endang sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius startang endang) - then (IRIS.GCMD 10 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL radius sppStream) - (IRIS.SENDS startang sppStream) - (IRIS.SENDS endang sppStream) - else (IRIS\ERROR %'IRIS.ARCI %' (x y radius startang endang]) - -(IRIS.ATTACHCURSOR - [LAMBDA (vx vy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND vx vy) - then (IRIS.GCMD 11 sppStream) - (IRIS.SENDS vx sppStream) - (IRIS.SENDS vy sppStream) - else (IRIS\ERROR %'IRIS.ATTACHCURSOR %' (vx vy]) - -(IRIS.BACKBUFFER - [LAMBDA (b sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if b - then (IRIS.GCMD 12 sppStream) - (IRIS.SENDO b sppStream) - else (IRIS\ERROR %'IRIS.BACKBUFFER %' (b]) - -(IRIS.BBOX2 - [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND xmin ymin x1 y1 x2 y2) - then (IRIS.GCMD 14 sppStream) - (IRIS.SENDS xmin sppStream) - (IRIS.SENDS ymin sppStream) - (IRIS.SENDF x1 sppStream) - (IRIS.SENDF y1 sppStream) - (IRIS.SENDF x2 sppStream) - (IRIS.SENDF y2 sppStream) - else (IRIS\ERROR %'IRIS.BBOX2 %' (xmin ymin x1 y1 x2 y2]) - -(IRIS.BBOX2I - [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND xmin ymin x1 y1 x2 y2) - then (IRIS.GCMD 15 sppStream) - (IRIS.SENDS xmin sppStream) - (IRIS.SENDS ymin sppStream) - (IRIS.SENDL x1 sppStream) - (IRIS.SENDL y1 sppStream) - (IRIS.SENDL x2 sppStream) - (IRIS.SENDL y2 sppStream) - else (IRIS\ERROR %'IRIS.BBOX2I %' (xmin ymin x1 y1 x2 y2]) - -(IRIS.BLINK - [LAMBDA (rate color red green blue sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND rate color red green blue) - then (IRIS.GCMD 17 sppStream) - (IRIS.SENDS rate sppStream) - (IRIS.SENDS color sppStream) - (IRIS.SENDS red sppStream) - (IRIS.SENDS green sppStream) - (IRIS.SENDS blue sppStream) - else (IRIS\ERROR %'IRIS.BLINK %' (rate color red green blue]) - -(IRIS.CALLOBJ - [LAMBDA (obj sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if obj - then (IRIS.GCMD 18 sppStream) - (IRIS.SENDL obj sppStream) - else (IRIS\ERROR %'IRIS.CALLOBJ %' (obj]) - -(IRIS.CHARSTR - [LAMBDA (str sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if str - then (IRIS.GCMD 19 sppStream) - (IRIS.SENDC str sppStream) - else (IRIS\ERROR %'IRIS.CHARSTR %' (str]) - -(IRIS.CIRC - [LAMBDA (x y radius sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius) - then (IRIS.GCMD 20 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF radius sppStream) - else (IRIS\ERROR %'IRIS.CIRC %' (x y radius]) - -(IRIS.CIRCF - [LAMBDA (x y radius sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius) - then (IRIS.GCMD 21 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF radius sppStream) - else (IRIS\ERROR %'IRIS.CIRCF %' (x y radius]) - -(IRIS.CIRCFI - [LAMBDA (x y radius sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius) - then (IRIS.GCMD 22 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL radius sppStream) - else (IRIS\ERROR %'IRIS.CIRCFI %' (x y radius]) - -(IRIS.CIRCI - [LAMBDA (x y radius sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius) - then (IRIS.GCMD 23 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL radius sppStream) - else (IRIS\ERROR %'IRIS.CIRCI %' (x y radius]) - -(IRIS.CLEAR - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 24 sppStream]) - -(IRIS.CLEARHITCODE - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 25 sppStream]) - -(IRIS.CLOSEOBJ - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 29 sppStream]) - -(IRIS.CMOV - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 30 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.CMOV %' (x y z]) - -(IRIS.CMOV2 - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 31 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - else (IRIS\ERROR %'IRIS.CMOV2 %' (x y]) - -(IRIS.CMOV2I - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 32 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - else (IRIS\ERROR %'IRIS.CMOV2I %' (x y]) - -(IRIS.CMOVI - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 33 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL z sppStream) - else (IRIS\ERROR %'IRIS.CMOVI %' (x y z]) - -(IRIS.COLOR - [LAMBDA (color sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if color - then (IRIS.GCMD 34 sppStream) - (IRIS.SENDS color sppStream) - else (IRIS\ERROR %'IRIS.COLOR %' (color]) - -(IRIS.CURSOFF - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 35 sppStream]) - -(IRIS.CURSON - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 36 sppStream]) - -(IRIS.CURVEIT - [LAMBDA (iterationcount sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if iterationcount - then (IRIS.GCMD 38 sppStream) - (IRIS.SENDS iterationcount sppStream) - else (IRIS\ERROR %'IRIS.CURVEIT %' (iterationcount]) - -(IRIS.DEFCURSOR - [LAMBDA (n curs sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n curs) - then (IRIS.GCMD 39 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.SENDSS curs 16 sppStream) - else (IRIS\ERROR %'IRIS.DEFCURSOR %' (n curs]) - -(IRIS.DEFLINESTYLE - [LAMBDA (n ls sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n ls) - then (IRIS.GCMD 40 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.SENDS ls sppStream) - else (IRIS\ERROR %'IRIS.DEFLINESTYLE %' (n ls]) - -(IRIS.DEFRASTERFONT - [LAMBDA (n ht nc chars nr raster sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n ht nc chars nr raster) - then (IRIS.GCMD 42 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.SENDS ht sppStream) - (IRIS.SENDS nc sppStream) - (IRIS.SENDQS chars nc sppStream) - (IRIS.SENDS nr sppStream) - (IRIS.SENDSS raster nr sppStream) - else (IRIS\ERROR %'IRIS.DEFRASTERFONT %' (n ht nc chars nr raster]) - -(IRIS.DELOBJ - [LAMBDA (obj sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if obj - then (IRIS.GCMD 45 sppStream) - (IRIS.SENDL obj sppStream) - else (IRIS\ERROR %'IRIS.DELOBJ %' (obj]) - -(IRIS.DOUBLEBUFFER - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 46 sppStream]) - -(IRIS.DRAW - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 47 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.DRAW %' (x y z]) - -(IRIS.DRAW2 - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 48 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - else (IRIS\ERROR %'IRIS.DRAW2 %' (x y]) - -(IRIS.DRAW2I - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 49 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - else (IRIS\ERROR %'IRIS.DRAW2I %' (x y]) - -(IRIS.DRAWI - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 50 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL z sppStream) - else (IRIS\ERROR %'IRIS.DRAWI %' (x y z]) - -(IRIS.EDITOBJ - [LAMBDA (obj sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if obj - then (IRIS.GCMD 51 sppStream) - (IRIS.SENDL obj sppStream) - else (IRIS\ERROR %'IRIS.EDITOBJ %' (obj]) - -(IRIS.ENDPICK - [LAMBDA (buffer sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if buffer - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 52 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECSS buffer sppStream) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.ENDPICK %' (buffer]) - -(IRIS.ENDSELECT - [LAMBDA (buffer sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if buffer - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 53 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECSS buffer sppStream) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.ENDSELECT %' (buffer]) - -(IRIS.FINISH - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 54 sppStream]) - -(IRIS.FONT - [LAMBDA (fntnum sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if fntnum - then (IRIS.GCMD 55 sppStream) - (IRIS.SENDS fntnum sppStream) - else (IRIS\ERROR %'IRIS.FONT %' (fntnum]) - -(IRIS.FRONTBUFFER - [LAMBDA (b sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if b - then (IRIS.GCMD 56 sppStream) - (IRIS.SENDO b sppStream) - else (IRIS\ERROR %'IRIS.FRONTBUFFER %' (b]) - -(IRIS.GCONFIG - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 57 sppStream]) - -(IRIS.GENOBJ - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 58 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GENTAG - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 59 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETBUFFER - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 60 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETBUTTON - [LAMBDA (b sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if b - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 61 sppStream) - (IRIS.SENDS b sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.GETBUTTON %' (b]) - -(IRIS.GETCMMODE - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 62 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETCOLOR - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 63 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETCURSOR - [LAMBDA (index color wtm b sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND index color wtm b) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 64 sppStream) - (IRIS.FLUSHG sppStream) - (SET index (IRIS.RECS sppStream)) - (SET color (IRIS.RECS sppStream)) - (SET wtm (IRIS.RECS sppStream)) - (SET b (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETCURSOR %' (index color wtm b]) - -(IRIS.GETDEPTH - [LAMBDA (near far sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND near far) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 65 sppStream) - (IRIS.FLUSHG sppStream) - (SET near (IRIS.RECS sppStream)) - (SET far (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETDEPTH %' (near far]) - -(IRIS.GETDISPLAYMODE - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 66 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETFONT - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 67 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETHEIGHT - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 68 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETHITCODE - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 69 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETLSBACKUP - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 70 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETLSTYLE - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 71 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETLWIDTH - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 72 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETMAP - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 73 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETMATRIX - [LAMBDA (m sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if m - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 74 sppStream) - (IRIS.FLUSHG sppStream) - (IRIS.RECFS m sppStream) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETMATRIX %' (m]) - -(IRIS.GETPLANES - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 76 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETRESETLS - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 77 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETSCRMASK - [LAMBDA (left right bottom top sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 78 sppStream) - (IRIS.FLUSHG sppStream) - (SET left (IRIS.RECS sppStream)) - (SET right (IRIS.RECS sppStream)) - (SET bottom (IRIS.RECS sppStream)) - (SET top (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETSCRMASK %' (left right bottom top]) - -(IRIS.GETVALUATOR - [LAMBDA (v sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if v - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 80 sppStream) - (IRIS.SENDS v sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.GETVALUATOR %' (v]) - -(IRIS.GETVIEWPORT - [LAMBDA (left right bottom top sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 81 sppStream) - (IRIS.FLUSHG sppStream) - (SET left (IRIS.RECS sppStream)) - (SET right (IRIS.RECS sppStream)) - (SET bottom (IRIS.RECS sppStream)) - (SET top (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETVIEWPORT %' (left right bottom top]) - -(IRIS.GETWRITEMASK - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 82 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.XGINIT - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 83 sppStream]) - -(IRIS.XGRESET - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 84 sppStream]) - -(IRIS.GRGBCOLOR - [LAMBDA (red green blue sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND red green blue) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 85 sppStream) - (IRIS.FLUSHG sppStream) - (SET red (IRIS.RECS sppStream)) - (SET green (IRIS.RECS sppStream)) - (SET blue (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GRGBCOLOR %' (red green blue]) - -(IRIS.GRGBCURSOR - [LAMBDA (index red green blue redm greenm blum b sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND index red green blue redm greenm blum b) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 86 sppStream) - (IRIS.FLUSHG sppStream) - (SET index (IRIS.RECS sppStream)) - (SET red (IRIS.RECS sppStream)) - (SET green (IRIS.RECS sppStream)) - (SET blue (IRIS.RECS sppStream)) - (SET redm (IRIS.RECS sppStream)) - (SET greenm (IRIS.RECS sppStream)) - (SET blum (IRIS.RECS sppStream)) - (SET b (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GRGBCURSOR %' (index red green blue redm greenm blum b]) - -(IRIS.GRGBMASK - [LAMBDA (redm greenm blum sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND redm greenm blum) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 87 sppStream) - (IRIS.FLUSHG sppStream) - (SET redm (IRIS.RECS sppStream)) - (SET greenm (IRIS.RECS sppStream)) - (SET blum (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GRGBMASK %' (redm greenm blum]) - -(IRIS.ISOBJ - [LAMBDA (obj sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if obj - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 89 sppStream) - (IRIS.SENDL obj sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.ISOBJ %' (obj]) - -(IRIS.ISTAG - [LAMBDA (t sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if t - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 90 sppStream) - (IRIS.SENDL t sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.ISTAG %' (t]) - -(IRIS.LINEWIDTH - [LAMBDA (n sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if n - then (IRIS.GCMD 92 sppStream) - (IRIS.SENDS n sppStream) - else (IRIS\ERROR %'IRIS.LINEWIDTH %' (n]) - -(IRIS.LOADMATRIX - [LAMBDA (m sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if m - then (IRIS.GCMD 93 sppStream) - (IRIS.SENDFS m 16 sppStream) - else (IRIS\ERROR %'IRIS.LOADMATRIX %' (m]) - -(IRIS.LOOKAT - [LAMBDA (vx vy vz px py pz twist sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND vx vy vz px py pz twist) - then (IRIS.GCMD 94 sppStream) - (IRIS.SENDF vx sppStream) - (IRIS.SENDF vy sppStream) - (IRIS.SENDF vz sppStream) - (IRIS.SENDF px sppStream) - (IRIS.SENDF py sppStream) - (IRIS.SENDF pz sppStream) - (IRIS.SENDS twist sppStream) - else (IRIS\ERROR %'IRIS.LOOKAT %' (vx vy vz px py pz twist]) - -(IRIS.LSBACKUP - [LAMBDA (b sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if b - then (IRIS.GCMD 95 sppStream) - (IRIS.SENDO b sppStream) - else (IRIS\ERROR %'IRIS.LSBACKUP %' (b]) - -(IRIS.MAKEOBJ - [LAMBDA (obj sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if obj - then (IRIS.GCMD 96 sppStream) - (IRIS.SENDL obj sppStream) - else (IRIS\ERROR %'IRIS.MAKEOBJ %' (obj]) - -(IRIS.MAKETAG - [LAMBDA (t sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if t - then (IRIS.GCMD 97 sppStream) - (IRIS.SENDL t sppStream) - else (IRIS\ERROR %'IRIS.MAKETAG %' (t]) - -(IRIS.MAPCOLOR - [LAMBDA (color red green blue sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND color red green blue) - then (IRIS.GCMD 98 sppStream) - (IRIS.SENDS color sppStream) - (IRIS.SENDS red sppStream) - (IRIS.SENDS green sppStream) - (IRIS.SENDS blue sppStream) - else (IRIS\ERROR %'IRIS.MAPCOLOR %' (color red green blue]) - -(IRIS.MAPW - [LAMBDA (vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 99 sppStream) - (IRIS.SENDL vobj sppStream) - (IRIS.SENDS sx sppStream) - (IRIS.SENDS sy sppStream) - (IRIS.FLUSHG sppStream) - (SET wx1 (IRIS.RECF sppStream)) - (SET wy1 (IRIS.RECF sppStream)) - (SET wz1 (IRIS.RECF sppStream)) - (SET wx2 (IRIS.RECF sppStream)) - (SET wy2 (IRIS.RECF sppStream)) - (SET wz2 (IRIS.RECF sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.MAPW %' (vobj sx sy wx1 wy1 wz1 wx2 wy2 wz2]) - -(IRIS.MAPW2 - [LAMBDA (vobj sx sy wx wy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND vobj sx sy wx wy) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 100 sppStream) - (IRIS.SENDL vobj sppStream) - (IRIS.SENDS sx sppStream) - (IRIS.SENDS sy sppStream) - (IRIS.FLUSHG sppStream) - (SET wx (IRIS.RECF sppStream)) - (SET wy (IRIS.RECF sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.MAPW2 %' (vobj sx sy wx wy]) - -(IRIS.MOVE - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 102 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.MOVE %' (x y z]) - -(IRIS.MOVE2 - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 103 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - else (IRIS\ERROR %'IRIS.MOVE2 %' (x y]) - -(IRIS.MOVE2I - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 104 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - else (IRIS\ERROR %'IRIS.MOVE2I %' (x y]) - -(IRIS.MOVEI - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 105 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL z sppStream) - else (IRIS\ERROR %'IRIS.MOVEI %' (x y z]) - -(IRIS.MULTIMAP - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 106 sppStream]) - -(IRIS.MULTMATRIX - [LAMBDA (m sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if m - then (IRIS.GCMD 107 sppStream) - (IRIS.SENDFS m 16 sppStream) - else (IRIS\ERROR %'IRIS.MULTMATRIX %' (m]) - -(IRIS.NOISE - [LAMBDA (v delta sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND v delta) - then (IRIS.GCMD 108 sppStream) - (IRIS.SENDS v sppStream) - (IRIS.SENDS delta sppStream) - else (IRIS\ERROR %'IRIS.NOISE %' (v delta]) - -(IRIS.ONEMAP - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 111 sppStream]) - -(IRIS.ORTHO - [LAMBDA (left right bottom top near far sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top near far) - then (IRIS.GCMD 112 sppStream) - (IRIS.SENDF left sppStream) - (IRIS.SENDF right sppStream) - (IRIS.SENDF bottom sppStream) - (IRIS.SENDF top sppStream) - (IRIS.SENDF near sppStream) - (IRIS.SENDF far sppStream) - else (IRIS\ERROR %'IRIS.ORTHO %' (left right bottom top near far]) - -(IRIS.ORTHO2 - [LAMBDA (left right bottom top sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top) - then (IRIS.GCMD 113 sppStream) - (IRIS.SENDF left sppStream) - (IRIS.SENDF right sppStream) - (IRIS.SENDF bottom sppStream) - (IRIS.SENDF top sppStream) - else (IRIS\ERROR %'IRIS.ORTHO2 %' (left right bottom top]) - -(IRIS.PERSPECTIVE - [LAMBDA (fovy aspect near far sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND fovy aspect near far) - then (IRIS.GCMD 114 sppStream) - (IRIS.SENDS fovy sppStream) - (IRIS.SENDF aspect sppStream) - (IRIS.SENDF near sppStream) - (IRIS.SENDF far sppStream) - else (IRIS\ERROR %'IRIS.PERSPECTIVE %' (fovy aspect near far]) - -(IRIS.PICK - [LAMBDA (numNames buffer sppStream) (* LeL, " 9-Sep-85 04:19") - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND numNames buffer) - then (IRIS.GCMD 115 sppStream) - (IRIS.SENDSS buffer 0 sppStream) - (IRIS.SENDL numNames sppStream) - else (IRIS\ERROR %'IRIS.PICK %' (numNames buffer]) - -(IRIS.PICKSIZE - [LAMBDA (deltax deltay sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND deltax deltay) - then (IRIS.GCMD 116 sppStream) - (IRIS.SENDS deltax sppStream) - (IRIS.SENDS deltay sppStream) - else (IRIS\ERROR %'IRIS.PICKSIZE %' (deltax deltay]) - -(IRIS.PNT - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 117 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.PNT %' (x y z]) - -(IRIS.PNT2 - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 118 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - else (IRIS\ERROR %'IRIS.PNT2 %' (x y]) - -(IRIS.PNT2I - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 119 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - else (IRIS\ERROR %'IRIS.PNT2I %' (x y]) - -(IRIS.PNTI - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 120 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL z sppStream) - else (IRIS\ERROR %'IRIS.PNTI %' (x y z]) - -(IRIS.POLARVIEW - [LAMBDA (dist azim inc twist sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dist azim inc twist) - then (IRIS.GCMD 121 sppStream) - (IRIS.SENDF dist sppStream) - (IRIS.SENDS azim sppStream) - (IRIS.SENDS inc sppStream) - (IRIS.SENDS twist sppStream) - else (IRIS\ERROR %'IRIS.POLARVIEW %' (dist azim inc twist]) - -(IRIS.POLF - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 122 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDFS parray (TIMES 3 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLF %' (n parray]) - -(IRIS.POLF2 - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 123 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDFS parray (TIMES 2 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLF2 %' (n parray]) - -(IRIS.POLF2I - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 124 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDLS parray (TIMES 2 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLF2I %' (n parray]) - -(IRIS.POLFI - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 125 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDLS parray (TIMES 3 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLFI %' (n parray]) - -(IRIS.POLY - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 126 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDFS parray (TIMES 3 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLY %' (n parray]) - -(IRIS.POLY2 - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 127 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDFS parray (TIMES 2 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLY2 %' (n parray]) - -(IRIS.POLY2I - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 128 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDLS parray (TIMES 2 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLY2I %' (n parray]) - -(IRIS.POLYI - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 129 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDLS parray (TIMES 3 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLYI %' (n parray]) - -(IRIS.POPATTRIBUTES - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 130 sppStream]) - -(IRIS.POPMATRIX - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 131 sppStream]) - -(IRIS.POPVIEWPORT - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 132 sppStream]) - -(IRIS.PUSHATTRIBUTES - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 133 sppStream]) - -(IRIS.PUSHMATRIX - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 134 sppStream]) - -(IRIS.PUSHVIEWPORT - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 135 sppStream]) - -(IRIS.QENTER - [LAMBDA (qtype val sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND qtype val) - then (IRIS.GCMD 137 sppStream) - (IRIS.SENDS qtype sppStream) - (IRIS.SENDS val sppStream) - else (IRIS\ERROR %'IRIS.QENTER %' (qtype val]) - -(IRIS.QREAD - [LAMBDA (data sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if data - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 139 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (SET data (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.QREAD %' (data]) - -(IRIS.QRESET - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 140 sppStream]) - -(IRIS.QTEST - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 141 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.READPIXELS - [LAMBDA (n colors sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n colors) - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 143 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECSS colors sppStream) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.READPIXELS %' (n colors]) - -(IRIS.READRGB - [LAMBDA (n red green blue sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n red green blue) - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 144 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECBS red sppStream) - (IRIS.RECBS green sppStream) - (IRIS.RECBS blue sppStream) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.READRGB %' (n red green blue]) - -(IRIS.RECT - [LAMBDA (x1 y1 x2 y2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x1 y1 x2 y2) - then (IRIS.GCMD 145 sppStream) - (IRIS.SENDF x1 sppStream) - (IRIS.SENDF y1 sppStream) - (IRIS.SENDF x2 sppStream) - (IRIS.SENDF y2 sppStream) - else (IRIS\ERROR %'IRIS.RECT %' (x1 y1 x2 y2]) - -(IRIS.RECTF - [LAMBDA (x1 y1 x2 y2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x1 y1 x2 y2) - then (IRIS.GCMD 146 sppStream) - (IRIS.SENDF x1 sppStream) - (IRIS.SENDF y1 sppStream) - (IRIS.SENDF x2 sppStream) - (IRIS.SENDF y2 sppStream) - else (IRIS\ERROR %'IRIS.RECTF %' (x1 y1 x2 y2]) - -(IRIS.RECTFI - [LAMBDA (x1 y1 x2 y2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x1 y1 x2 y2) - then (IRIS.GCMD 147 sppStream) - (IRIS.SENDL x1 sppStream) - (IRIS.SENDL y1 sppStream) - (IRIS.SENDL x2 sppStream) - (IRIS.SENDL y2 sppStream) - else (IRIS\ERROR %'IRIS.RECTFI %' (x1 y1 x2 y2]) - -(IRIS.RECTI - [LAMBDA (x1 y1 x2 y2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x1 y1 x2 y2) - then (IRIS.GCMD 148 sppStream) - (IRIS.SENDL x1 sppStream) - (IRIS.SENDL y1 sppStream) - (IRIS.SENDL x2 sppStream) - (IRIS.SENDL y2 sppStream) - else (IRIS\ERROR %'IRIS.RECTI %' (x1 y1 x2 y2]) - -(IRIS.RESETLS - [LAMBDA (b sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if b - then (IRIS.GCMD 150 sppStream) - (IRIS.SENDO b sppStream) - else (IRIS\ERROR %'IRIS.RESETLS %' (b]) - -(IRIS.RGBCOLOR - [LAMBDA (red green blue sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND red green blue) - then (IRIS.GCMD 151 sppStream) - (IRIS.SENDS red sppStream) - (IRIS.SENDS green sppStream) - (IRIS.SENDS blue sppStream) - else (IRIS\ERROR %'IRIS.RGBCOLOR %' (red green blue]) - -(IRIS.RGBCURSOR - [LAMBDA (index red green blue redm greenm blum sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND index red green blue redm greenm blum) - then (IRIS.GCMD 152 sppStream) - (IRIS.SENDS index sppStream) - (IRIS.SENDS red sppStream) - (IRIS.SENDS green sppStream) - (IRIS.SENDS blue sppStream) - (IRIS.SENDS redm sppStream) - (IRIS.SENDS greenm sppStream) - (IRIS.SENDS blum sppStream) - else (IRIS\ERROR %'IRIS.RGBCURSOR %' (index red green blue redm greenm blum]) - -(IRIS.RGBMODE - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 153 sppStream]) - -(IRIS.RGBWRITEMASK - [LAMBDA (red green blue sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND red green blue) - then (IRIS.GCMD 154 sppStream) - (IRIS.SENDS red sppStream) - (IRIS.SENDS green sppStream) - (IRIS.SENDS blue sppStream) - else (IRIS\ERROR %'IRIS.RGBWRITEMASK %' (red green blue]) - -(IRIS.ROTATE - [LAMBDA (a axis sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND a axis) - then (IRIS.GCMD 155 sppStream) - (IRIS.SENDS a sppStream) - (IRIS.SENDB axis sppStream) - else (IRIS\ERROR %'IRIS.ROTATE %' (a axis]) - -(IRIS.SCALE - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 156 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.SCALE %' (x y z]) - -(IRIS.SCRMASK - [LAMBDA (left right bottom top sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top) - then (IRIS.GCMD 158 sppStream) - (IRIS.SENDS left sppStream) - (IRIS.SENDS right sppStream) - (IRIS.SENDS bottom sppStream) - (IRIS.SENDS top sppStream) - else (IRIS\ERROR %'IRIS.SCRMASK %' (left right bottom top]) - -(IRIS.SELECT - [LAMBDA (numnames buffer sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND numnames buffer) - then (IRIS.GCMD 159 sppStream) - (IRIS.SENDSS numnames 0 sppStream) - (IRIS.SENDL buffer sppStream) - else (IRIS\ERROR %'IRIS.SELECT %' (numnames buffer]) - -(IRIS.SETBUTTON - [LAMBDA (b value sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND b value) - then (IRIS.GCMD 160 sppStream) - (IRIS.SENDS b sppStream) - (IRIS.SENDO value sppStream) - else (IRIS\ERROR %'IRIS.SETBUTTON %' (b value]) - -(IRIS.SETCURSOR - [LAMBDA (index color wtm sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND index color wtm) - then (IRIS.GCMD 161 sppStream) - (IRIS.SENDS index sppStream) - (IRIS.SENDS color sppStream) - (IRIS.SENDS wtm sppStream) - else (IRIS\ERROR %'IRIS.SETCURSOR %' (index color wtm]) - -(IRIS.SETDEPTH - [LAMBDA (near far sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND near far) - then (IRIS.GCMD 162 sppStream) - (IRIS.SENDS near sppStream) - (IRIS.SENDS far sppStream) - else (IRIS\ERROR %'IRIS.SETDEPTH %' (near far]) - -(IRIS.SETLINESTYLE - [LAMBDA (index sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if index - then (IRIS.GCMD 163 sppStream) - (IRIS.SENDS index sppStream) - else (IRIS\ERROR %'IRIS.SETLINESTYLE %' (index]) - -(IRIS.SETMAP - [LAMBDA (mapnum sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if mapnum - then (IRIS.GCMD 164 sppStream) - (IRIS.SENDS mapnum sppStream) - else (IRIS\ERROR %'IRIS.SETMAP %' (mapnum]) - -(IRIS.SETVALUATOR - [LAMBDA (v init min max sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND v init min max) - then (IRIS.GCMD 167 sppStream) - (IRIS.SENDS v sppStream) - (IRIS.SENDS init sppStream) - (IRIS.SENDS min sppStream) - (IRIS.SENDS max sppStream) - else (IRIS\ERROR %'IRIS.SETVALUATOR %' (v init min max]) - -(IRIS.SINGLEBUFFER - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 168 sppStream]) - -(IRIS.STRWIDTH - [LAMBDA (str sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if str - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 169 sppStream) - (IRIS.SENDC str sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.STRWIDTH %' (str]) - -(IRIS.SWAPBUFFERS - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 170 sppStream]) - -(IRIS.SWAPINTERVAL - [LAMBDA (i sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if i - then (IRIS.GCMD 171 sppStream) - (IRIS.SENDS i sppStream) - else (IRIS\ERROR %'IRIS.SWAPINTERVAL %' (i]) - -(IRIS.GSYNC - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 172 sppStream]) - -(IRIS.TIE - [LAMBDA (b v1 v2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND b v1 v2) - then (IRIS.GCMD 173 sppStream) - (IRIS.SENDS b sppStream) - (IRIS.SENDS v1 sppStream) - (IRIS.SENDS v2 sppStream) - else (IRIS\ERROR %'IRIS.TIE %' (b v1 v2]) - -(IRIS.TRANSLATE - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 175 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.TRANSLATE %' (x y z]) - -(IRIS.VIEWPORT - [LAMBDA (left right bottom top sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top) - then (IRIS.GCMD 179 sppStream) - (IRIS.SENDS left sppStream) - (IRIS.SENDS right sppStream) - (IRIS.SENDS bottom sppStream) - (IRIS.SENDS top sppStream) - else (IRIS\ERROR %'IRIS.VIEWPORT %' (left right bottom top]) - -(IRIS.WINDOW - [LAMBDA (left right bottom top near far sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top near far) - then (IRIS.GCMD 180 sppStream) - (IRIS.SENDF left sppStream) - (IRIS.SENDF right sppStream) - (IRIS.SENDF bottom sppStream) - (IRIS.SENDF top sppStream) - (IRIS.SENDF near sppStream) - (IRIS.SENDF far sppStream) - else (IRIS\ERROR %'IRIS.WINDOW %' (left right bottom top near far]) - -(IRIS.WRITEMASK - [LAMBDA (wtm sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if wtm - then (IRIS.GCMD 181 sppStream) - (IRIS.SENDS wtm sppStream) - else (IRIS\ERROR %'IRIS.WRITEMASK %' (wtm]) - -(IRIS.WRITEPIXELS - [LAMBDA (n colors sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n colors) - then (IRIS.GCMD 182 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.SENDSS colors n sppStream) - else (IRIS\ERROR %'IRIS.WRITEPIXELS %' (n colors]) - -(IRIS.WRITERGB - [LAMBDA (n red green blue sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n red green blue) - then (IRIS.GCMD 183 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.SENDBS red n sppStream) - (IRIS.SENDBS green n sppStream) - (IRIS.SENDBS blue n sppStream) - else (IRIS\ERROR %'IRIS.WRITERGB %' (n red green blue]) - -(IRIS.TPON - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 184 sppStream]) - -(IRIS.TPOFF - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 185 sppStream]) - -(IRIS.TEXTWRITEMASK - [LAMBDA (tmask sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if tmask - then (IRIS.GCMD 187 sppStream) - (IRIS.SENDS tmask sppStream) - else (IRIS\ERROR %'IRIS.TEXTWRITEMASK %' (tmask]) - -(IRIS.XGEXIT - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 188 sppStream]) - -(IRIS.CLKON - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 189 sppStream]) - -(IRIS.CLKOFF - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 190 sppStream]) - -(IRIS.LAMPON - [LAMBDA (lamps sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if lamps - then (IRIS.GCMD 191 sppStream) - (IRIS.SENDB lamps sppStream) - else (IRIS\ERROR %'IRIS.LAMPON %' (lamps]) - -(IRIS.LAMPOFF - [LAMBDA (lamps sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if lamps - then (IRIS.GCMD 192 sppStream) - (IRIS.SENDB lamps sppStream) - else (IRIS\ERROR %'IRIS.LAMPOFF %' (lamps]) - -(IRIS.SETBELL - [LAMBDA (arg sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if arg - then (IRIS.GCMD 193 sppStream) - (IRIS.SENDB arg sppStream) - else (IRIS\ERROR %'IRIS.SETBELL %' (arg]) - -(IRIS.RINGBELL - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 194 sppStream]) - -(IRIS.TADELAY - [LAMBDA (arg1 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if arg1 - then (IRIS.GCMD 195 sppStream) - (IRIS.SENDS arg1 sppStream) - else (IRIS\ERROR %'IRIS.TADELAY %' (arg1]) - -(IRIS.ARCFS - [LAMBDA (x y radius startang endang sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius startang endang) - then (IRIS.GCMD 196 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS radius sppStream) - (IRIS.SENDS startang sppStream) - (IRIS.SENDS endang sppStream) - else (IRIS\ERROR %'IRIS.ARCFS %' (x y radius startang endang]) - -(IRIS.ARCS - [LAMBDA (x y radius startang endang sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius startang endang) - then (IRIS.GCMD 197 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS radius sppStream) - (IRIS.SENDS startang sppStream) - (IRIS.SENDS endang sppStream) - else (IRIS\ERROR %'IRIS.ARCS %' (x y radius startang endang]) - -(IRIS.BBOX2S - [LAMBDA (xmin ymin x1 y1 x2 y2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND xmin ymin x1 y1 x2 y2) - then (IRIS.GCMD 199 sppStream) - (IRIS.SENDS xmin sppStream) - (IRIS.SENDS ymin sppStream) - (IRIS.SENDS x1 sppStream) - (IRIS.SENDS y1 sppStream) - (IRIS.SENDS x2 sppStream) - (IRIS.SENDS y2 sppStream) - else (IRIS\ERROR %'IRIS.BBOX2S %' (xmin ymin x1 y1 x2 y2]) - -(IRIS.BLANKSCREEN - [LAMBDA (bool sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if bool - then (IRIS.GCMD 200 sppStream) - (IRIS.SENDO bool sppStream) - else (IRIS\ERROR %'IRIS.BLANKSCREEN %' (bool]) - -(IRIS.BLKQREAD - [LAMBDA (data n sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND data n) - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 202 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECSS data sppStream) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.BLKQREAD %' (data n]) - -(IRIS.GETMCOLOR - [LAMBDA (color r g b sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND color r g b) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 203 sppStream) - (IRIS.SENDS color sppStream) - (IRIS.FLUSHG sppStream) - (SET r (IRIS.RECS sppStream)) - (SET g (IRIS.RECS sppStream)) - (SET b (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETMCOLOR %' (color r g b]) - -(IRIS.CALLFUNC - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 204 sppStream]) - -(IRIS.CHUNKSIZE - [LAMBDA (chunk sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if chunk - then (IRIS.GCMD 205 sppStream) - (IRIS.SENDL chunk sppStream) - else (IRIS\ERROR %'IRIS.CHUNKSIZE %' (chunk]) - -(IRIS.CIRCFS - [LAMBDA (x y radius sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius) - then (IRIS.GCMD 206 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS radius sppStream) - else (IRIS\ERROR %'IRIS.CIRCFS %' (x y radius]) - -(IRIS.CIRCS - [LAMBDA (x y radius sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y radius) - then (IRIS.GCMD 207 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS radius sppStream) - else (IRIS\ERROR %'IRIS.CIRCS %' (x y radius]) - -(IRIS.CMOV2S - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 208 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - else (IRIS\ERROR %'IRIS.CMOV2S %' (x y]) - -(IRIS.CMOVS - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 209 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS z sppStream) - else (IRIS\ERROR %'IRIS.CMOVS %' (x y z]) - -(IRIS.COMPACTIFY - [LAMBDA (obj sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if obj - then (IRIS.GCMD 210 sppStream) - (IRIS.SENDL obj sppStream) - else (IRIS\ERROR %'IRIS.COMPACTIFY %' (obj]) - -(IRIS.QDEVICE - [LAMBDA (v sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if v - then (IRIS.GCMD 211 sppStream) - (IRIS.SENDS v sppStream) - else (IRIS\ERROR %'IRIS.QDEVICE %' (v]) - -(IRIS.UNQDEVICE - [LAMBDA (v sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if v - then (IRIS.GCMD 212 sppStream) - (IRIS.SENDS v sppStream) - else (IRIS\ERROR %'IRIS.UNQDEVICE %' (v]) - -(IRIS.CURVEBASIS - [LAMBDA (basisid sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if basisid - then (IRIS.GCMD 213 sppStream) - (IRIS.SENDS basisid sppStream) - else (IRIS\ERROR %'IRIS.CURVEBASIS %' (basisid]) - -(IRIS.CURVEPRECISION - [LAMBDA (nsegments sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if nsegments - then (IRIS.GCMD 214 sppStream) - (IRIS.SENDS nsegments sppStream) - else (IRIS\ERROR %'IRIS.CURVEPRECISION %' (nsegments]) - -(IRIS.CRV - [LAMBDA (geom sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if geom - then (IRIS.GCMD 215 sppStream) - (IRIS.SENDFS geom (TIMES 4 3) - sppStream) - else (IRIS\ERROR %'IRIS.CRV %' (geom]) - -(IRIS.GETTP - [LAMBDA (left right bottom top sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 216 sppStream) - (IRIS.FLUSHG sppStream) - (SET left (IRIS.RECS sppStream)) - (SET right (IRIS.RECS sppStream)) - (SET bottom (IRIS.RECS sppStream)) - (SET top (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETTP %' (left right bottom top]) - -(IRIS.GBEGIN - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 217 sppStream]) - -(IRIS.TEXTINIT - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 218 sppStream]) - -(IRIS.CRVN - [LAMBDA (n geom sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n geom) - then (IRIS.GCMD 219 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDFS geom (TIMES 3 n) - sppStream) - else (IRIS\ERROR %'IRIS.CRVN %' (n geom]) - -(IRIS.DEFBASIS - [LAMBDA (id matrix sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND id matrix) - then (IRIS.GCMD 220 sppStream) - (IRIS.SENDS id sppStream) - (IRIS.SENDFS matrix 16 sppStream) - else (IRIS\ERROR %'IRIS.DEFBASIS %' (id matrix]) - -(IRIS.DELTAG - [LAMBDA (t sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if t - then (IRIS.GCMD 221 sppStream) - (IRIS.SENDL t sppStream) - else (IRIS\ERROR %'IRIS.DELTAG %' (t]) - -(IRIS.DEPTHCUE - [LAMBDA (mode sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if mode - then (IRIS.GCMD 222 sppStream) - (IRIS.SENDO mode sppStream) - else (IRIS\ERROR %'IRIS.DEPTHCUE %' (mode]) - -(IRIS.DRAW2S - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 223 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - else (IRIS\ERROR %'IRIS.DRAW2S %' (x y]) - -(IRIS.DRAWS - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 224 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS z sppStream) - else (IRIS\ERROR %'IRIS.DRAWS %' (x y z]) - -(IRIS.ENDFEEDBACK - [LAMBDA (buffer sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if buffer - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 225 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECSS buffer sppStream) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.ENDFEEDBACK %' (buffer]) - -(IRIS.FEEDBACK - [LAMBDA (buffer size sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND buffer size) - then (IRIS.GCMD 226 sppStream) - (IRIS.SENDSS buffer 0 sppStream) - (IRIS.SENDL size sppStream) - else (IRIS\ERROR %'IRIS.FEEDBACK %' (buffer size]) - -(IRIS.GETCPOS - [LAMBDA (ix iy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND ix iy) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 227 sppStream) - (IRIS.FLUSHG sppStream) - (SET ix (IRIS.RECS sppStream)) - (SET iy (IRIS.RECS sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETCPOS %' (ix iy]) - -(IRIS.GETDCM - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 228 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETGPOS - [LAMBDA (x y z w sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z w) - then (IRIS.ECHOFF sppStream) - (IRIS.GCMD 229 sppStream) - (IRIS.FLUSHG sppStream) - (SET x (IRIS.RECF sppStream)) - (SET y (IRIS.RECF sppStream)) - (SET z (IRIS.RECF sppStream)) - (SET w (IRIS.RECF sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - else (IRIS\ERROR %'IRIS.GETGPOS %' (x y z w]) - -(IRIS.GETLSREPEAT - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 230 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETMEM - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 231 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETMONITOR - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 232 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETOPENOBJ - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 233 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GETZBUFFER - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 234 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECO sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.GEWRITE - [LAMBDA (arg1 arg2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND arg1 arg2) - then (IRIS.GCMD 235 sppStream) - (IRIS.SENDSS arg1 arg2 sppStream) - (IRIS.SENDL arg2 sppStream) - else (IRIS\ERROR %'IRIS.GEWRITE %' (arg1 arg2]) - -(IRIS.INITNAMES - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 236 sppStream]) - -(IRIS.LOADNAME - [LAMBDA (name sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if name - then (IRIS.GCMD 237 sppStream) - (IRIS.SENDS name sppStream) - else (IRIS\ERROR %'IRIS.LOADNAME %' (name]) - -(IRIS.LSREPEAT - [LAMBDA (factor sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if factor - then (IRIS.GCMD 238 sppStream) - (IRIS.SENDL factor sppStream) - else (IRIS\ERROR %'IRIS.LSREPEAT %' (factor]) - -(IRIS.MOVE2S - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 239 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - else (IRIS\ERROR %'IRIS.MOVE2S %' (x y]) - -(IRIS.MOVES - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 240 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS z sppStream) - else (IRIS\ERROR %'IRIS.MOVES %' (x y z]) - -(IRIS.NEWTAG - [LAMBDA (newtag oldtag offset sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND newtag oldtag offset) - then (IRIS.GCMD 241 sppStream) - (IRIS.SENDL newtag sppStream) - (IRIS.SENDL oldtag sppStream) - (IRIS.SENDL offset sppStream) - else (IRIS\ERROR %'IRIS.NEWTAG %' (newtag oldtag offset]) - -(IRIS.PASSTHROUGH - [LAMBDA (token sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if token - then (IRIS.GCMD 242 sppStream) - (IRIS.SENDS token sppStream) - else (IRIS\ERROR %'IRIS.PASSTHROUGH %' (token]) - -(IRIS.PATCHBASIS - [LAMBDA (uid vid sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND uid vid) - then (IRIS.GCMD 243 sppStream) - (IRIS.SENDL uid sppStream) - (IRIS.SENDL vid sppStream) - else (IRIS\ERROR %'IRIS.PATCHBASIS %' (uid vid]) - -(IRIS.PATCHPRECISION - [LAMBDA (usegments vsegments sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND usegments vsegments) - then (IRIS.GCMD 244 sppStream) - (IRIS.SENDL usegments sppStream) - (IRIS.SENDL vsegments sppStream) - else (IRIS\ERROR %'IRIS.PATCHPRECISION %' (usegments vsegments]) - -(IRIS.PATCH - [LAMBDA (geomx geomy geomz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND geomx geomy geomz) - then (IRIS.GCMD 245 sppStream) - (IRIS.SENDFS geomx 16 sppStream) - (IRIS.SENDFS geomy 16 sppStream) - (IRIS.SENDFS geomz 16 sppStream) - else (IRIS\ERROR %'IRIS.PATCH %' (geomx geomy geomz]) - -(IRIS.PCLOS - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 246 sppStream]) - -(IRIS.PDR - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 247 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.PDR %' (x y z]) - -(IRIS.PDR2 - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 248 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - else (IRIS\ERROR %'IRIS.PDR2 %' (x y]) - -(IRIS.PDRI - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 249 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL z sppStream) - else (IRIS\ERROR %'IRIS.PDRI %' (x y z]) - -(IRIS.PDR2I - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 250 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - else (IRIS\ERROR %'IRIS.PDR2I %' (x y]) - -(IRIS.PDRS - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 251 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS z sppStream) - else (IRIS\ERROR %'IRIS.PDRS %' (x y z]) - -(IRIS.PDR2S - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 252 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - else (IRIS\ERROR %'IRIS.PDR2S %' (x y]) - -(IRIS.POLF2S - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 253 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDSS parray (TIMES 2 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLF2S %' (n parray]) - -(IRIS.POLFS - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 254 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDSS parray (TIMES 3 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLFS %' (n parray]) - -(IRIS.POLY2S - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 255 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDSS parray (TIMES 2 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLY2S %' (n parray]) - -(IRIS.POLYS - [LAMBDA (n parray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray) - then (IRIS.GCMD 256 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDSS parray (TIMES 3 n) - sppStream) - else (IRIS\ERROR %'IRIS.POLYS %' (n parray]) - -(IRIS.PMV - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 257 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.PMV %' (x y z]) - -(IRIS.PMV2 - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 258 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - else (IRIS\ERROR %'IRIS.PMV2 %' (x y]) - -(IRIS.PMVI - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 259 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL z sppStream) - else (IRIS\ERROR %'IRIS.PMVI %' (x y z]) - -(IRIS.PMV2I - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 260 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - else (IRIS\ERROR %'IRIS.PMV2I %' (x y]) - -(IRIS.PMVS - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 261 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS z sppStream) - else (IRIS\ERROR %'IRIS.PMVS %' (x y z]) - -(IRIS.PMV2S - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 262 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - else (IRIS\ERROR %'IRIS.PMV2S %' (x y]) - -(IRIS.PNT2S - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 263 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - else (IRIS\ERROR %'IRIS.PNT2S %' (x y]) - -(IRIS.PNTS - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 264 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS z sppStream) - else (IRIS\ERROR %'IRIS.PNTS %' (x y z]) - -(IRIS.POPNAME - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 265 sppStream]) - -(IRIS.PUSHNAME - [LAMBDA (name sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if name - then (IRIS.GCMD 266 sppStream) - (IRIS.SENDS name sppStream) - else (IRIS\ERROR %'IRIS.PUSHNAME %' (name]) - -(IRIS.RDR - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 267 sppStream) - (IRIS.SENDF dx sppStream) - (IRIS.SENDF dy sppStream) - (IRIS.SENDF dz sppStream) - else (IRIS\ERROR %'IRIS.RDR %' (dx dy dz]) - -(IRIS.RDR2 - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 268 sppStream) - (IRIS.SENDF dx sppStream) - (IRIS.SENDF dy sppStream) - else (IRIS\ERROR %'IRIS.RDR2 %' (dx dy]) - -(IRIS.RDRI - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 269 sppStream) - (IRIS.SENDL dx sppStream) - (IRIS.SENDL dy sppStream) - (IRIS.SENDL dz sppStream) - else (IRIS\ERROR %'IRIS.RDRI %' (dx dy dz]) - -(IRIS.RDR2I - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 270 sppStream) - (IRIS.SENDL dx sppStream) - (IRIS.SENDL dy sppStream) - else (IRIS\ERROR %'IRIS.RDR2I %' (dx dy]) - -(IRIS.RDRS - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 271 sppStream) - (IRIS.SENDS dx sppStream) - (IRIS.SENDS dy sppStream) - (IRIS.SENDS dz sppStream) - else (IRIS\ERROR %'IRIS.RDRS %' (dx dy dz]) - -(IRIS.RDR2S - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 272 sppStream) - (IRIS.SENDS dx sppStream) - (IRIS.SENDS dy sppStream) - else (IRIS\ERROR %'IRIS.RDR2S %' (dx dy]) - -(IRIS.RECTCOPY - [LAMBDA (left right bottom top newx newy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND left right bottom top newx newy) - then (IRIS.GCMD 273 sppStream) - (IRIS.SENDS left sppStream) - (IRIS.SENDS right sppStream) - (IRIS.SENDS bottom sppStream) - (IRIS.SENDS top sppStream) - (IRIS.SENDS newx sppStream) - (IRIS.SENDS newy sppStream) - else (IRIS\ERROR %'IRIS.RECTCOPY %' (left right bottom top newx newy]) - -(IRIS.RMV - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 274 sppStream) - (IRIS.SENDF dx sppStream) - (IRIS.SENDF dy sppStream) - (IRIS.SENDF dz sppStream) - else (IRIS\ERROR %'IRIS.RMV %' (dx dy dz]) - -(IRIS.RMV2 - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 275 sppStream) - (IRIS.SENDF dx sppStream) - (IRIS.SENDF dy sppStream) - else (IRIS\ERROR %'IRIS.RMV2 %' (dx dy]) - -(IRIS.RMVI - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 276 sppStream) - (IRIS.SENDL dx sppStream) - (IRIS.SENDL dy sppStream) - (IRIS.SENDL dz sppStream) - else (IRIS\ERROR %'IRIS.RMVI %' (dx dy dz]) - -(IRIS.RMV2I - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 277 sppStream) - (IRIS.SENDL dx sppStream) - (IRIS.SENDL dy sppStream) - else (IRIS\ERROR %'IRIS.RMV2I %' (dx dy]) - -(IRIS.RMVS - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 278 sppStream) - (IRIS.SENDS dx sppStream) - (IRIS.SENDS dy sppStream) - (IRIS.SENDS dz sppStream) - else (IRIS\ERROR %'IRIS.RMVS %' (dx dy dz]) - -(IRIS.RMV2S - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 279 sppStream) - (IRIS.SENDS dx sppStream) - (IRIS.SENDS dy sppStream) - else (IRIS\ERROR %'IRIS.RMV2S %' (dx dy]) - -(IRIS.RPDR - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 280 sppStream) - (IRIS.SENDF dx sppStream) - (IRIS.SENDF dy sppStream) - (IRIS.SENDF dz sppStream) - else (IRIS\ERROR %'IRIS.RPDR %' (dx dy dz]) - -(IRIS.RPDR2 - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 281 sppStream) - (IRIS.SENDF dx sppStream) - (IRIS.SENDF dy sppStream) - else (IRIS\ERROR %'IRIS.RPDR2 %' (dx dy]) - -(IRIS.RPDRI - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 282 sppStream) - (IRIS.SENDL dx sppStream) - (IRIS.SENDL dy sppStream) - (IRIS.SENDL dz sppStream) - else (IRIS\ERROR %'IRIS.RPDRI %' (dx dy dz]) - -(IRIS.RPDR2I - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 283 sppStream) - (IRIS.SENDL dx sppStream) - (IRIS.SENDL dy sppStream) - else (IRIS\ERROR %'IRIS.RPDR2I %' (dx dy]) - -(IRIS.RPDRS - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 284 sppStream) - (IRIS.SENDS dx sppStream) - (IRIS.SENDS dy sppStream) - (IRIS.SENDS dz sppStream) - else (IRIS\ERROR %'IRIS.RPDRS %' (dx dy dz]) - -(IRIS.RPDR2S - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 285 sppStream) - (IRIS.SENDS dx sppStream) - (IRIS.SENDS dy sppStream) - else (IRIS\ERROR %'IRIS.RPDR2S %' (dx dy]) - -(IRIS.RPMV - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 286 sppStream) - (IRIS.SENDF dx sppStream) - (IRIS.SENDF dy sppStream) - (IRIS.SENDF dz sppStream) - else (IRIS\ERROR %'IRIS.RPMV %' (dx dy dz]) - -(IRIS.RPMV2 - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 287 sppStream) - (IRIS.SENDF dx sppStream) - (IRIS.SENDF dy sppStream) - else (IRIS\ERROR %'IRIS.RPMV2 %' (dx dy]) - -(IRIS.RPMVI - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 288 sppStream) - (IRIS.SENDL dx sppStream) - (IRIS.SENDL dy sppStream) - (IRIS.SENDL dz sppStream) - else (IRIS\ERROR %'IRIS.RPMVI %' (dx dy dz]) - -(IRIS.RPMV2I - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 289 sppStream) - (IRIS.SENDL dx sppStream) - (IRIS.SENDL dy sppStream) - else (IRIS\ERROR %'IRIS.RPMV2I %' (dx dy]) - -(IRIS.RPMVS - [LAMBDA (dx dy dz sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy dz) - then (IRIS.GCMD 290 sppStream) - (IRIS.SENDS dx sppStream) - (IRIS.SENDS dy sppStream) - (IRIS.SENDS dz sppStream) - else (IRIS\ERROR %'IRIS.RPMVS %' (dx dy dz]) - -(IRIS.RPMV2S - [LAMBDA (dx dy sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND dx dy) - then (IRIS.GCMD 291 sppStream) - (IRIS.SENDS dx sppStream) - (IRIS.SENDS dy sppStream) - else (IRIS\ERROR %'IRIS.RPMV2S %' (dx dy]) - -(IRIS.SETDBLIGHTS - [LAMBDA (mask sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if mask - then (IRIS.GCMD 292 sppStream) - (IRIS.SENDL mask sppStream) - else (IRIS\ERROR %'IRIS.SETDBLIGHTS %' (mask]) - -(IRIS.SETMONITOR - [LAMBDA (type sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if type - then (IRIS.GCMD 293 sppStream) - (IRIS.SENDS type sppStream) - else (IRIS\ERROR %'IRIS.SETMONITOR %' (type]) - -(IRIS.SETSHADE - [LAMBDA (shade sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if shade - then (IRIS.GCMD 294 sppStream) - (IRIS.SENDS shade sppStream) - else (IRIS\ERROR %'IRIS.SETSHADE %' (shade]) - -(IRIS.SHADERANGE - [LAMBDA (lowindex highindex sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND lowindex highindex) - then (IRIS.GCMD 295 sppStream) - (IRIS.SENDS lowindex sppStream) - (IRIS.SENDS highindex sppStream) - else (IRIS\ERROR %'IRIS.SHADERANGE %' (lowindex highindex]) - -(IRIS.SPCLOS - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 296 sppStream]) - -(IRIS.SPLF - [LAMBDA (n parray iarray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray iarray) - then (IRIS.GCMD 297 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDFS parray (TIMES 3 n) - sppStream) - (IRIS.SENDSS iarray n sppStream) - else (IRIS\ERROR %'IRIS.SPLF %' (n parray iarray]) - -(IRIS.SPLF2 - [LAMBDA (n parray iarray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray iarray) - then (IRIS.GCMD 298 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDFS parray (TIMES 2 n) - sppStream) - (IRIS.SENDSS iarray n sppStream) - else (IRIS\ERROR %'IRIS.SPLF2 %' (n parray iarray]) - -(IRIS.SPLFI - [LAMBDA (n parray iarray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray iarray) - then (IRIS.GCMD 299 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDLS parray (TIMES 3 n) - sppStream) - (IRIS.SENDSS iarray n sppStream) - else (IRIS\ERROR %'IRIS.SPLFI %' (n parray iarray]) - -(IRIS.SPLF2I - [LAMBDA (n parray iarray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray iarray) - then (IRIS.GCMD 300 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDLS parray (TIMES 2 n) - sppStream) - (IRIS.SENDSS iarray n sppStream) - else (IRIS\ERROR %'IRIS.SPLF2I %' (n parray iarray]) - -(IRIS.SPLFS - [LAMBDA (n parray iarray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray iarray) - then (IRIS.GCMD 301 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDSS parray (TIMES 3 n) - sppStream) - (IRIS.SENDSS iarray n sppStream) - else (IRIS\ERROR %'IRIS.SPLFS %' (n parray iarray]) - -(IRIS.SPLF2S - [LAMBDA (n parray iarray sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n parray iarray) - then (IRIS.GCMD 302 sppStream) - (IRIS.SENDL n sppStream) - (IRIS.SENDSS parray (TIMES 2 n) - sppStream) - (IRIS.SENDSS iarray n sppStream) - else (IRIS\ERROR %'IRIS.SPLF2S %' (n parray iarray]) - -(IRIS.XFPT - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 303 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - else (IRIS\ERROR %'IRIS.XFPT %' (x y z]) - -(IRIS.XFPTI - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 304 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL z sppStream) - else (IRIS\ERROR %'IRIS.XFPTI %' (x y z]) - -(IRIS.XFPTS - [LAMBDA (x y z sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z) - then (IRIS.GCMD 305 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS z sppStream) - else (IRIS\ERROR %'IRIS.XFPTS %' (x y z]) - -(IRIS.XFPT2 - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 306 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - else (IRIS\ERROR %'IRIS.XFPT2 %' (x y]) - -(IRIS.XFPT2I - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 307 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - else (IRIS\ERROR %'IRIS.XFPT2I %' (x y]) - -(IRIS.XFPT2S - [LAMBDA (x y sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y) - then (IRIS.GCMD 308 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - else (IRIS\ERROR %'IRIS.XFPT2S %' (x y]) - -(IRIS.XFPT4 - [LAMBDA (x y z w sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z w) - then (IRIS.GCMD 309 sppStream) - (IRIS.SENDF x sppStream) - (IRIS.SENDF y sppStream) - (IRIS.SENDF z sppStream) - (IRIS.SENDF w sppStream) - else (IRIS\ERROR %'IRIS.XFPT4 %' (x y z w]) - -(IRIS.XFPT4I - [LAMBDA (x y z w sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z w) - then (IRIS.GCMD 310 sppStream) - (IRIS.SENDL x sppStream) - (IRIS.SENDL y sppStream) - (IRIS.SENDL z sppStream) - (IRIS.SENDL w sppStream) - else (IRIS\ERROR %'IRIS.XFPT4I %' (x y z w]) - -(IRIS.XFPT4S - [LAMBDA (x y z w sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND x y z w) - then (IRIS.GCMD 311 sppStream) - (IRIS.SENDS x sppStream) - (IRIS.SENDS y sppStream) - (IRIS.SENDS z sppStream) - (IRIS.SENDS w sppStream) - else (IRIS\ERROR %'IRIS.XFPT4S %' (x y z w]) - -(IRIS.ZBUFFER - [LAMBDA (bool sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if bool - then (IRIS.GCMD 312 sppStream) - (IRIS.SENDO bool sppStream) - else (IRIS\ERROR %'IRIS.ZBUFFER %' (bool]) - -(IRIS.CHARST - [LAMBDA (arg1 arg2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND arg1 arg2) - then (IRIS.GCMD 313 sppStream) - (IRIS.SENDBS arg1 arg2 sppStream) - (IRIS.SENDL arg2 sppStream) - else (IRIS\ERROR %'IRIS.CHARST %' (arg1 arg2]) - -(IRIS.STRWID - [LAMBDA (arg1 arg2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND arg1 arg2) - then (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 314 sppStream) - (IRIS.SENDBS arg1 arg2 sppStream) - (IRIS.SENDL arg2 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval) - else (IRIS\ERROR %'IRIS.STRWID %' (arg1 arg2]) - -(IRIS.DEFPATTERN - [LAMBDA (n size mask sppStream) (* LeL, " 9-Sep-85 04:19") - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n size mask) - then (IRIS.GCMD 315 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.SENDS size sppStream) - (IRIS.SENDSS mask (QUOTIENT (TIMES size size) - 16) - sppStream) - else (IRIS\ERROR %'IRIS.DEFPATTERN %' (n size mask]) - -(IRIS.GETPATTERN - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (LET (retval) - (IRIS.ECHOFF sppStream) - (IRIS.GCMD 316 sppStream) - (IRIS.FLUSHG sppStream) - (SETQ retval (IRIS.RECL sppStream)) - (IRIS.RECCR sppStream) - (IRIS.ECHOON sppStream) - retval]) - -(IRIS.SETPATTERN - [LAMBDA (index sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if index - then (IRIS.GCMD 317 sppStream) - (IRIS.SENDS index sppStream) - else (IRIS\ERROR %'IRIS.SETPATTERN %' (index]) - -(IRIS.OBJINSERT - [LAMBDA (t sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if t - then (IRIS.GCMD 318 sppStream) - (IRIS.SENDL t sppStream) - else (IRIS\ERROR %'IRIS.OBJINSERT %' (t]) - -(IRIS.OBJDELETE - [LAMBDA (tag1 tag2 sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND tag1 tag2) - then (IRIS.GCMD 319 sppStream) - (IRIS.SENDL tag1 sppStream) - (IRIS.SENDL tag2 sppStream) - else (IRIS\ERROR %'IRIS.OBJDELETE %' (tag1 tag2]) - -(IRIS.OBJREPLACE - [LAMBDA (t sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if t - then (IRIS.GCMD 320 sppStream) - (IRIS.SENDL t sppStream) - else (IRIS\ERROR %'IRIS.OBJREPLACE %' (t]) - -(IRIS.ZCLEAR - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 321 sppStream]) - -(IRIS.CURORIGIN - [LAMBDA (n xorigin yorigin sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND n xorigin yorigin) - then (IRIS.GCMD 322 sppStream) - (IRIS.SENDS n sppStream) - (IRIS.SENDS xorigin sppStream) - (IRIS.SENDS yorigin sppStream) - else (IRIS\ERROR %'IRIS.CURORIGIN %' (n xorigin yorigin]) - -(IRIS.PAGEWRITEMASK - [LAMBDA (arg sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if arg - then (IRIS.GCMD 323 sppStream) - (IRIS.SENDS arg sppStream) - else (IRIS\ERROR %'IRIS.PAGEWRITEMASK %' (arg]) - -(IRIS.PATCHCURVES - [LAMBDA (ucurves vcurves sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if (AND ucurves vcurves) - then (IRIS.GCMD 324 sppStream) - (IRIS.SENDL ucurves sppStream) - (IRIS.SENDL vcurves sppStream) - else (IRIS\ERROR %'IRIS.PATCHCURVES %' (ucurves vcurves]) - -(IRIS.DBTEXT - [LAMBDA (str sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (if str - then (IRIS.GCMD 325 sppStream) - (IRIS.SENDBS str 8 sppStream) - else (IRIS\ERROR %'IRIS.DBTEXT %' (str]) - -(IRIS.LASTONE - [LAMBDA (sppStream) - (if sppStream - then [OR (SPPSTREAM? sppStream) - (SETQ sppStream (fetch SPPOUTSTREAM of (fetch IRISDATA of sppStream] - else (SETQ sppStream IRISCONN)) - (IRIS.GCMD 326 sppStream]) - -(IRIS\ERROR - [LAMBDA (FNNAME FNARGS) (* ; "Edited 28-Jan-87 18:57 by gbn") - -(* ;;; "This function breaks whenever an IRIS library function gets a null arg") - - (ERROR (CONCAT FNNAME ": some input arg is NIL" " -") - (APPLY 'CONCAT (for ARG in FNARGS join (LIST " " ARG " = " (EVAL ARG) - " -"]) -) -(PUTPROPS IRISLIB COPYRIGHT ("Xerox Corporation" 1985 1987)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (5294 150294 (IRIS.XSETSLOWCOM 5304 . 5586) (IRIS.XSETFASTCOM 5588 . 5870) ( -IRIS.GVERSION 5872 . 6367) (IRIS.GDOWNLOAD 6369 . 6649) (IRIS.PAGECOLOR 6651 . 7069) (IRIS.TEXTCOLOR -7071 . 7489) (IRIS.TEXTPORT 7491 . 8085) (IRIS.ARC 8087 . 8727) (IRIS.ARCF 8729 . 9371) (IRIS.ARCFI -9373 . 10017) (IRIS.ARCI 10019 . 10662) (IRIS.ATTACHCURSOR 10664 . 11131) (IRIS.BACKBUFFER 11133 . -11538) (IRIS.BBOX2 11540 . 12201) (IRIS.BBOX2I 12203 . 12866) (IRIS.BLINK 12868 . 13509) (IRIS.CALLOBJ - 13511 . 13918) (IRIS.CHARSTR 13920 . 14327) (IRIS.CIRC 14329 . 14836) (IRIS.CIRCF 14838 . 15347) ( -IRIS.CIRCFI 15349 . 15860) (IRIS.CIRCI 15862 . 16371) (IRIS.CLEAR 16373 . 16650) (IRIS.CLEARHITCODE -16652 . 16936) (IRIS.CLOSEOBJ 16938 . 17218) (IRIS.CMOV 17220 . 17707) (IRIS.CMOV2 17709 . 18154) ( -IRIS.CMOV2I 18156 . 18603) (IRIS.CMOVI 18605 . 19094) (IRIS.COLOR 19096 . 19507) (IRIS.CURSOFF 19509 - . 19788) (IRIS.CURSON 19790 . 20068) (IRIS.CURVEIT 20070 . 20521) (IRIS.DEFCURSOR 20523 . 20992) ( -IRIS.DEFLINESTYLE 20994 . 21457) (IRIS.DEFRASTERFONT 21459 . 22152) (IRIS.DELOBJ 22154 . 22559) ( -IRIS.DOUBLEBUFFER 22561 . 22845) (IRIS.DRAW 22847 . 23334) (IRIS.DRAW2 23336 . 23781) (IRIS.DRAW2I -23783 . 24230) (IRIS.DRAWI 24232 . 24721) (IRIS.EDITOBJ 24723 . 25130) (IRIS.ENDPICK 25132 . 25835) ( -IRIS.ENDSELECT 25837 . 26544) (IRIS.FINISH 26546 . 26824) (IRIS.FONT 26826 . 27239) (IRIS.FRONTBUFFER -27241 . 27648) (IRIS.GCONFIG 27650 . 27929) (IRIS.GENOBJ 27931 . 28425) (IRIS.GENTAG 28427 . 28921) ( -IRIS.GETBUFFER 28923 . 29420) (IRIS.GETBUTTON 29422 . 30109) (IRIS.GETCMMODE 30111 . 30608) ( -IRIS.GETCOLOR 30610 . 31106) (IRIS.GETCURSOR 31108 . 31856) (IRIS.GETDEPTH 31858 . 32486) ( -IRIS.GETDISPLAYMODE 32488 . 32990) (IRIS.GETFONT 32992 . 33487) (IRIS.GETHEIGHT 33489 . 33986) ( -IRIS.GETHITCODE 33988 . 34486) (IRIS.GETLSBACKUP 34488 . 34987) (IRIS.GETLSTYLE 34989 . 35486) ( -IRIS.GETLWIDTH 35488 . 35985) (IRIS.GETMAP 35987 . 36481) (IRIS.GETMATRIX 36483 . 37033) ( -IRIS.GETPLANES 37035 . 37532) (IRIS.GETRESETLS 37534 . 38032) (IRIS.GETSCRMASK 38034 . 38800) ( -IRIS.GETVALUATOR 38802 . 39493) (IRIS.GETVIEWPORT 39495 . 40263) (IRIS.GETWRITEMASK 40265 . 40765) ( -IRIS.XGINIT 40767 . 41045) (IRIS.XGRESET 41047 . 41326) (IRIS.GRGBCOLOR 41328 . 42023) ( -IRIS.GRGBCURSOR 42025 . 43027) (IRIS.GRGBMASK 43029 . 43730) (IRIS.ISOBJ 43732 . 44419) (IRIS.ISTAG -44421 . 45100) (IRIS.LINEWIDTH 45102 . 45505) (IRIS.LOADMATRIX 45507 . 45916) (IRIS.LOOKAT 45918 . -46625) (IRIS.LSBACKUP 46627 . 47028) (IRIS.MAKEOBJ 47030 . 47437) (IRIS.MAKETAG 47439 . 47838) ( -IRIS.MAPCOLOR 47840 . 48431) (IRIS.MAPW 48433 . 49429) (IRIS.MAPW2 49431 . 50194) (IRIS.MOVE 50196 . -50684) (IRIS.MOVE2 50686 . 51132) (IRIS.MOVE2I 51134 . 51582) (IRIS.MOVEI 51584 . 52074) ( -IRIS.MULTIMAP 52076 . 52357) (IRIS.MULTMATRIX 52359 . 52769) (IRIS.NOISE 52771 . 53233) (IRIS.ONEMAP -53235 . 53514) (IRIS.ORTHO 53516 . 54214) (IRIS.ORTHO2 54216 . 54808) (IRIS.PERSPECTIVE 54810 . 55408) - (IRIS.PICK 55410 . 55963) (IRIS.PICKSIZE 55965 . 56457) (IRIS.PNT 56459 . 56945) (IRIS.PNT2 56947 . -57391) (IRIS.PNT2I 57393 . 57839) (IRIS.PNTI 57841 . 58329) (IRIS.POLARVIEW 58331 . 58921) (IRIS.POLF -58923 . 59420) (IRIS.POLF2 59422 . 59921) (IRIS.POLF2I 59923 . 60424) (IRIS.POLFI 60426 . 60925) ( -IRIS.POLY 60927 . 61424) (IRIS.POLY2 61426 . 61925) (IRIS.POLY2I 61927 . 62428) (IRIS.POLYI 62430 . -62929) (IRIS.POPATTRIBUTES 62931 . 63217) (IRIS.POPMATRIX 63219 . 63501) (IRIS.POPVIEWPORT 63503 . -63787) (IRIS.PUSHATTRIBUTES 63789 . 64076) (IRIS.PUSHMATRIX 64078 . 64361) (IRIS.PUSHVIEWPORT 64363 . -64648) (IRIS.QENTER 64650 . 65122) (IRIS.QREAD 65124 . 65821) (IRIS.QRESET 65823 . 66102) (IRIS.QTEST -66104 . 66598) (IRIS.READPIXELS 66600 . 67365) (IRIS.READRGB 67367 . 68240) (IRIS.RECT 68242 . 68790) -(IRIS.RECTF 68792 . 69342) (IRIS.RECTFI 69344 . 69896) (IRIS.RECTI 69898 . 70448) (IRIS.RESETLS 70450 - . 70850) (IRIS.RGBCOLOR 70852 . 71384) (IRIS.RGBCURSOR 71386 . 72156) (IRIS.RGBMODE 72158 . 72438) ( -IRIS.RGBWRITEMASK 72440 . 72980) (IRIS.ROTATE 72982 . 73442) (IRIS.SCALE 73444 . 73934) (IRIS.SCRMASK -73936 . 74530) (IRIS.SELECT 74532 . 75031) (IRIS.SETBUTTON 75033 . 75503) (IRIS.SETCURSOR 75505 . -76043) (IRIS.SETDEPTH 76045 . 76517) (IRIS.SETLINESTYLE 76519 . 76945) (IRIS.SETMAP 76947 . 77365) ( -IRIS.SETVALUATOR 77367 . 77941) (IRIS.SINGLEBUFFER 77943 . 78228) (IRIS.STRWIDTH 78230 . 78924) ( -IRIS.SWAPBUFFERS 78926 . 79210) (IRIS.SWAPINTERVAL 79212 . 79622) (IRIS.GSYNC 79624 . 79902) (IRIS.TIE - 79904 . 80398) (IRIS.TRANSLATE 80400 . 80898) (IRIS.VIEWPORT 80900 . 81496) (IRIS.WINDOW 81498 . -82198) (IRIS.WRITEMASK 82200 . 82612) (IRIS.WRITEPIXELS 82614 . 83095) (IRIS.WRITERGB 83097 . 83682) ( -IRIS.TPON 83684 . 83961) (IRIS.TPOFF 83963 . 84241) (IRIS.TEXTWRITEMASK 84243 . 84671) (IRIS.XGEXIT -84673 . 84952) (IRIS.CLKON 84954 . 85232) (IRIS.CLKOFF 85234 . 85513) (IRIS.LAMPON 85515 . 85929) ( -IRIS.LAMPOFF 85931 . 86347) (IRIS.SETBELL 86349 . 86757) (IRIS.RINGBELL 86759 . 87040) (IRIS.TADELAY -87042 . 87454) (IRIS.ARCFS 87456 . 88102) (IRIS.ARCS 88104 . 88748) (IRIS.BBOX2S 88750 . 89414) ( -IRIS.BLANKSCREEN 89416 . 89836) (IRIS.BLKQREAD 89838 . 90591) (IRIS.GETMCOLOR 90593 . 91313) ( -IRIS.CALLFUNC 91315 . 91596) (IRIS.CHUNKSIZE 91598 . 92018) (IRIS.CIRCFS 92020 . 92532) (IRIS.CIRCS -92534 . 93044) (IRIS.CMOV2S 93046 . 93494) (IRIS.CMOVS 93496 . 93986) (IRIS.COMPACTIFY 93988 . 94402) -(IRIS.QDEVICE 94404 . 94804) (IRIS.UNQDEVICE 94806 . 95210) (IRIS.CURVEBASIS 95212 . 95642) ( -IRIS.CURVEPRECISION 95644 . 96090) (IRIS.CRV 96092 . 96529) (IRIS.GETTP 96531 . 97288) (IRIS.GBEGIN -97290 . 97569) (IRIS.TEXTINIT 97571 . 97852) (IRIS.CRVN 97854 . 98343) (IRIS.DEFBASIS 98345 . 98825) ( -IRIS.DELTAG 98827 . 99225) (IRIS.DEPTHCUE 99227 . 99641) (IRIS.DRAW2S 99643 . 100091) (IRIS.DRAWS -100093 . 100583) (IRIS.ENDFEEDBACK 100585 . 101297) (IRIS.FEEDBACK 101299 . 101786) (IRIS.GETCPOS -101788 . 102403) (IRIS.GETDCM 102405 . 102900) (IRIS.GETGPOS 102902 . 103607) (IRIS.GETLSREPEAT 103609 - . 104109) (IRIS.GETMEM 104111 . 104606) (IRIS.GETMONITOR 104608 . 105107) (IRIS.GETOPENOBJ 105109 . -105608) (IRIS.GETZBUFFER 105610 . 106109) (IRIS.GEWRITE 106111 . 106591) (IRIS.INITNAMES 106593 . -106875) (IRIS.LOADNAME 106877 . 107291) (IRIS.LSREPEAT 107293 . 107715) (IRIS.MOVE2S 107717 . 108165) -(IRIS.MOVES 108167 . 108657) (IRIS.NEWTAG 108659 . 109211) (IRIS.PASSTHROUGH 109213 . 109637) ( -IRIS.PATCHBASIS 109639 . 110111) (IRIS.PATCHPRECISION 110113 . 110641) (IRIS.PATCH 110643 . 111193) ( -IRIS.PCLOS 111195 . 111473) (IRIS.PDR 111475 . 111961) (IRIS.PDR2 111963 . 112407) (IRIS.PDRI 112409 - . 112897) (IRIS.PDR2I 112899 . 113345) (IRIS.PDRS 113347 . 113835) (IRIS.PDR2S 113837 . 114283) ( -IRIS.POLF2S 114285 . 114786) (IRIS.POLFS 114788 . 115287) (IRIS.POLY2S 115289 . 115790) (IRIS.POLYS -115792 . 116291) (IRIS.PMV 116293 . 116779) (IRIS.PMV2 116781 . 117225) (IRIS.PMVI 117227 . 117715) ( -IRIS.PMV2I 117717 . 118163) (IRIS.PMVS 118165 . 118653) (IRIS.PMV2S 118655 . 119101) (IRIS.PNT2S -119103 . 119549) (IRIS.PNTS 119551 . 120039) (IRIS.POPNAME 120041 . 120321) (IRIS.PUSHNAME 120323 . -120737) (IRIS.RDR 120739 . 121237) (IRIS.RDR2 121239 . 121691) (IRIS.RDRI 121693 . 122193) (IRIS.RDR2I - 122195 . 122649) (IRIS.RDRS 122651 . 123151) (IRIS.RDR2S 123153 . 123607) (IRIS.RECTCOPY 123609 . -124317) (IRIS.RMV 124319 . 124817) (IRIS.RMV2 124819 . 125271) (IRIS.RMVI 125273 . 125773) (IRIS.RMV2I - 125775 . 126229) (IRIS.RMVS 126231 . 126731) (IRIS.RMV2S 126733 . 127187) (IRIS.RPDR 127189 . 127689) - (IRIS.RPDR2 127691 . 128145) (IRIS.RPDRI 128147 . 128649) (IRIS.RPDR2I 128651 . 129107) (IRIS.RPDRS -129109 . 129611) (IRIS.RPDR2S 129613 . 130069) (IRIS.RPMV 130071 . 130571) (IRIS.RPMV2 130573 . 131027 -) (IRIS.RPMVI 131029 . 131531) (IRIS.RPMV2I 131533 . 131989) (IRIS.RPMVS 131991 . 132493) (IRIS.RPMV2S - 132495 . 132951) (IRIS.SETDBLIGHTS 132953 . 133373) (IRIS.SETMONITOR 133375 . 133793) (IRIS.SETSHADE -133795 . 134213) (IRIS.SHADERANGE 134215 . 134731) (IRIS.SPCLOS 134733 . 135012) (IRIS.SPLF 135014 . -135578) (IRIS.SPLF2 135580 . 136146) (IRIS.SPLFI 136148 . 136714) (IRIS.SPLF2I 136716 . 137284) ( -IRIS.SPLFS 137286 . 137852) (IRIS.SPLF2S 137854 . 138422) (IRIS.XFPT 138424 . 138912) (IRIS.XFPTI -138914 . 139404) (IRIS.XFPTS 139406 . 139896) (IRIS.XFPT2 139898 . 140344) (IRIS.XFPT2I 140346 . -140794) (IRIS.XFPT2S 140796 . 141244) (IRIS.XFPT4 141246 . 141780) (IRIS.XFPT4I 141782 . 142318) ( -IRIS.XFPT4S 142320 . 142856) (IRIS.ZBUFFER 142858 . 143270) (IRIS.CHARST 143272 . 143750) (IRIS.STRWID - 143752 . 144519) (IRIS.DEFPATTERN 144521 . 145198) (IRIS.GETPATTERN 145200 . 145699) (IRIS.SETPATTERN - 145701 . 146123) (IRIS.OBJINSERT 146125 . 146529) (IRIS.OBJDELETE 146531 . 147009) (IRIS.OBJREPLACE -147011 . 147417) (IRIS.ZCLEAR 147419 . 147698) (IRIS.CURORIGIN 147700 . 148246) (IRIS.PAGEWRITEMASK -148248 . 148668) (IRIS.PATCHCURVES 148670 . 149176) (IRIS.DBTEXT 149178 . 149587) (IRIS.LASTONE 149589 - . 149869) (IRIS\ERROR 149871 . 150292))))) -STOP diff --git a/obsolete/lispusers/IRISNET b/obsolete/lispusers/IRISNET deleted file mode 100644 index 0399a862..00000000 --- a/obsolete/lispusers/IRISNET +++ /dev/null @@ -1,279 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "10-May-88 00:46:44" {ERINYES}MEDLEY>IRISNET.;1 15482 - - previous date%: " 4-Feb-87 19:47:55" {ERINYES}LYRIC>IRISNET.;1) - - -(* " -Copyright (c) 1988 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT IRISNETCOMS) - -(RPAQQ IRISNETCOMS ([DECLARE%: EVAL@LOAD DONTCOPY (P (LOADCOMP 'LLETHER) - (LOADCOMP 'ETHERRECORDS] - (FNS IRIS.RESET IRIS.TRACE IRISBOOTPROCESS SENDIRISPACKET IRISFILTER - OPEN.IRISCONN IRISBOOTSERVER) - (VARS \IRIS.VERBOSE (PRINTSPPDATAFLG T)) - (VARS (IRIS.LOCK (CREATE.MONITORLOCK "iris boot lock"))) - (GLOBALVARS IRISNSHOSTNUMBER) - [INITVARS (IRISNET 146) - (IRISBOOTDIRECTORIES '({CORE} {ERIS}gl2>boot>] - (CONSTANTS (IRISSOCKET 37) - (IRIS.PACKETTYPE 32790) - (IRIS.BOOT.STREAM.NAME '|IRIS boot SPP|)) - [DECLARE%: EVAL@LOAD DONTCOPY (FILES ETHERRECORDS) - (P (LOADCOMP 'LLETHER] - [P (ACCESSFNS IRISENCAPSULATION [(IRISBASE (LOCF (FETCH (ETHERPACKET - EPENCAPSULATION - ) - OF DATUM] - [BLOCKRECORD IRISBASE ((IRISLENGTH WORD) - (IRISDESTHOSTO 3 WORD) - (IRISSOURCEHOSTO 3 WORD) - (IRISTYPE WORD) - (IRISEXCHID WORD) - (INFOCHAR1 BYTE) - (INFOCHAR2 BYTE)) - [ACCESSFNS IRISDESTHOSTO ((IRISDESTHOST (\LOADNSHOSTNUMBER - (LOCF DATUM)) - (\STORENSHOSTNUMBER - (LOCF DATUM) - NEWVALUE)) - (IRISPACKETBASE (LOCF DATUM)) - (IRISDESTHOSTBASE (LOCF DATUM] - (ACCESSFNS IRISSOURCEHOSTO ((IRISSOURCEHOST - (\LOADNSHOSTNUMBER (LOCF DATUM) - ) - (\STORENSHOSTNUMBER - (LOCF DATUM) - NEWVALUE)) - (IRISSOURCEHOSTBASE (LOCF DATUM] - (TYPE? (type? ETHERPACKET DATUM] - (MACROS BROADCASTP))) -(DECLARE%: EVAL@LOAD DONTCOPY -(LOADCOMP 'LLETHER) -(LOADCOMP 'ETHERRECORDS) -) -(DEFINEQ - -(IRIS.RESET - [LAMBDA NIL (* gbn "24-Jun-85 01:31") - (PROG (PROC) - (CLOSEF? '{DSK}IRISBOOTFILE) - (if (SETQ PROC (FIND.PROCESS IRIS.BOOT.STREAM.NAME)) - then (DEL.PROCESS PROC)) - (if (SETQ PROC (FIND.PROCESS '|Iris Terminal SPP|)) - then (DEL.PROCESS PROC)) - (if (SETQ PROC (FIND.PROCESS 'IRISBOOTPROCESS)) - then (DEL.PROCESS PROC)) - (PROCESS.STATUS.WINDOW (CREATEPOSITION 5 5]) - -(IRIS.TRACE - [LAMBDA NIL (* gbn "25-Feb-86 12:24") - (SETQ PRINTSPPDATAFLG NIL) - (SETQ XIPIGNORETYPES '(1 TRANS)) - (XIPTRACE T]) - -(IRISBOOTPROCESS - [LAMBDA (IRISPACKET) (* gbn "12-Nov-85 23:16") - (DECLARE (GLOBALVARS IRISBOOTDIRECTORIES IRISNSADDRESS IRIS.LOCK IRISNET IRISNSHOSTNUMBER)) - (COND - ((OBTAIN.MONITORLOCK IRIS.LOCK T T) - [PROG (DH CHAR NET IRISBOOTFILE INBOOTSTREAM OUTBOOTSTREAM IRISBOOTFILENAME BOOTFILENAME TEMP - ) - (SETQ DH (fetch (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET)) - (SETQ CHAR (fetch (IRISENCAPSULATION INFOCHAR1) of IRISPACKET)) - (replace (IRISENCAPSULATION IRISDESTHOST) of IRISPACKET - with (SETQ IRISNSHOSTNUMBER (fetch (IRISENCAPSULATION IRISSOURCEHOST) - of IRISPACKET))) - (replace (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET with - \MY.NSHOSTNUMBER - ) - [COND - (\IRIS.VERBOSE - (* inform the user that a boot attempt is being made) - (FLASHWINDOW PROMPTWINDOW) - (PROMPTPRINT (CONCAT "IRIS boot initiated to: " DH] - (* "E" for "reply" to booting and "H" for "hostname" for spp connection) - (SETQ NET (fetch (XIP XIPSOURCENET) of IRISPACKET)) - (SETQ IRISNSADDRESS (create NSADDRESS - NSNET _ IRISNET - NSHOSTNUMBER _ IRISNSHOSTNUMBER)) - (* this should be using the net from the iris, but it can't be trusted. - SGI doesn't handle turning around packets properly) - (COND - ((EQ CHAR (CHARCODE C)) (* replace EPSOCKET of IRISPACKET - with 41) - (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE - E)) - (SENDIRISPACKET IRISPACKET) - (* just sends back an "E" packet with our host socket - (41) filled in) - (SETQ INBOOTSTREAM (SPP.OPEN NIL 41 NIL IRIS.BOOT.STREAM.NAME)) - (SETQ OUTBOOTSTREAM (SPPOUTPUTSTREAM INBOOTSTREAM)) - (SPP.DSTYPE INBOOTSTREAM 108) (* returns a connection which is not - yet established) - (BIN INBOOTSTREAM) - [SETQ TEMP (CONCAT (PACKC (while (SPP.READP INBOOTSTREAM) - collect (BIN INBOOTSTREAM] - [SETQ BOOTFILENAME (L-CASE (SUBSTRING TEMP (STRPOS ":*:" TEMP 1 NIL NIL T) - (SUB1 (STRPOS (CONCAT (CHARACTER 0)) - TEMP] - [COND - ((STREQUAL BOOTFILENAME (CONSTANT "defaultboot")) - (SETQ BOOTFILENAME (CONSTANT "iris"] (* This is a packet specifying the - boot file name,) - [SETQ IRISBOOTFILE (OPENSTREAM (SETQ IRISBOOTFILENAME (FINDFILE BOOTFILENAME NIL - IRISBOOTDIRECTORIES)) - 'INPUT NIL '((TYPE BINARY] - [COND - (\IRIS.VERBOSE - (* inform the user that a boot attempt is being made) - (PROMPTPRINT (CONCAT "Booting IRIS from: " IRISBOOTFILENAME] - (COPYBYTES IRISBOOTFILE OUTBOOTSTREAM NIL NIL) - (FORCEOUTPUT OUTBOOTSTREAM) - (CLOSEF IRISBOOTFILE) - (PROMPTPRINT "IRIS boot server complete, closing boot file") - (CLOSEF INBOOTSTREAM)) - ((EQ CHAR (CHARCODE A)) (* replace EPSOCKET of IRISPACKET - with 41) - (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE - E)) - (SENDIRISPACKET IRISPACKET) - (* just sends back an "E" packet with our host socket - (41) filled in) - (SETQ INBOOTSTREAM (SPP.OPEN NIL 41 NIL IRIS.BOOT.STREAM.NAME)) - (SETQ OUTBOOTSTREAM (SPPOUTPUTSTREAM INBOOTSTREAM)) - (SPP.DSTYPE INBOOTSTREAM 108) (* returns a connection which is not - yet established) - (BIN INBOOTSTREAM) - (while (SPP.READP INBOOTSTREAM) collect (BIN INBOOTSTREAM)) - (SETQ BOOTFILENAME (CONSTANT "iris")) (* This is a packet specifying the - boot file name,) - [SETQ IRISBOOTFILE (OPENSTREAM (SETQ IRISBOOTFILENAME (FINDFILE BOOTFILENAME NIL - IRISBOOTDIRECTORIES)) - 'INPUT NIL '((TYPE BINARY] - [COND - (\IRIS.VERBOSE - (* inform the user that a boot attempt is being made) - (PROMPTPRINT (CONCAT "Booting IRIS from: " IRISBOOTFILENAME] - (COPYBYTES IRISBOOTFILE OUTBOOTSTREAM NIL NIL) - (FORCEOUTPUT OUTBOOTSTREAM) - (CLOSEF IRISBOOTFILE) - (PROMPTPRINT "IRIS boot server complete, closing boot file") - (CLOSEF INBOOTSTREAM)) - ((EQ CHAR (CHARCODE H)) (* serv-hostname in SGIspeak) - (PRINT "workstation server connection") (* replace EPSOCKET of IRISPACKET - with 41) - (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE - H)) - (SETQ INBOOTSTREAM (SPP.OPEN NIL 37)) - (SENDIRISPACKET IRISPACKET)) - (T (PRINT "Iris connection") (* replace EPSOCKET of IRISPACKET - with 41) - (PRINTOUT PROMPTWINDOW CHAR "RECEIVED") - (replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with - (CHARCODE H)) - (SETQ INBOOTSTREAM (SPP.OPEN NIL 37)) - (SENDIRISPACKET IRISPACKET] - (RELEASE.MONITORLOCK IRIS.LOCK]) - -(SENDIRISPACKET - [LAMBDA (IRISPACKET) (* gbn "10-Jun-85 16:05") - (* * Sends a raw seething IRIS packet) - (COND - ((fetch (ETHERPACKET EPTRANSMITTING) of IRISPACKET) - 'AlreadyQueued) - (T (* (\RCLK (LOCF (fetch - (ETHERPACKET EPTIMESTAMP) of - IRISPACKET)))) - (TRANSMIT.ETHERPACKET (fetch (ETHERPACKET EPNETWORK) of IRISPACKET) - IRISPACKET]) - -(IRISFILTER - [LAMBDA (IRISPACKET) (* gbn " 3-Jun-85 22:49") - (if (AND (EQ (fetch (ETHERPACKET EPTYPE) of IRISPACKET) - IRIS.PACKETTYPE) - (BROADCASTP IRISPACKET)) - then (ADD.PROCESS `(IRISBOOTPROCESS %, IRISPACKET)) - T - else (* not an iris packet) - NIL]) - -(OPEN.IRISCONN - [LAMBDA (NSADDRESS) (* gbn " 7-Jul-85 14:42") - (SETQ IRISCONN (SPP.OPEN (OR NSADDRESS IRISNSADDRESS) - IRISSOCKET T '|Iris Terminal SPP|]) - -(IRISBOOTSERVER - [LAMBDA (ON?) (* gbn " 7-Jul-85 14:54") - (if ON? - then (PROMPTPRINT "Enabling IRIS boot server") - (\ADD.PACKET.FILTER (FUNCTION IRISFILTER)) - else (PROMPTPRINT "Disabling IRIS boot server") - (\DEL.PACKET.FILTER (FUNCTION IRISFILTER]) -) - -(RPAQQ \IRIS.VERBOSE T) - -(RPAQQ PRINTSPPDATAFLG T) - -(RPAQ IRIS.LOCK (CREATE.MONITORLOCK "iris boot lock")) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS IRISNSHOSTNUMBER) -) - -(RPAQ? IRISNET 146) - -(RPAQ? IRISBOOTDIRECTORIES '({CORE} {ERIS}gl2>boot>)) -(DECLARE%: EVAL@COMPILE - -(RPAQQ IRISSOCKET 37) - -(RPAQQ IRIS.PACKETTYPE 32790) - -(RPAQQ IRIS.BOOT.STREAM.NAME |IRIS boot SPP|) - -(CONSTANTS (IRISSOCKET 37) - (IRIS.PACKETTYPE 32790) - (IRIS.BOOT.STREAM.NAME '|IRIS boot SPP|)) -) -(DECLARE%: EVAL@LOAD DONTCOPY -(FILESLOAD ETHERRECORDS) - -(LOADCOMP 'LLETHER) -) -(ACCESSFNS IRISENCAPSULATION [(IRISBASE (LOCF (FETCH (ETHERPACKET EPENCAPSULATION) - OF DATUM] - [BLOCKRECORD IRISBASE ((IRISLENGTH WORD) - (IRISDESTHOSTO 3 WORD) - (IRISSOURCEHOSTO 3 WORD) - (IRISTYPE WORD) - (IRISEXCHID WORD) - (INFOCHAR1 BYTE) - (INFOCHAR2 BYTE)) - [ACCESSFNS IRISDESTHOSTO ((IRISDESTHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) - (\STORENSHOSTNUMBER (LOCF DATUM) - NEWVALUE)) - (IRISPACKETBASE (LOCF DATUM)) - (IRISDESTHOSTBASE (LOCF DATUM] - (ACCESSFNS IRISSOURCEHOSTO ((IRISSOURCEHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) - (\STORENSHOSTNUMBER (LOCF DATUM) - NEWVALUE)) - (IRISSOURCEHOSTBASE (LOCF DATUM] - (TYPE? (type? ETHERPACKET DATUM))) -(DECLARE%: EVAL@COMPILE -[PUTPROPS BROADCASTP MACRO ((PACKET) - ([LAMBDA (NDB) - (AND NDB (APPLY* (fetch NDBBROADCASTP of NDB) - PACKET NDB] - (fetch EPNETWORK of PACKET] -) -(PUTPROPS IRISNET COPYRIGHT ("Xerox Corporation" 1988)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (3679 13267 (IRIS.RESET 3689 . 4230) (IRIS.TRACE 4232 . 4424) (IRISBOOTPROCESS 4426 . -11586) (SENDIRISPACKET 11588 . 12227) (IRISFILTER 12229 . 12677) (OPEN.IRISCONN 12679 . 12908) ( -IRISBOOTSERVER 12910 . 13265))))) -STOP diff --git a/obsolete/lispusers/IRISSTREAM b/obsolete/lispusers/IRISSTREAM deleted file mode 100644 index d33b73f7..00000000 --- a/obsolete/lispusers/IRISSTREAM +++ /dev/null @@ -1,1314 +0,0 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED " 4-Feb-87 19:48:57" {ERIS}NEXT>IRISSTREAM.;10 68566 - - changes to%: (RECORDS IRISDATA) - (FNS OPENIRISSTREAM CLEARIRIS DRAWBITMAP TRYGRAPHER \FONTCREATE.IRIS - \OUTCHARFN.IRIS \IRISSTREAMINIT \IRIS.ASSURE.COLOR \LOOKUPRGB BOXSCREEN - IRIS.CONS.OBJNO IRISBITMAP FILLPOLYGON INSTALL.OBJFONT \CLOSEF.IRIS R - SPPINPUTSTREAM \BACKCOLOR.IRIS \BITBLT.IRIS \BLTSHADE.IRIS - \FONTSAVAILABLE.IRIS \LEFTMARGIN.IRIS \RESET.IRIS - \PSPLINE.TO.BEZIER.GEOMETRY \SCALE.IRIS \SCALE.SPLINE.BY.DERIVS - \STRINGWIDTH.IRIS \TERPRI.IRIS \FONT.IRIS \CREATECHARSET.IRIS - \IRISSETFONTBASE \IRISFONTBASE \CHANGECHARSET.IRIS \CHARWIDTH.IRIS - \CLIPPINGREGION.IRIS \CLOSEFN.IRIS \COLOR.IRIS \DRAWCIRCLE.IRIS - \DRAWCURVE.IRIS \DRAWLINE.IRIS \CONVERTLINESTYLE.IRIS \MOVETO.IRIS - \XPOSITION.IRIS \YPOSITION.IRIS \FILLCIRCLE.IRIS \DRAWELLIPSE.IRIS - \FILLPOLYGON.IRIS \IRIS.BITBLT \DRAWPOLYGON.IRIS ALIGN) - (VARS IRISSTREAMCOMS \BEZIERBASIS.IRIS) - - previous date%: "16-Jan-87 18:14:11" {ERIS}NEXT>IRISSTREAM.;5) - - -(PRETTYCOMPRINT IRISSTREAMCOMS) - -(RPAQQ IRISSTREAMCOMS - ((FILES SFFONT COLOR IRISLIB IRISIO IRISNET) - [ADDVARS (IMAGESTREAMTYPES (IRIS (OPENSTREAM OPENIRISSTREAM) - (FONTCREATE \FONTCREATE.IRIS) - (FONTSAVAILABLE \FONTSAVAILABLE.IRIS) - (CREATECHARSET \CREATECHARSET.IRIS] - (GLOBALVARS \IRIS.VERBOSE IRISNSHOSTNUMBER \IRIS.DEBUG \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE - \IRIS.VERSION \IRISSTREAM IRISCONN \IV.HIGHOBJNO \IRIS.BITPLANES) - (INITVARS (\IRIS.VERBOSE T) - (\IRISSTREAMS NIL) - (\IRIS.VERSION 'GL2) - (IRISFONTDIRECTORIES '{ERIS}SF>) - (\CHARSEGMENTS.IRIS 10) - (\IRIS.BITPLANES 4) - (IRISFONTFAMILIES '(GACHA TIMESROMAN)) - (IRISFONTROTATIONS '(0)) - (IRISFONTSIZES '(8 10 12 14 18 24)) - (\IRIS.DEBUG NIL) - (IRISNSHOSTNUMBER "0#4000.12000.41504#0") - (\IV.HIGHOBJNO 100000)) - (VARS \BEZIERBASIS.IRIS \IRIS.VERBOSE \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE \IRIS.VERSION) - (CONSTANTS IRIS.YAXIS IRIS.ZAXIS) - (FNS BOXSCREEN CLEARIRIS DRAWBITMAP IRIS.CONS.OBJNO IRISBITMAP INSTALL.OBJFONT OPENIRISSTREAM - \CLOSEF.IRIS R SPPINPUTSTREAM TRYGRAPHER \BACKCOLOR.IRIS \BITBLT.IRIS \BLTSHADE.IRIS - \FONTCREATE.IRIS \FONTSAVAILABLE.IRIS \LEFTMARGIN.IRIS \RESET.IRIS \LOOKUPRGB - \PSPLINE.TO.BEZIER.GEOMETRY \SCALE.IRIS \SCALE.SPLINE.BY.DERIVS \TERPRI.IRIS \FONT.IRIS - \CREATECHARSET.IRIS \IRISSETFONTBASE \IRISFONTBASE \CHANGECHARSET.IRIS \CHARWIDTH.IRIS - \OUTCHARFN.IRIS \CLIPPINGREGION.IRIS \CLOSEFN.IRIS \COLOR.IRIS \IRIS.ASSURE.COLOR - \DRAWCIRCLE.IRIS \DRAWCURVE.IRIS \DRAWLINE.IRIS \CONVERTLINESTYLE.IRIS \IRISSTREAMINIT - \MOVETO.IRIS \XPOSITION.IRIS \YPOSITION.IRIS \FILLCIRCLE.IRIS \DRAWELLIPSE.IRIS - \FILLPOLYGON.IRIS \IRIS.BITBLT \DRAWPOLYGON.IRIS ALIGN) - - -(* ;;; "test functions") - - (RECORDS BEZIER IRISDATA IRISSTREAM SPLINE) - (CONSTANTS (\ALTLINESTYLE.IRIS 1) - (\IRIS.ITALICS.ROTATION -100) - (\PRIMARYLINESTLE.IRIS 0) - (\IRIS.BOLD.LINEWIDTH 2)) - [P (\IRISSTREAMINIT) - (SETFONTCLASSCOMPONENT DEFAULTFONT 'IRIS '(GACHA 12] - [ADDVARS (DEFAULTPRINTINGHOST (IRIS Iris)) - (PRINTERTYPES (IRIS (CANPRINT (IRIS)) - (BITMAPFILE (IRISBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION - TITLE] - (P (PUTPROP 'Iris 'PRINTERTYPE 'IRIS)) - (PROP PRINTERTYPE Iris) - (FUNCTIONS WITH.IRIS.ATTR))) -(FILESLOAD SFFONT COLOR IRISLIB IRISIO IRISNET) - -(ADDTOVAR IMAGESTREAMTYPES (IRIS (OPENSTREAM OPENIRISSTREAM) - (FONTCREATE \FONTCREATE.IRIS) - (FONTSAVAILABLE \FONTSAVAILABLE.IRIS) - (CREATECHARSET \CREATECHARSET.IRIS))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \IRIS.VERBOSE IRISNSHOSTNUMBER \IRIS.DEBUG \BEZIERBASIS.IRIS \IRISCOLORMAPCACHE - \IRIS.VERSION \IRISSTREAM IRISCONN \IV.HIGHOBJNO \IRIS.BITPLANES) -) - -(RPAQ? \IRIS.VERBOSE T) - -(RPAQ? \IRISSTREAMS NIL) - -(RPAQ? \IRIS.VERSION 'GL2) - -(RPAQ? IRISFONTDIRECTORIES '{ERIS}SF>) - -(RPAQ? \CHARSEGMENTS.IRIS 10) - -(RPAQ? \IRIS.BITPLANES 4) - -(RPAQ? IRISFONTFAMILIES '(GACHA TIMESROMAN)) - -(RPAQ? IRISFONTROTATIONS '(0)) - -(RPAQ? IRISFONTSIZES '(8 10 12 14 18 24)) - -(RPAQ? \IRIS.DEBUG NIL) - -(RPAQ? IRISNSHOSTNUMBER "0#4000.12000.41504#0") - -(RPAQ? \IV.HIGHOBJNO 100000) - -(RPAQQ \BEZIERBASIS.IRIS ((-1.0 3.0 -3.0 1.0) - (3.0 -6.0 3.0 0.0) - (-3.0 3.0 0.0 0.0) - (1.0 0.0 0.0 0.0))) - -(RPAQQ \IRIS.VERBOSE T) - -(RPAQQ \BEZIERBASIS.IRIS ((-1.0 3.0 -3.0 1.0) - (3.0 -6.0 3.0 0.0) - (-3.0 3.0 0.0 0.0) - (1.0 0.0 0.0 0.0))) - -(RPAQQ \IRISCOLORMAPCACHE (((0 0 0) . 0) - ((255 255 255) . 7) - ((0 255 0) . 2) - ((0 0 255) . 4) - ((255 0 0) . 1) - ((255 255 0) . 3) - ((255 0 255) . 5) - ((0 255 255) . 6))) - -(RPAQQ \IRIS.VERSION GL2) -(DECLARE%: EVAL@COMPILE - -(RPAQQ IRIS.YAXIS 89) - -(RPAQQ IRIS.ZAXIS 90) - -(CONSTANTS IRIS.YAXIS IRIS.ZAXIS) -) -(DEFINEQ - -(BOXSCREEN - [LAMBDA NIL (* gbn " 8-Nov-85 16:56") - - (* * draw a box around the screen) - - (DRAWLINE 0 0 (SUB1 SCREENWIDTH) - 0 NIL NIL \IRISSTREAM) - (DRAWTO (SUB1 SCREENWIDTH) - (SUB1 SCREENHEIGHT) - NIL NIL \IRISSTREAM) - (DRAWTO 0 (SUB1 SCREENHEIGHT) - NIL NIL \IRISSTREAM) - (DRAWTO 0 0 NIL NIL \IRISSTREAM) - (FLUSHOUTPUT IRISCONN]) - -(CLEARIRIS - [LAMBDA (IRIS-CONNECTION IRISSTREAM) (* ; "Edited 2-Feb-87 23:36 by gbn") - (OR IRISSTREAM (SETQ IRISSTREAM \IRISSTREAM)) - [OR IRIS-CONNECTION (SETQ IRIS-CONNECTION (fetch SPPOUTSTREAM of (fetch IRISDATA of \IRISSTREAM] - (IRIS.SINGLEBUFFER IRIS-CONNECTION) - (IRIS.GCONFIG IRIS-CONNECTION) - (DSPCLIPPINGREGION WHOLESCREEN IRISSTREAM) - (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -1000 1000 IRIS-CONNECTION) - (DSPCOLOR 'WHITE IRISSTREAM) - (IRIS.LINEWIDTH 1 IRIS-CONNECTION) (* ; "IRIS.RESETLS 0 IRISCONN") - (* ; - "make the IRIS not reset the line style between curve segments") - (IRIS.CURSOFF IRIS-CONNECTION) - (IRIS.CLEAR IRIS-CONNECTION) - (DSPCOLOR 'BLUE IRISSTREAM) - (SELECTQ \IRIS.VERSION - (GL2 (IRIS.CURVEPRECISION \CHARSEGMENTS.IRIS IRIS-CONNECTION) - (IRIS.DEFBASIS 1 \BEZIERBASIS.IRIS IRIS-CONNECTION) - (IRIS.CURVEBASIS 1 IRIS-CONNECTION)) - (GL1) - (ERROR "Unknown version of IRIS: " \IRIS.VERSION)) - (DSPRESET IRISSTREAM) - (SPP.FORCEOUTPUT IRIS-CONNECTION]) - -(DRAWBITMAP - [LAMBDA (BITMAP SOURCELEFT SOURCEBOTTOM OUTPUTSTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT - ) (* ; "Edited 2-Feb-87 23:37 by gbn") - (LET ((DESTBOTTOM (OR DESTINATIONBOTTOM (DSPYPOSITION NIL OUTPUTSTREAM))) - (DESTLEFT (OR DESTINATIONLEFT (DSPXPOSITION NIL OUTPUTSTREAM))) - (WIDTH (OR WIDTH (BITMAPWIDTH BITMAP))) - (HEIGHT (OR HEIGHT (BITMAPHEIGHT BITMAP))) - (SBOTTOM (OR SOURCEBOTTOM 0)) - (SLEFT (OR SOURCELEFT 0)) - ROW) - [for Y from SOURCEBOTTOM to (IPLUS SOURCEBOTTOM HEIGHT) as YBASE from 0 - do (SETQ ROW (IPLUS DESTBOTTOM YBASE)) - - (* if there is a pixel set on the row, it is better to set the row outside the - loop) - - (bind (STATE _ 'SKIP0S) - START END for X from SLEFT to (IPLUS SLEFT WIDTH) as BASE from 0 - do (SELECTQ STATE - (SKIP0S (if (IEQP 0 (BITMAPBIT BITMAP X Y)) - then (* skipping zeros, found a zero, so do - nothing) - NIL - else (* start a run.) - (SETQ START BASE) - (SETQ END BASE) - (SETQ STATE 'COLLECT1S))) - (COLLECT1S (if (ILESSP END (add END (BITMAPBIT BITMAP X Y))) - then - - (* collecting 1's, found one. The test already incremented END, so do nothing) - - NIL - else (DRAWLINE (IPLUS DESTLEFT START) - ROW - (IPLUS DESTLEFT END) - ROW 1 NIL OUTPUTSTREAM) - (SETQ STATE 'SKIP0S))) - (SHOULDNT "Unknown state: " STATE)) - finally (if (EQ STATE 'COLLECT1S) - then (DRAWLINE (IPLUS DESTLEFT START) - ROW - (IPLUS DESTLEFT END) - ROW 1 NIL OUTPUTSTREAM] - (MOVETO DESTLEFT DESTBOTTOM OUTPUTSTREAM]) - -(IRIS.CONS.OBJNO - [LAMBDA NIL (* gbn "15-Nov-85 15:41") - (add \IV.HIGHOBJNO 1]) - -(IRISBITMAP - [LAMBDA (FILE BITMAP SCALEFACTOR REGION ROTATION TITLE) (* gbn "24-Oct-85 16:51") - (LET [(IRISSTREAM (OPENIMAGESTREAM '{LPT}Iris.IRIS 'IRIS] - (BITBLT BITMAP (fetch (REGION LEFT) of REGION) - (fetch (REGION BOTTOM) of REGION) - IRISSTREAM - (DSPXPOSITION NIL IRISSTREAM) - (DSPYPOSITION NIL IRISSTREAM) - (fetch (REGION WIDTH) of REGION) - (fetch (REGION HEIGHT) of REGION]) - -(INSTALL.OBJFONT - [LAMBDA (FAMILY CHARSET LOWCHARCODE HIGHESTCHARCODE SCALE IRISSTREAM CSINFO) - (* gbn "12-Nov-85 19:17") - - (* * takes a font in SF format that is already in core, ie, part of the value - of \SPLINEFONTSINCORE, and installs it on the iris connected to STREAM. - Characters in the font which are nil are not downloaded) - - (* * note that this fn is called by the fontcreate method for the iris, even - when the font has already been downloaded. - This fn looks up in the stream and just returns the old cached info from the - original downloading.) - - (if \IRIS.DEBUG - then (SETQ LOWCHARCODE 97) - (SETQ HIGHESTCHARCODE 101) - else (SETQ LOWCHARCODE (OR LOWCHARCODE 1)) - (SETQ HIGHESTCHARCODE (OR HIGHESTCHARCODE 255))) - (PROG ((FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET)) - (IRISDATA (fetch IRISDATA of IRISSTREAM)) - (MAXHEIGHT 0) - SPACEWIDTH OBJ# FONTBASE CHARDESC WIDTHARRAY STREAM) - (SETQ STREAM (fetch SPPOUTSTREAM of IRISDATA)) - (if (NOT FONTARRAY) - then (ERROR "Charset for spline font not in core:" (LIST FAMILY CHARSET))) - (if (SETQ FONTBASE (\IRISFONTBASE FAMILY CHARSET IRISDATA)) - then - - (* the font has already been downloaded, just return the cached info) - - (if \IRIS.DEBUG - then (SHOULDNT "font being redefined")) - (RETURN FONTBASE) - else (SETQ FONTBASE (add (fetch HIFONT# of IRISDATA) - 256)) - (SETQ WIDTHARRAY (\CREATECSINFOELEMENT))) - (if \IRIS.VERBOSE - then (PROMPTPRINT "Installing font on IRIS: " FAMILY)) - (if (ZEROP (IRIS.ISOBJ 0 STREAM)) - then (IRIS.MAKEOBJ 0 STREAM) - (IRIS.CURSOFF STREAM) - (IRIS.CLOSEOBJ STREAM)) - - (* character 0 of the font is always defined on the IRIS as the way of telling - if this charset has been downloaded.) - (* NOT ANY MORE) - [for I from LOWCHARCODE to HIGHESTCHARCODE - do (SETQ CHARDESC (ELT FONTARRAY I)) - (if CHARDESC - then (IRIS.MAKEOBJ (SETQ OBJ# (IPLUS FONTBASE I)) - STREAM) - (SFDRAW CHARDESC NIL 0 0 SCALE IRISSTREAM) - - (* The scale is always one when called for the iris, because the printchar - method makes the IRIS scale the character anyway) - - (IRIS.CLOSEOBJ STREAM) - (ALIGN) (* CONSISTENCY CHECK) - (if (ZEROP (IRIS.ISOBJ OBJ# STREAM)) - then (ERROR ' - "(OBJECT FONT CHARACTER IS UNDEFINED DIRECTLY AFTER DEFINING INSIDE INSTALL.OBJFONT)" - ) - else (PRINTOUT PROMPTWINDOW (CHARACTER I] - (IRIS.GFLUSH STREAM) - (ALIGN) - (\IRISSETFONTBASE FAMILY CHARSET IRISDATA FONTBASE) - (SETQ OBJ# (IPLUS FONTBASE (CHARCODE SPACE))) - (if (ZEROP (IRIS.ISOBJ OBJ# STREAM)) - then (* install a fake space char if there - isn't one) - (SETQ SPACEWIDTH (\FGETWIDTH WIDTHARRAY (OR HIGHESTCHARCODE 127))) - (IRIS.MAKEOBJ OBJ# STREAM) - (MOVETO SPACEWIDTH 0 IRISSTREAM) - (IRIS.CLOSEOBJ STREAM) - (\FSETWIDTH WIDTHARRAY (CHARCODE SPACE) - SPACEWIDTH)) - (RETURN (LIST FAMILY FONTBASE WIDTHARRAY MAXHEIGHT]) - -(OPENIRISSTREAM - [LAMBDA (NSHOSTNUMBER OPTIONS) (* ; "Edited 4-Feb-87 19:05 by gbn") - - (* * opens a stream to an iris workstation) - - (DECLARE (GLOBALVARS \IRISIMAGEOPS)) - (PROG ((IRISDATA (create IRISDATA)) - (HOST (OR NSHOSTNUMBER IRISNSHOSTNUMBER)) - (IRISSTREAM (OPENSTREAM '{NODIRCORE}IRIS.SCRATCH 'OUTPUT 'NEW 8 'BINARY)) - TEMPCONN) - (if (NOT HOST) - then (ERROR "IRISNSHOSTNUMBER must be supplied")) - (if [AND (NOT (EQMEMB 'RECONNECT OPTIONS)) - (SPP.OPENP IRISCONN) - (OR (NULL HOST) - (SELECTQ (TYPENAME HOST) - (NSADDRESS (EQUAL (fetch (NSADDRESS NSHOSTNUMBER) of HOST) - (fetch (NSADDRESS NSHOSTNUMBER) of (SPP.DESTADDRESS - IRISCONN)))) - (LISTP (EQUAL HOST (fetch (NSADDRESS NSHOSTNUMBER) of (SPP.DESTADDRESS - IRISCONN)))) - (LITATOM (EQ 'LPT (LISTGET (UNPACKFILENAME HOST) - 'HOST))) - (NILL] - then - - (* there is still a stream open to the iris. - Just use that, since one can have at most a single stream open to the iris) - - (RETURN \IRISSTREAM) - else (if [AND (TYPENAMEP HOST 'LITATOM) - (EQ 'LPT (LISTGET (UNPACKFILENAME HOST) - 'HOST] - then - - (* * This is just a request to hardcopy when there is no open stream) - - (SETQ HOST NIL)) - (if (NOT (SETQ TEMPCONN (OPEN.IRISCONN HOST))) - then (ERROR "Iris did not respond to connection attempt" HOST))) - (* replace (STREAM USERCLOSEABLE) of - IRISSTREAM with NIL) - (STREAMADDPROP IRISSTREAM 'BEFORECLOSE '\CLOSEF.IRIS) - (replace (STREAM OUTCHARFN) of IRISSTREAM with (FUNCTION \OUTCHARFN.IRIS)) - (replace (IRISSTREAM IMAGEOPS) of IRISSTREAM with \IRISIMAGEOPS) - (replace (IRISSTREAM IRISDATA) of IRISSTREAM with IRISDATA) - (replace (IRISDATA SPPINSTREAM) of IRISDATA with TEMPCONN) - (replace (IRISDATA SPPOUTSTREAM) of IRISDATA with (SPPOUTPUTSTREAM TEMPCONN)) - (replace (IRISDATA IRISCOLORMAPCACHE) of IRISDATA with \IRISCOLORMAPCACHE) - (* replace (IRISDATA IRISCOLORMAP) of - IRISDATA with (COLORMAPCREATE NIL - \IRIS.BITPLANES)) - (replace (IRISDATA IRISCHARSET) of IRISDATA with -1) - (replace (IRISDATA IRISPAGE) of IRISDATA with (COPY WHOLESCREEN)) - (SETQ IRISCONN (fetch SPPOUTSTREAM of IRISDATA)) - (IRIS.GINIT IRISCONN) - (CLEARIRIS IRISCONN IRISSTREAM) - (RETURN (SETQ \IRISSTREAM IRISSTREAM]) - -(\CLOSEF.IRIS - [LAMBDA (IRISSTREAM) (* gbn "25-Oct-85 17:18") - - (* * this fn is installed on the stream as a streamprop. - It flushs the output to the stream, but does not close it) - - (FORCEOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM))) - (RETFROM 'CLOSEF NIL]) - -(R - [LAMBDA NIL (* gbn "21-Jun-85 03:57") - (OPENIRISSTREAM NIL '(DONTCONNECT]) - -(SPPINPUTSTREAM - [LAMBDA (OUTPUTSTREAM) (* gbn "17-Jun-85 17:40") - (PROG ((CON (fetch (STREAM F1) of OUTPUTSTREAM))) - (if CON - then (RETURN (fetch (SPPCON SPPINPUTSTREAM) of CON]) - -(TRYGRAPHER - [LAMBDA (DONTSETUP?) (* ; "Edited 2-Feb-87 23:43 by gbn") - -(* ;;; "just a hack to try to draw a grapher graph") - -(* ;;; "comment") - - (PROG (G) - [SETQ G (LAYOUTSEXPR '(stu (wxy xxx) - (xyzzy)) NIL NIL (FONTCREATE 'GACHA 20 NIL NIL 'IRIS] - (IF (NOT DONTSETUP?) - THEN (IRIS.GRESET) - (IRIS.SINGLEBUFFER) (* ; "(IRIS.DOUBLEBUFFER)") - (IRIS.GCONFIG) - (IRIS.PERSPECTIVE 120 1 -1000 1000) - (IRIS.LOOKAT 0 0 30000 0 0 0 0) - (IRIS.LINEWIDTH 2) - (CLEAR 'BLUE) - (IRIS.COLOR 'WHITE)) - (DISPLAYGRAPH G \IRISSTREAM) - (RETURN]) - -(\BACKCOLOR.IRIS - [LAMBDA (STREAM COLOR) (* ; "Edited 16-Jan-87 13:58 by gbn") - (IF COLOR - THEN (REPLACE (IRISDATA BACKCOLOR) OF (FETCH IRISDATA OF STREAM) WITH COLOR) - ELSE (FETCH (IRISDATA BACKCOLOR) OF (FETCH IRISDATA OF STREAM]) - -(\BITBLT.IRIS - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH - HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM) (* gbn "12-Nov-85 14:35") - - (* * produces a |3-d| bitmap composed of lines) - - (if (NOT (EQ (IMAGESTREAMTYPE DESTINATION) - 'IRIS)) - then (ERROR "Destination not IRIS stream: " DESTINATION)) - (DRAWBITMAP SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM - WIDTH HEIGHT) - (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of \IRISSTREAM]) - -(\BLTSHADE.IRIS - [LAMBDA (TEXTURE IRISSTREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION - ) (* ; "Edited 16-Jan-87 15:00 by gbn") - (* ; - "should not affect anything, so do a with attr") - (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM)) - (SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA))) - (WITH.IRIS.ATTR (IRIS.POLF2 4 (LIST (CREATEPOSITION DESTINATIONLEFT DESTINATIONBOTTOM) - (CREATEPOSITION (IPLUS DESTINATIONLEFT WIDTH) - DESTINATIONBOTTOM) - (CREATEPOSITION (IPLUS DESTINATIONLEFT WIDTH) - (IPLUS DESTINATIONBOTTOM HEIGHT)) - (CREATEPOSITION DESTINATIONLEFT (IPLUS - DESTINATIONBOTTOM - HEIGHT))) - SPPOUT) - IRISSTREAM SPPOUT :COLOR TEXTURE) - (FORCEOUTPUT SPPOUT]) - -(\FONTCREATE.IRIS - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 2-Feb-87 23:44 by gbn") - -(* ;;; "This function reads in the spline definition for a font, but does not install it on the iris. The installation is done on a demand basis on the IRIS, charset by charset.") - - (PROG (WIDTHS (SCALE 1) - FONTDESC CSINFO) - - (* ;; "since a spline font can be any size, we must guarantee that relative sizes are guaranteed, i.e. a 10 point font is twice as big as a 5 point font") - - (SETQ SCALE 1) - -(* ;;; "the width arrays, the height, ascent, etc are all scaled") - - (SETQ FONTDESC (create FONTDESCRIPTOR - FONTDEVICE _ 'IRIS - FONTFAMILY _ FAMILY - FONTSIZE _ SIZE - FONTFACE _ FACE - ROTATION _ ROTATION)) (* ; "CHECK WHAT FONTSCALE MEANS") - (SETQ CSINFO (\GETCHARSETINFO 0 FONTDESC T)) - (if (NOT CSINFO) - then (RETURN NIL)) (* ; - "this will call the createcharset method for the IRIS") - [SETQ SCALE (replace OTHERDEVICEFONTPROPS of FONTDESC - with (QUOTIENT (FLOAT SIZE) - (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) - (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO] - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - [for I from 0 to \MAXTHINCHAR DO (\FSETWIDTH WIDTHS I (FIX (TIMES (\FGETWIDTH WIDTHS I) - SCALE] - (replace \SFHeight of FONTDESC with SIZE) - [replace \SFAscent of FONTDESC with (FIX (TIMES SCALE (fetch (CHARSETINFO CHARSETASCENT) - of CSINFO] - [replace \SFDescent of FONTDESC with (FIX (TIMES SCALE (fetch (CHARSETINFO CHARSETDESCENT) - of CSINFO] - (* ; - "OTHERDEVICEFONTPROPS is used to hide the scale of the font on the iris") - (RETURN FONTDESC]) - -(\FONTSAVAILABLE.IRIS - [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* gbn "13-Nov-85 12:06") - - (* * returns a list of the form (family size face rotation IRIS) for any font - matching the specs. * is used as wildcard.) - - (DECLARE (GLOBALVARS IRISFONTDIRECTORIES)) (* Normalize face) - (LET [(FAMILIES (if (MEMB FAMILY IRISFONTFAMILIES) - then FAMILY - else NIL)) - (SIZES (SELECTQ PSIZE - (* IRISFONTSIZES) - (PROG1 PSIZE))) - [FACES (SELECTQ FACE - (* '((MEDIUM REGULAR REGULAR) - (MEDIUM ITALIC REGULAR) - (BOLD REGULAR REGULAR) - (BOLD ITALIC REGULAR))) - (PROG1 (LIST (\FONTFACE FACE] - (ROTATIONS (SELECTQ ROTATION - (* IRISFONTROTATIONS) - (PROG1 ROTATION] - (for FFAMILY inside FAMILIES - join (for SSIZE inside SIZES - join (for FFACE in FACES join (for RROTATION inside ROTATIONS - collect (LIST FFAMILY SSIZE FFACE RROTATION - 'IRIS]) - -(\LEFTMARGIN.IRIS - [LAMBDA (MARGIN STREAM) (* gbn " 8-Nov-85 17:33") - (OR 0 (if MARGIN - then (replace LEFT of (fetch IRISPAGE OF (fetch IRISDATA of STREAM)) with MARGIN) - else (fetch LEFT of (fetch IRISPAGE OF (fetch IRISDATA of STREAM]) - -(\RESET.IRIS - [LAMBDA (IRISSTREAM) (* gbn "13-Nov-85 00:46") - (MOVETO (DSPLEFTMARGIN NIL IRISSTREAM) - (IDIFFERENCE (fetch TOP of (DSPCLIPPINGREGION NIL IRISSTREAM)) - (FONTPROP (DSPFONT NIL IRISSTREAM) - 'HEIGHT)) - IRISSTREAM]) - -(\LOOKUPRGB - [LAMBDA (RGB IRISDATA) (* ; "Edited 2-Feb-87 20:37 by gbn") - -(* ;;; -"returns the colormap index whose value is RGB. Returns the closest found and caches that value.") - -(* ;;; "Since the colormap code is so flakey, the iris now relies only on the cache in the stream. Not very efficient.") - - (LET* ((CACHE (FETCH IRISCOLORMAPCACHE OF IRISDATA)) - (INDEX (SASSOC RGB CACHE))) - (IF INDEX - THEN (CDR INDEX) - ELSE - - (* ;; "didn't find exactly the right index. Now look through the cache. For closeness in the color space, we use cartesian difference of the rgb's.") - - [SETQ INDEX (CDR (FOR PAIR IN CACHE - SMALLEST (CL:FLET [(ABSDIF (X Y) - (IABS (IDIFFERENCE X Y] - (APPLY #'+ (CL:MAPCAR #'ABSDIF RGB (CAR PAIR] - (REPLACE IRISCOLORMAPCACHE OF IRISDATA WITH (CL:ACONS RGB INDEX CACHE)) - INDEX]) - -(\PSPLINE.TO.BEZIER.GEOMETRY - [LAMBDA (SPLINE KNOT#) (* gbn " 7-Jul-85 20:49") - - (* * returns a bezier geometry matrix from the spline for knot KNOT#. - (compare with SF.DERIVS.TO.BEZIER which does the same thing for a SF spline - description)) - - (* * the derivatives must already be scaled by the Factorials) - - (* * should not create the BEZIER) - - (PROG [(BEZ (create BEZIER - B0X _ (ELT (fetch SPLINEX of SPLINE) - KNOT#) - B0Y _ (ELT (fetch SPLINEY of SPLINE) - KNOT#] - (replace B1X of BEZ with (PLUS (ffetch B0X of BEZ) - (QUOTIENT (ELT (ffetch SPLINEDX of SPLINE) - KNOT#) - 3))) - (replace B1Y of BEZ with (PLUS (ffetch B0Y of BEZ) - (QUOTIENT (ELT (ffetch SPLINEDY of SPLINE) - KNOT#) - 3))) - (replace B2X of BEZ with (PLUS (ffetch B1X of BEZ) - (QUOTIENT (PLUS (ELT (ffetch SPLINEDX of SPLINE) - KNOT#) - (ELT (ffetch SPLINEDDX of SPLINE) - KNOT#)) - 3))) - (replace B2Y of BEZ with (PLUS (ffetch B1Y of BEZ) - (QUOTIENT (PLUS (ELT (ffetch SPLINEDY of SPLINE) - KNOT#) - (ELT (ffetch SPLINEDDY of SPLINE) - KNOT#)) - 3))) - (replace B3X of BEZ with (PLUS (ffetch B0X of BEZ) - (ELT (ffetch SPLINEDX of SPLINE) - KNOT#) - (ELT (ffetch SPLINEDDX of SPLINE) - KNOT#) - (ELT (ffetch SPLINEDDDX of SPLINE) - KNOT#))) - (replace B3Y of BEZ with (PLUS (ffetch B0Y of BEZ) - (ELT (fetch SPLINEDY of SPLINE) - KNOT#) - (ELT (ffetch SPLINEDDY of SPLINE) - KNOT#) - (ELT (ffetch SPLINEDDDY of SPLINE) - KNOT#))) - (RETURN BEZ]) - -(\SCALE.IRIS - [LAMBDA (STREAM SCALE) (* gbn "24-Jun-85 18:50") - (if (NOT SCALE) - then 1 - else (ERROR]) - -(\SCALE.SPLINE.BY.DERIVS - [LAMBDA (SPLINE) (* gbn " 8-Jul-85 17:20") - - (* * For the form used by \PSPLINE.TO.BEZIER.GEOMETRY, the derivs can all be - premultiplied by the factorial coefficients, rather than repeatedly multiplying - them in) - - (bind (DDX _ (fetch SPLINEDDX of SPLINE)) - (DDY _ (fetch SPLINEDDY of SPLINE)) - (DDDX _ (fetch SPLINEDDDX of SPLINE)) - (DDDY _ (fetch SPLINEDDDY of SPLINE)) for I from 1 to (fetch %#KNOTS of SPLINE) - do (SETA DDX I (FQUOTIENT (ELT DDX I) - 2.0)) - (SETA DDY I (FQUOTIENT (ELT DDY I) - 2.0)) - (SETA DDDX I (FQUOTIENT (ELT DDDX I) - 6.0)) - (SETA DDDY I (FQUOTIENT (ELT DDDY I) - 6.0]) - -(\TERPRI.IRIS - [LAMBDA (STREAM) (* gbn "12-Nov-85 14:37") - (MOVETO (DSPLEFTMARGIN NIL STREAM) - (IDIFFERENCE (DSPYPOSITION NIL STREAM) - (FONTPROP (DSPFONT NIL STREAM) - 'HEIGHT)) - STREAM) - (if (ILESSP (DSPYPOSITION NIL STREAM) - 0) - then (DSPRESET STREAM)) - (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM]) - -(\FONT.IRIS - [LAMBDA (IRISSTREAM FONTDESC) (* gbn "29-Oct-85 15:25") - (if FONTDESC - then (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM))) - [if [NOT (AND (type? FONTDESCRIPTOR FONTDESC) - (EQ 'IRIS (fetch FONTDEVICE of FONTDESC] - then (SETQ FONTDESC (\COERCEFONTDESC FONTDESC 'IRIS] - (* user supplied a font so install it) - (replace (IRISDATA CURRENTFONTDESC) of IRISDATA with FONTDESC) - (\CHANGECHARSET.IRIS IRISSTREAM 0) (* this validates the caches for - fontbase, current charset, etc.) - FONTDESC) - else (fetch CURRENTFONTDESC of (fetch IRISDATA of IRISSTREAM]) - -(\CREATECHARSET.IRIS - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) - (* ; "Edited 16-Jan-87 16:43 by gbn") - -(* ;;; "This function reads in the spline definition for a CHARSET but does not install it on the iris. The installation is done on a demand basis on the IRIS, charset by charset.") - - (PROG ((FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET)) - (MAXHEIGHT 1) - WIDTHS CSINFO FONTARRAY SCALE FILES) - (if (NOT FONTARRAY) - then (* ; - "we haven't even read this into core.") - (SETQ FILES (DIRECTORY (PACK* IRISFONTDIRECTORIES FAMILY '*.*SF) - 'COLLECT)) - - (* ;; "THIS METHOD OF FINDING THE FILES WILL NEED TO BE UPGRADED IF WE GET SPLINE DEFINITIONS FOR NS CHARACTERS") - - (if (NOT FILES) - then - - (* ;; "if you can't find the file then just return NIL to createcharset who will either report the error or build a slug charset") - - (RETURN (if NOSLUG? - then (* ; - "if you can't find the file then just return NIL to createcharset who will report the error") - NIL - else (* ; - "this will guarantee that all the chars in the charset have 0 width") - (\BUILDSLUGCSINFO 0 0 0))) - else (if \IRIS.VERBOSE - then (PROMPTPRINT "Reading the following spline font files: " FILES)) - (if \IRIS.DEBUG - then (READ.SPLINE.FONT (CAR FILES) - FAMILY CHARSET) - else (READ.SPLINE.FONT FILES FAMILY CHARSET))) - (* ; "now see if it really worked") - (if (NOT (SETQ FONTARRAY (\LOOKUPSPLINEFONT FAMILY CHARSET))) - then (* ; - "we just lost horribly, so die with an inconsistency") - (SHOULDNT "Inside \FONTCREATE.IRIS, some SFFONTS were found, but reading them did not produce an entry in \SPLINEFONTSINCORE" - ))) (* ; - "we have the FAMILY/CHARSET entries, now see if there is a font descriptor ready made for this size") - - (* ;; "since a spline font can be any size, we must guarantee that relative sizes are guaranteed, i.e. a 10 point font is twice as big as a 5 point font") - - (SETQ CSINFO (create CHARSETINFO)) - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (bind CHARDESC for I from 1 to \MAXTHINCHAR - do (SETQ CHARDESC (ELT FONTARRAY I)) - - (* ;; "If there is no description for a character, set its width to zero, so that dspprintchar can recognize not to call this character.") - - (if CHARDESC - then (\FSETWIDTH WIDTHS I (fetch XWIDTH of (fetch SF.WIDTH of CHARDESC))) - [SETQ MAXHEIGHT (IMAX MAXHEIGHT (fetch YFIDUCIAL - of (fetch FIDUCIAL of CHARDESC] - else (\FSETWIDTH WIDTHS I 0))) - (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (FIX (TIMES 0.7 MAXHEIGHT))) - (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (FIX (TIMES 0.3 MAXHEIGHT))) - - (* ;; "It doesn't look like this scale junk is used anymore. gbn Jan 17/87") - - [if (SETQ SCALE (fetch OTHERDEVICEFONTPROPS of FONTDESC)) - then - - (* ;; "this fontdescriptor has already build character sets, and has determined its scale. So scale the widths in this character set. For the first character set, this is done in \fontcreate.iris") - - (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I - (FIX (TIMES (\FGETWIDTH WIDTHS I) - SCALE] - (RETURN CSINFO]) - -(\IRISSETFONTBASE - [LAMBDA (FAMILY CHARSET IRISDATA FONTBASE) (* gbn "18-Oct-85 16:15") - (PUTASSOC (CONS FAMILY CHARSET) - FONTBASE - (fetch FONTSINIRIS of IRISDATA]) - -(\IRISFONTBASE - [LAMBDA (FAMILY CHARSET IRISDATA) (* gbn "18-Oct-85 16:15") - (CDR (SASSOC (CONS FAMILY CHARSET) - (fetch FONTSINIRIS of IRISDATA]) - -(\CHANGECHARSET.IRIS - [LAMBDA (IRISSTREAM CHARSET) (* gbn "18-Oct-85 16:16") - - (* * called when a character is about to be printed which is in a different - charset than the current one.) - - (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM)) - CSINFO BASE FONTDESC) - (SETQ FONTDESC (fetch CURRENTFONTDESC of IRISDATA)) - [replace (IRISDATA IRISWIDTHSCACHE) of IRISDATA with (fetch (CHARSETINFO WIDTHS) - of (SETQ CSINFO (\GETCHARSETINFO - CHARSET FONTDESC] - (SETQ BASE (\IRISFONTBASE (fetch FONTFAMILY of FONTDESC) - CHARSET IRISDATA)) - (if (NOT BASE) - then - - (* this stream has never seen this charset before so install it on the IRIS.) - - (INSTALL.OBJFONT (fetch FONTFAMILY of FONTDESC) - CHARSET NIL NIL NIL IRISSTREAM CSINFO) - (SETQ BASE (\IRISFONTBASE (fetch FONTFAMILY of FONTDESC) - CHARSET IRISDATA))) - (replace (IRISDATA CURRENTFONTBASE) of IRISDATA with BASE) - (replace (IRISDATA IRISCHARSET) of IRISDATA with CHARSET]) - -(\CHARWIDTH.IRIS - [LAMBDA (CHARCODE FONT) (* gbn "18-Oct-85 19:11") - (FIX (TIMES (fetch OTHERDEVICEFONTPROPS of FONT) - (\FGETCHARWIDTH FONT CHARCODE]) - -(\OUTCHARFN.IRIS - [LAMBDA (IRISSTREAM CHARCODE) (* ; "Edited 2-Feb-87 23:46 by gbn") - (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM)) - (SPPOUT (fetch SPPOUTSTREAM of IRISDATA)) - OBJNO - (FONTDESC (fetch CURRENTFONTDESC of IRISDATA)) - PUSHEDATTRIBUTES SCALE) - (if (NOT FONTDESC) - then (* ; - "this is so that the stream can be opened without the expensive font create operation") - (SETQ FONTDESC (DSPFONT (FONTCREATE 'GACHA 12 NIL NIL 'IRIS) - IRISSTREAM))) - (if (NEQ (fetch (IRISDATA IRISCHARSET) of IRISDATA) - (\CHARSET CHARCODE)) - then (\CHANGECHARSET.IRIS IRISSTREAM (\CHARSET CHARCODE))) - (SETQ OBJNO (IPLUS (fetch CURRENTFONTBASE of IRISDATA) - CHARCODE)) - (COND - ((EQ CHARCODE (CHARCODE EOL)) - (\TERPRI.IRIS IRISSTREAM)) - ((NILL) (* ; - "ZEROP (IRIS.ISOBJ CURRENTFONTBASE SPPOUT)") - - (* ;; "this character set has not been installed on the IRIS. character zero is defined for every charset that is installed.") - - (SHOULDNT "\CHANGECHARSET.IRIS has not guaranteed that char 0 is defined. Obj = " - OBJNO)) - ((ZEROP (\FGETWIDTH (fetch (IRISDATA IRISWIDTHSCACHE) of IRISDATA) - (\CHAR8CODE CHARCODE))) (* ; - "the character is not defined. don't call it") - NIL) - (T (IRIS.PUSHMATRIX SPPOUT) - (IRIS.TRANSLATE (DSPXPOSITION NIL IRISSTREAM) - (DSPYPOSITION NIL IRISSTREAM) - 0 SPPOUT) - (IRIS.SCALE (SETQ SCALE (fetch OTHERDEVICEFONTPROPS of FONTDESC)) - SCALE SCALE SPPOUT) - (if (EQ (CAR (fetch FONTFACE of FONTDESC)) - 'BOLD) - then (SETQ PUSHEDATTRIBUTES T) - (IRIS.PUSHATTRIBUTES SPPOUT) - (IRIS.LINEWIDTH \IRIS.BOLD.LINEWIDTH SPPOUT)) - (if (EQ (CADR (fetch FONTFACE of FONTDESC)) - 'ITALIC) - then (* ; "fake italics with a rotation") - (IRIS.ROTATE \IRIS.ITALICS.ROTATION IRIS.ZAXIS SPPOUT)) - (if PUSHEDATTRIBUTES - then (IRIS.POPATTRIBUTES SPPOUT)) - (IRIS.CALLOBJ OBJNO SPPOUT) - (IRIS.POPMATRIX SPPOUT) - (RELMOVETO (FIX (\FGETWIDTH (fetch IRISWIDTHSCACHE of IRISDATA) - CHARCODE)) - 0 IRISSTREAM) - (FLUSHOUTPUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM]) - -(\CLIPPINGREGION.IRIS - [LAMBDA (STREAM REGION) (* gbn "30-Jun-85 21:21") - (if REGION - then (replace IRISCLIPPINGREGION of (fetch IRISDATA of STREAM) with REGION) - else (fetch IRISCLIPPINGREGION of (fetch IRISDATA of STREAM]) - -(\CLOSEFN.IRIS - [LAMBDA (STR) (* gbn "12-Nov-85 14:25") - - (* * (I DONT THINK THAT SGI IMPLEMENTS THE SPP CLOSE PROTOCOL, BUT WE SHOULD - TRY TO CONVINCE THEM)) - - (FORCEOUTPUT IRISCONN]) - -(\COLOR.IRIS - [LAMBDA (STREAM COLOR) (* gbn " 8-Nov-85 19:25") - (if COLOR - then (IRIS.COLOR (\IRIS.ASSURE.COLOR COLOR STREAM) - (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM))) - else (IRIS.GETCOLOR (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM]) - -(\IRIS.ASSURE.COLOR - [LAMBDA (COLOR# IRISSTREAM) (* ; "Edited 31-Jan-87 20:32 by gbn") - (PROG (LEVELS) - (AND (COND - ((NULL COLOR#) - NIL) - ((FIXP COLOR#) - - (* ;; "since Sketch and others call fillpolygon with textures, just return a consistent color from a texture") - - (RETURN (IMOD COLOR# 7))) - [(LITATOM COLOR#) - (RETURN (COND - ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR#)) - (* ; "recursively look up color number") - (\IRIS.ASSURE.COLOR (CDR LEVELS) - IRISSTREAM)) - (T (ERROR "Unknown color name" COLOR#] - ((HLSP COLOR#) (* ; "HLS form convert to RGB") - (SETQ LEVELS (HLSTORGB COLOR#))) - ((RGBP COLOR#) (* ; "check for RGB or HLS") - (SETQ LEVELS COLOR#)) - ((AND (LISTP COLOR#) - (RGBP (CADR COLOR#))) (* ; - "temporarily, handle the case of being given a texture and a color, by using the color") - (RETURN (\IRIS.ASSURE.COLOR (CADR COLOR#) - IRISSTREAM))) - ((TYPENAMEP COLOR# 'BITMAP) (* ; "just a hack to not blow up") - (RETURN (IMOD (for I from 1 to (BITMAPWIDTH COLOR#) - sum (BITMAPBIT COLOR# I 1)) - 8))) - (T (\ILLEGAL.ARG COLOR#))) - (RETURN (COND - ((\LOOKUPRGB LEVELS (fetch IRISDATA of IRISSTREAM))) - (T (ERROR COLOR# "not available in color map"]) - -(\DRAWCIRCLE.IRIS - [LAMBDA (IRISSTREAM X Y RADIUS BRUSH DASHING) (* ; "Edited 16-Jan-87 15:18 by gbn") - (LET [(SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of (fetch IRISDATA of IRISSTREAM] - (WITH.IRIS.ATTR (IRIS.CIRC X Y RADIUS SPPOUT) - SPPOUT IRISSTREAM :COLOR (CADDR BRUSH) - :WIDTH - (if (NOT (EQP (CADR BRUSH) - 1)) - then (CADR BRUSH) - else NIL) - :DASHING DASHING]) - -(\DRAWCURVE.IRIS - [LAMBDA (IRISSTREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 16-Jan-87 16:00 by gbn") - -(* ;;; "takes a list of knots. It must build a set of bezier control points for each knot pair.") - - (LET ((SPPOUT (fetch SPPOUTSTREAM of (fetch IRISDATA of IRISSTREAM))) - GEOMETRY SPLINE) - (WITH.IRIS.ATTR [PROGN [SETQ SPLINE (PARAMETRICSPLINE KNOTS CLOSED - (fetch SCRATCHSPLINE of (fetch IRISDATA - of IRISSTREAM] - (* ; - "convert the list of knots to a parametric spline description.") - (\SCALE.SPLINE.BY.DERIVS SPLINE) - (* ; - "For each knot in the spline, use the knots and the derivatives to compute bezier control points") - (for KNOT# from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) - do (SETQ GEOMETRY (\PSPLINE.TO.BEZIER.GEOMETRY SPLINE KNOT#)) - (SELECTQ \IRIS.VERSION - (GL1 (IRIS.CURVE 10 \BEZIERBASIS.IRIS GEOMETRY SPPOUT)) - (GL2 (IRIS.CRV GEOMETRY SPPOUT)) - (ERROR "UNKNOWN IRIS VERSION" \IRIS.VERSION] - SPPOUT IRISSTREAM :COLOR (CADDR BRUSH) - :WIDTH - (if (NOT (EQP (CADR BRUSH) - 1)) - then (CADR BRUSH) - else NIL) - :DASHING DASHING) - (fetch %#KNOTS of SPLINE]) - -(\DRAWLINE.IRIS - [LAMBDA (IRISSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) - (* ; "Edited 16-Jan-87 15:22 by gbn") - -(* ;;; "(check about color and operation) (sets irisx and irisy to x2 and y2 respectively)") - - (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM)) - PUSHEDATTRIBUTES SPPOUT) - (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA)) - (WITH.IRIS.ATTR (PROGN (IRIS.MOVE X1 Y1 (fetch IRISZ of IRISDATA) - SPPOUT) - (IRIS.DRAW (replace IRISX of IRISDATA with X2) - (replace IRISY of IRISDATA with Y2) - (fetch IRISZ of IRISDATA) - SPPOUT)) - IRISSTREAM SPPOUT :COLOR COLOR :WIDTH WIDTH :DASHING DASHING]) - -(\CONVERTLINESTYLE.IRIS - [LAMBDA (DASHING) (* gbn "12-Nov-85 13:54") - - (* * takes an Interlisp style dashing description - (a list of on then off pixels) and turns it into a 16 bit dashing description, - like the IRIS likes.) - - (bind (RESULT _ 0) for PIX in DASHING as (FLAG _ 1) by (IDIFFERENCE 1 FLAG) - do [SETQ RESULT (LOGOR (LLSH RESULT PIX) - (ITIMES FLAG (SUB1 (EXPT 2 PIX] - finally (RETURN (LOGAND (SUB1 (EXPT 2 16)) - RESULT]) - -(\IRISSTREAMINIT - [LAMBDA NIL (* ; "Edited 31-Jan-87 19:57 by gbn") - -(* ;;; "installs the definition of the Iris ImageOps") - - (DECLARE (GLOBALVARS \IRISIMAGEOPS \FACT.IRIS)) - (SETQ \IRISIMAGEOPS (create IMAGEOPS - IMAGETYPE _ 'IRIS - IMCLOSEFN _ (FUNCTION \CLOSEFN.IRIS) - IMMOVETO _ (FUNCTION \MOVETO.IRIS) - IMXPOSITION _ (FUNCTION \XPOSITION.IRIS) - IMYPOSITION _ (FUNCTION \YPOSITION.IRIS) - IMFONT _ (FUNCTION \FONT.IRIS) - IMFONTCREATE _ (FUNCTION IRIS) - IMDRAWLINE _ (FUNCTION \DRAWLINE.IRIS) - IMLEFTMARGIN _ (FUNCTION \LEFTMARGIN.IRIS) - IMRIGHTMARGIN _ (FUNCTION NILL) - IMLINEFEED _ (FUNCTION HELP) - IMDRAWCURVE _ (FUNCTION \DRAWCURVE.IRIS) - IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.IRIS) - IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.IRIS) - IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.IRIS) - IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.IRIS) - IMCHARWIDTH _ (FUNCTION \CHARWIDTH.IRIS) - IMBLTSHADE _ (FUNCTION \BLTSHADE.IRIS) - IMBITBLT _ (FUNCTION \BITBLT.IRIS) - IMNEWPAGE _ (FUNCTION NILL) - IMSCALE _ (FUNCTION \SCALE.IRIS) - IMTERPRI _ (FUNCTION \TERPRI.IRIS) - IMTOPMARGIN _ (FUNCTION NILL) - IMBOTTOMMARGIN _ (FUNCTION NILL) - IMBACKCOLOR _ (FUNCTION \BACKCOLOR.IRIS) - IMCOLOR _ (FUNCTION \COLOR.IRIS) - IMCLIPPINGREGION _ (FUNCTION \CLIPPINGREGION.IRIS) - IMRESET _ (FUNCTION \RESET.IRIS) - IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.IRIS) - IMFILLPOLYGON _ (FUNCTION \FILLPOLYGON.IRIS))) - (SETQ \FACT.IRIS (ARRAY 4 0 0.0 0)) - (SETA \FACT.IRIS 0 1.0) - (SETA \FACT.IRIS 1 1.0) - (SETA \FACT.IRIS 2 2.0) - (SETA \FACT.IRIS 3 6.0) - \IRISIMAGEOPS]) - -(\MOVETO.IRIS - [LAMBDA (IRISSTREAM XPOS YPOS) (* gbn "12-Nov-85 14:36") - (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM))) - (IRIS.MOVE (replace IRISX of IRISDATA with XPOS) - (replace IRISY of IRISDATA with YPOS) - (fetch IRISZ of IRISDATA) - (fetch SPPOUTSTREAM of IRISDATA]) - -(\XPOSITION.IRIS - [LAMBDA (IRISSTREAM XPOS) (* gbn "24-Jun-85 01:17") - - (* * adjust only the xpos) - - (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM))) - (RETURN (if XPOS - then (IRIS.MOVE (replace IRISX of IRISDATA with XPOS) - (fetch IRISY of IRISDATA) - (fetch IRISZ of IRISDATA) - (fetch SPPOUTSTREAM of IRISDATA)) - XPOS - else (OR (fetch IRISX of IRISDATA) - (replace IRISX of IRISDATA with (CAR (IRIS.GETGPOS NIL NIL NIL NIL - \IRISSTREAM]) - -(\YPOSITION.IRIS - [LAMBDA (IRISSTREAM YPOS) (* gbn "17-Jun-85 15:05") - - (* * adjust only the ypos) - - (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM))) - (RETURN (if YPOS - then (IRIS.MOVE (fetch IRISX of IRISDATA) - (replace IRISY of IRISDATA with YPOS) - (fetch IRISZ of IRISDATA) - (fetch SPPOUTSTREAM of IRISDATA)) - YPOS - else (fetch IRISY of IRISDATA]) - -(\FILLCIRCLE.IRIS - [LAMBDA (IRISSTREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "Edited 16-Jan-87 15:24 by gbn") - (* IRISSTREAM is guaranteed to be an - IRIS stream) - (COND - ((OR (NOT (NUMBERP RADIUS)) - (ILESSP (SETQ RADIUS (FIXR RADIUS)) - 0)) - (\ILLEGAL.ARG RADIUS)) - (T (LET* ((IRISDATA (fetch IRISDATA of IRISSTREAM)) - (SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA))) - (WITH.IRIS.ATTR (IRIS.CIRCF CENTERX CENTERY RADIUS SPPOUT) - IRISSTREAM SPPOUT :COLOR TEXTURE]) - -(\DRAWELLIPSE.IRIS - [LAMBDA (IRISSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) - (* gbn "11-Nov-85 19:07") - (PROG [(SINOR (COND - (ORIENTATION (SIN ORIENTATION)) - (T 0.0))) - (COSOR (COND - (ORIENTATION (COS ORIENTATION)) - (T 1.0] - (\DRAWCURVE.IRIS IRISSTREAM [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 BRUSH DASHING) - (MOVETO CENTERX CENTERY IRISSTREAM]) - -(\FILLPOLYGON.IRIS - [LAMBDA (IRISSTREAM POINTS TEXTURE CONVEX?) (* gbn "11-Nov-85 19:30") - (LET ((IRISDATA (fetch IRISDATA of IRISSTREAM)) - COLOR PUSHEDATTRIBUTES SPPOUT) - (SETQ COLOR (\IRIS.ASSURE.COLOR TEXTURE IRISSTREAM)) - (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA)) - (if COLOR - then - - (* save the current attributes since this fn is to have no side effects) - - (SETQ PUSHEDATTRIBUTES T) - (IRIS.PUSHATTRIBUTES SPPOUT) - (IRIS.COLOR COLOR SPPOUT)) - (if (NOT CONVEX?) - then - - (* break the polygon up into convex hunks, then fill each of those.) - - (for POLY in (TRAPLOOP POINTS) do (IRIS.POLF2 (LENGTH POLY) - (for P in POLY - collect (LIST (CAR P) - (CDR P))) - SPPOUT)) - else (IRIS.POLF2 (LENGTH POINTS) - (for P in POINTS collect (LIST (CAR P) - (CDR P))) - SPPOUT)) - (if PUSHEDATTRIBUTES - then (IRIS.POPATTRIBUTES SPPOUT]) - -(\IRIS.BITBLT - [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT - SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)(* gbn " 7-Aug-85 23:36") - (PROG ((COLOR (DSPCOLOR NIL DESTINATION)) - (SPPOUT (fetch SPPOUTSTREAM of (fetch IRISDATA of DESTINATION))) - NLONGS) - (for Y from DESTINATIONBOTTOM to (IPLUS DESTINATIONBOTTOM HEIGHT) - do (IRIS.CMOV2I DESTINATIONLEFT (PLUS DESTINATIONBOTTOM Y) - SPPOUT) (* IRIS.WRITEPIXELS WIDTH - (for X from SOURCELEFT to - (IPLUS SOURCELEFT (SUB1 WIDTH)) - collect (ITIMES (BITMAPBIT SOURCE X Y) - COLOR)) DESTINATION) - - (* the current character position determines where a write pixels op happens) - - (PROGN - - (* * now do an inline IRIS.WRITEPIXELS) - - (IRIS.GCMD 182 SPPOUT) - (IRIS.SENDS WIDTH SPPOUT) - (SETQ NLONGS (FOLDHI WIDTH 2)) - (IRIS.SENDL (LLSH NLONGS 1) - SPPOUT) (* Send the number of bytes to be sent) - (bind ALONG for X from SOURCELEFT to (IPLUS SOURCELEFT (SUB1 WIDTH)) - by 2 do (SETQ ALONG (LOGOR (LLSH (ITIMES (BITMAPBIT SOURCE X Y) - COLOR) - 16) - (ITIMES (BITMAPBIT SOURCE (ADD1 X) - Y) - COLOR))) - (COND - ((IRIS.DOSYNC (IQUOTIENT X 2)) - (IRIS.PUTGCHAR IRIS\AESC SPPOUT))) - (IRIS.SENDL ALONG SPPOUT]) - -(\DRAWPOLYGON.IRIS - [LAMBDA (IRISSTREAM POINTS TEXTURE) (* ; "Edited 16-Jan-87 15:33 by gbn") - (PROG ((IRISDATA (fetch IRISDATA of IRISSTREAM)) - COLOR SPPOUT) - (SETQ SPPOUT (fetch (IRISDATA SPPOUTSTREAM) of IRISDATA)) - (WITH.IRIS.ATTR (IRIS.POLY2 (LENGTH POINTS) - POINTS SPPOUT) - IRISSTREAM SPPOUT :COLOR TEXTURE]) - -(ALIGN - [LAMBDA (STREAM) (* gbn "17-Jun-85 15:06") - - (* * this is a dummy to insure that the IRIS has caught up on the output side. - When it returns a value, it has caught up) - - (IRIS.GETCOLOR (OR STREAM (fetch SPPINSTREAM of (fetch IRISDATA of \IRISSTREAM]) -) - - - -(* ;;; "test functions") - -(DECLARE%: EVAL@COMPILE - -(RECORD BEZIER ((B0X B0Y B0Z) - (B1X B1Y B1Z) - (B2X B2Y B2Z) - (B3X B3Y B3Z)) - B0Z _ 0 B1Z _ 0 B2Z _ 0 B3Z _ 0) - -(DATATYPE IRISDATA - (IRISX IRISY IRISZ SPPOUTSTREAM SPPINSTREAM SCRATCHSPLINE FONTSINIRIS CURRENTFONTDESC - HIFONT# CURRENTFONTBASE BACKCOLOR IRISCLIPPINGREGION OBSOLETE-FIELD - IRISCOLORMAPCACHE IRISCHARSET IRISWIDTHSCACHE IRISPAGE) - FONTSINIRIS _ (LIST NIL) - IRISX _ 0 IRISY _ 0 IRISZ _ 0 SCRATCHSPLINE _ (create SPLINE) - HIFONT# _ -255) - -(RECORD IRISSTREAM STREAM (SUBRECORD STREAM) - [ACCESSFNS ((IRISDATA (FETCH (STREAM IMAGEDATA) OF DATUM) - (REPLACE (STREAM IMAGEDATA) OF DATUM WITH NEWVALUE] - (TYPE? (TYPE? IRISDATA OF (FETCH (STREAM IMAGEDATA) OF DATUM)))) - -(RECORD SPLINE (%#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX SPLINEDDDY)) -) -(/DECLAREDATATYPE 'IRISDATA - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER POINTER POINTER POINTER) - '((IRISDATA 0 POINTER) - (IRISDATA 2 POINTER) - (IRISDATA 4 POINTER) - (IRISDATA 6 POINTER) - (IRISDATA 8 POINTER) - (IRISDATA 10 POINTER) - (IRISDATA 12 POINTER) - (IRISDATA 14 POINTER) - (IRISDATA 16 POINTER) - (IRISDATA 18 POINTER) - (IRISDATA 20 POINTER) - (IRISDATA 22 POINTER) - (IRISDATA 24 POINTER) - (IRISDATA 26 POINTER) - (IRISDATA 28 POINTER) - (IRISDATA 30 POINTER) - (IRISDATA 32 POINTER)) - '34) -(DECLARE%: EVAL@COMPILE - -(RPAQQ \ALTLINESTYLE.IRIS 1) - -(RPAQQ \IRIS.ITALICS.ROTATION -100) - -(RPAQQ \PRIMARYLINESTLE.IRIS 0) - -(RPAQQ \IRIS.BOLD.LINEWIDTH 2) - -(CONSTANTS (\ALTLINESTYLE.IRIS 1) - (\IRIS.ITALICS.ROTATION -100) - (\PRIMARYLINESTLE.IRIS 0) - (\IRIS.BOLD.LINEWIDTH 2)) -) -(\IRISSTREAMINIT) -(SETFONTCLASSCOMPONENT DEFAULTFONT 'IRIS '(GACHA 12)) - -(ADDTOVAR DEFAULTPRINTINGHOST (IRIS Iris)) - -(ADDTOVAR PRINTERTYPES (IRIS (CANPRINT (IRIS)) - (BITMAPFILE (IRISBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) -(PUTPROP 'Iris 'PRINTERTYPE 'IRIS) - -(PUTPROPS Iris PRINTERTYPE IRIS) - -(DEFMACRO WITH.IRIS.ATTR (FORM SPPOUT IRISSTREAM &KEY (COLOR NIL COLORSET) - (WIDTH NIL WIDTHSET) - (DASHING NIL DASHINGSET)) - `(LET [PUSHED ., [if COLORSET - then `((ECOLOR %, COLOR] - ., - [if WIDTHSET - then `((EWIDTH %, WIDTH] - ., - (if DASHINGSET - then `((EDASHING %, DASHING] - ., - [if COLORSET - then `((SETQ ECOLOR (AND ECOLOR (\IRIS.ASSURE.COLOR ECOLOR IRISSTREAM] - ., - [if DASHINGSET - then `((SETQ EDASHING (AND EDASHING (\CONVERTLINESTYLE.IRIS EDASHING] - [IF [OR ., (if COLORSET - then '(ECOLOR)) - ., - (if WIDTHSET - then '(EWIDTH)) - ., - (if DASHINGSET - then '(EDASHING] - THEN (SETQ PUSHED T) - (IRIS.PUSHATTRIBUTES %, SPPOUT) - ., - [IF COLORSET - THEN `((IF ECOLOR - THEN (IRIS.COLOR ECOLOR %, SPPOUT] - ., - [IF WIDTHSET - THEN `((IF EWIDTH - THEN (SELECTQ \IRIS.VERSION - (GL2 (IRIS.LINEWIDTH EWIDTH %, SPPOUT)) - (GL1 (if (IGREATERP EWIDTH 2) - then NIL - else (IRIS.LINEWIDTH 2 %, SPPOUT))) - (ERROR "UNKNOWN VERSION" \IRIS.VERSION] - ., - (IF DASHINGSET - THEN `((IF EDASHING - THEN (IRIS.DEFLINESTYLE \ALTLINESTYLE.IRIS EDASHING %, SPPOUT) - (IRIS.SETLINESTYLE \ALTLINESTYLE.IRIS SPPOUT) - (IRIS.RESETLS 0 SPPOUT] - %, FORM (IF PUSHED - THEN (IRIS.POPATTRIBUTES %, SPPOUT)))) - -(DECLARE%: DONTCOPY - (FILEMAP (NIL (6112 63745 (BOXSCREEN 6122 . 6588) (CLEARIRIS 6590 . 7831) (DRAWBITMAP 7833 . 10506) ( -IRIS.CONS.OBJNO 10508 . 10654) (IRISBITMAP 10656 . 11185) (INSTALL.OBJFONT 11187 . 15363) ( -OPENIRISSTREAM 15365 . 18920) (\CLOSEF.IRIS 18922 . 19306) (R 19308 . 19453) (SPPINPUTSTREAM 19455 . -19732) (TRYGRAPHER 19734 . 20565) (\BACKCOLOR.IRIS 20567 . 20911) (\BITBLT.IRIS 20913 . 21651) ( -\BLTSHADE.IRIS 21653 . 23041) (\FONTCREATE.IRIS 23043 . 25581) (\FONTSAVAILABLE.IRIS 25583 . 26989) ( -\LEFTMARGIN.IRIS 26991 . 27367) (\RESET.IRIS 27369 . 27717) (\LOOKUPRGB 27719 . 28896) ( -\PSPLINE.TO.BEZIER.GEOMETRY 28898 . 32164) (\SCALE.IRIS 32166 . 32344) (\SCALE.SPLINE.BY.DERIVS 32346 - . 33307) (\TERPRI.IRIS 33309 . 33797) (\FONT.IRIS 33799 . 34751) (\CREATECHARSET.IRIS 34753 . 39537) -(\IRISSETFONTBASE 39539 . 39763) (\IRISFONTBASE 39765 . 39974) (\CHANGECHARSET.IRIS 39976 . 41436) ( -\CHARWIDTH.IRIS 41438 . 41662) (\OUTCHARFN.IRIS 41664 . 44891) (\CLIPPINGREGION.IRIS 44893 . 45228) ( -\CLOSEFN.IRIS 45230 . 45512) (\COLOR.IRIS 45514 . 45895) (\IRIS.ASSURE.COLOR 45897 . 47915) ( -\DRAWCIRCLE.IRIS 47917 . 48467) (\DRAWCURVE.IRIS 48469 . 50364) (\DRAWLINE.IRIS 50366 . 51344) ( -\CONVERTLINESTYLE.IRIS 51346 . 51981) (\IRISSTREAMINIT 51983 . 54492) (\MOVETO.IRIS 54494 . 54911) ( -\XPOSITION.IRIS 54913 . 55773) (\YPOSITION.IRIS 55775 . 56436) (\FILLCIRCLE.IRIS 56438 . 57173) ( -\DRAWELLIPSE.IRIS 57175 . 59099) (\FILLPOLYGON.IRIS 59101 . 60607) (\IRIS.BITBLT 60609 . 62926) ( -\DRAWPOLYGON.IRIS 62928 . 63373) (ALIGN 63375 . 63743))))) -STOP diff --git a/obsolete/lispusers/IRISVIEW b/obsolete/lispusers/IRISVIEW deleted file mode 100644 index 1e076c69..00000000 --- a/obsolete/lispusers/IRISVIEW +++ /dev/null @@ -1,1274 +0,0 @@ -(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) -(FILECREATED " 4-Feb-87 19:32:44" {ERIS}NEXT>IRISVIEW.;18 65298 - - changes to%: (VARS IRISVIEWCOMS) - (FNS IV.SET.CURRENT.SCENE IV.SCENE.SETUP IV.INIT IV.VIEW.CHANGED IRIS.DEGREES - IV.ENSURE.SCENE IV.REDEFINE.SCENE IV.DOUBLEBUFFER IV.AXES IV.NEWSTREAM - IV.BACKGROUND IV.DSPCOLOR IV.RIGHT IV.UP IV.TOWARD IV.PHOME.AUX IV.PHOME - IV.2D.HOME) - (VARIABLES *IV-COMMANDS-MENUDESC* *IV-FILLINS-MENUDESC* - *IV-POSITIONING-MENU-DESC* *IV-MENUDESC*) - - previous date%: "27-Jan-87 01:16:23" {ERIS}NEXT>IRISVIEW.;10) - - -(* " -Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT IRISVIEWCOMS) - -(RPAQQ IRISVIEWCOMS - [(FILES IRISCONSTANTS COLOROBJ) - (GLOBALVARS IV.CURRENT.SCENE IV.SCENES IV.SCENES.MENU IV.VIEW.MENU IV.PROMPTWINDOW AXES.SCENE - SKULL.SCENE \IV.DRAW.AXES iV.BACKGROUND IV.MODE IV.THETA IV.DXLATE) - (INITVARS (IV.SCENES NIL) - (IV.CURRENT.SCENE) - (IV.SCENES.MENU) - (IV.VIEW.MENU)) - (BITMAPS IV.LEFT IV.POS IV.RIGHT IV.RIGHT.HIGHLIGHT IV.DOWN IV.UP IV.UP.HIGHLIGHT - BACKGROUNDBITMAP IV.ROTX IV.ROTX.HIGHLIGHT IV.ROTY IV.ROTY.HIGHLIGHT IV.ROTZ - IV.ROTZ.HIGHLIGHT IV.ROTATE IV.DELTA.LABEL IV.THETA.LABEL IV.TOWARD - IV.TOWARD.HIGHLIGHT IV.AWAY) - (* ; "fns for co-ordinating scenes") - (FNS IV.PROOF.SCENE IV.ENSURE.SCENE IV.NEW.SCENE.FROM.USER IV.REDEFINE.SCENE IV.CHOOSE.SCENE - IV.BUILD.SCENES.MENU IV.FORGET.SCENE IV.DRAW.SCENE IV.SET.CURRENT.SCENE IV.SCENE.SETUP) - (FNS DRAW.AXES F IV.CLEARIRIS IV.DOWN IV.GETINPUT IV.READ IV.HOME IV.2D.HOME IV.PHOME - IV.PHOME.AUX IV.VIEW IV.LEFT IV.RIGHT IV.ROTX IV.DOUBLEBUFFER IV.ROTY IV.ROTZ - IV.SWAPBUFFERS IV.UP IV.THETA IV.AXES IV.BACKGROUND IV.TOWARD IV.AWAY IV.DSPCOLOR - IV.DELTA IV.VIEW.CHANGED IV.NEWSTREAM IV.PROMPTPRINT IV.PROOF.SKETCH IV.INIT \CLEAR.IRIS - IRIS.DEGREES) - (FNS IV.ITEMMAPFN IV.DISPLAY.FMITEM) - (RECORDS IRISSCENE IVPOS) - (VARS HANDWIDTH IRIS.XAXIS IRIS.ZAXIS IV.DXLATE IV.MODE IV.OBJPT IV.THETA IV.TRACE.FNS - IV.TWIST IV.VIEWPT LASTIV.OBJPT LASTIV.VIEWPT (\IV.DRAW.AXES) - (\IV.BACKGROUND)) - (P (IV.SCENE.SETUP) - (IV.BUILD.SCENES.MENU)) - (FNS SKULLO) - - (* ;; "The order of these variables is important.") - - (VARIABLES *IV-SCENES-MENUDESC* *IV-FILLINS-MENUDESC* *IV-COMMANDS-MENUDESC* - *IV-POSITIONING-MENU-DESC* *IV-MENUDESC*) - (PROP FILETYPE IRISVIEW) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA IV.PROMPTPRINT]) -(FILESLOAD IRISCONSTANTS COLOROBJ) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS IV.CURRENT.SCENE IV.SCENES IV.SCENES.MENU IV.VIEW.MENU IV.PROMPTWINDOW AXES.SCENE - SKULL.SCENE \IV.DRAW.AXES iV.BACKGROUND IV.MODE IV.THETA IV.DXLATE) -) - -(RPAQ? IV.SCENES NIL) - -(RPAQ? IV.CURRENT.SCENE ) - -(RPAQ? IV.SCENES.MENU ) - -(RPAQ? IV.VIEW.MENU ) - -(RPAQQ IV.LEFT #*(48 24)@@@L@@@@@@@@@@ACH@@@@@@@@@A@F@@@@@@@@@@HAH@@@@@@@@@F@F@@@@@@@@@ALAH@@@@@@@@@B@L@@@@@GOOOO@GH@@@@H@@@@@@F@@@@H@@@@@@ACO@@H@@@@@@@N@@@GOOO@@@@B@@@@@D@@@@@B@@@@@H@@@@@B@@@@@H@@@@@B@@@@@GOH@@@B@@@@@B@@@@@B@@@@@D@@@@@B@@@@@D@@@@@B@@@@@CON@@@B@@@@@A@@@@@B@@@@@B@@@@AN@@@@@B@@@@NAH@@@@AOOOO@@G@@ -) - -(RPAQQ IV.POS (275 . 200)) - -(RPAQQ IV.RIGHT #*(48 24)@@@@@@@@C@@@@@@@@@@ALH@@@@@@@@@F@H@@@@@@@@AHA@@@@@@@@@F@F@@@@@@@@AHCH@@@@@@@@C@D@@@@@@@@AN@OOOON@@@@F@@@@@@A@@OLH@@@@@@A@@@G@@@@@@@A@@@D@@@@OOON@@@D@@@@@B@@@@@D@@@@@A@@@@@D@@@@@A@@@@@D@@@AON@@@@@D@@@@@D@@@@@D@@@@@B@@@@@D@@@@@B@@@@@D@@@GOL@@@@@D@@@@@H@@@@@GH@@@@D@@@@AHG@@@@D@@@@N@@OOOOH@@ -) - -(RPAQQ IV.RIGHT.HIGHLIGHT #*(48 24)@@@@@@@@C@@@@@@@@@@AOH@@@@@@@@@GOH@@@@@@@@AOO@@@@@@@@@GON@@@@@@@@AOOH@@@@@@@@GOL@@@@@@@@AOOOOOON@@@@GOOOOOOO@@OLOOOOOOOO@@@GOOOOOOOO@@@GOOOOOOON@@@GOOOOON@@@@@GOOOOOO@@@@@GOOOOOO@@@@@GOOOOON@@@@@GOOOOOL@@@@@GOOOOON@@@@@GOOOOON@@@@@GOOOOOL@@@@@GOOOOOH@@@@@GOOOOOL@@@@AHGOOOOL@@@@N@@OOOOH@@ -) - -(RPAQQ IV.DOWN #*(24 48)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@D@@A@@@@D@@A@@@@D@@A@@@@D@@B@@@@D@@B@@@@GOOL@@@@B@@D@@@@B@@D@@@@D@@D@@@@H@@B@@@@H@@B@@@A@@@B@@@A@@@A@@@A@@@A@@@C@@@A@@@F@@@A@@@D@@@A@@@H@@@A@@@H@@@A@@A@@@@A@@AA@@@A@@BC@@AA@@BE@@AA@@DE@AAA@@DEAAAA@@DIAAAA@@HIAAAA@@IAAAAA@@FAAAAI@@@AAAIF@@@AAIF@@@@AAF@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@@N@@@@@ -) - -(RPAQQ IV.UP #*(24 48)@@N@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AA@@@@@@AAF@@@@@AAIF@@@@AAAIF@@FAAAAI@@IAAAAA@@HIAAAA@@DIAAAA@@DEAAAA@@DE@AAA@@BE@@AA@@BC@@AA@@AA@@@A@@A@@@@A@@@H@@@A@@@H@@@A@@@D@@@A@@@F@@@A@@@C@@@A@@@A@@@A@@@A@@@A@@@A@@@B@@@@H@@B@@@@H@@B@@@@D@@D@@@@B@@D@@@@B@@D@@@@GOOL@@@@D@@B@@@@D@@B@@@@D@@A@@@@D@@A@@@@D@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.UP.HIGHLIGHT #*(24 48)@@N@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AO@@@@@@AOF@@@@@AOOF@@@@AOOOF@@FAOOOO@@OAOOOO@@OIOOOO@@GIOOOO@@GMOOOO@@GMOOOO@@CMOOOO@@COOOOO@@AOOOOO@@AOOOOO@@@OOOOO@@@OOOOO@@@GOOOO@@@GOOOO@@@COOOO@@@AOOOO@@@AOOOO@@@AOOON@@@@OOON@@@@OOON@@@@GOOL@@@@COOL@@@@COOL@@@@GOOL@@@@D@@B@@@@D@@B@@@@D@@A@@@@D@@A@@@@D@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ BACKGROUNDBITMAP #*(12 15)@@@@CKN@EOB@IFH@JFH@BF@@BD@@@D@@@D@@@B@@@CF@@CN@@ON@AON@@@@@) - -(RPAQQ IV.ROTX #*(28 47)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@@AHL@@@@@B@B@@@@@D@A@@@@@D@A@@@@@H@@H@@@@H@@H@@@A@@@D@@@A@@@D@@@A@@@D@@@A@@@D@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@@B@@BB@@@B@@CBF@@B@@AJL@@B@@@OH@@A@@@F@@@A@@@D@@@A@@@D@@@A@@@D@@@@H@@H@@@@H@@H@@@@D@A@@@@@D@A@@@@@B@B@@@@@AHL@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.ROTX.HIGHLIGHT #*(28 47)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@G@@@@@@AOL@@@@@CON@@@@@GOO@@@@@GOO@@@@@OOOH@@@@OOOH@@@AOOOL@@@AOOOL@@@AOOOL@@@AOOOL@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOON@@@COOONF@@COOONL@@COOOOH@@AOOON@@@AOOOL@@@AOOOL@@@AOOOL@@@@OOOH@@@@OOOH@@@@GOO@@@@@GOO@@@@@CON@@@@@AOL@@@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.ROTY #*(42 30)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OON@@@@@@@@O@@AN@@@@@@C@@@@AH@@@@@L@@@@@F@@@@A@@@@@@A@@@@B@@@@@@@H@@@B@@@@@@@H@@@D@@@@@@@D@@@D@@@@@@@D@@@D@@@@@@@D@@@B@@@@@@@H@@@B@@@@H@@H@@@A@@@AH@A@@@@@L@@C@@F@@@@@C@@F@AH@@@@@@O@LAN@@@@@@@@OON@@@@@@@@@@L@@@@@@@@@@@F@@@@@@@@@@@C@@@@@@@@@@@AH@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.ROTY.HIGHLIGHT #*(42 30)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OON@@@@@@@@OOOON@@@@@@COOOOOH@@@@@OOOOOON@@@@AOOOOOOO@@@@COOOOOOOH@@@COOOOOOOH@@@GOOOOOOOL@@@GOOOOOOOL@@@GOOOOOOOL@@@COOOOOOOH@@@COOOOOOOH@@@AOOOOOOO@@@@@OOOOOON@@@@@COOOOOH@@@@@@OOOON@@@@@@@@OON@@@@@@@@@@L@@@@@@@@@@@F@@@@@@@@@@@C@@@@@@@@@@@AH@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.ROTZ #*(45 38)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@AL@O@@@@@@@@F@@@N@@@@@@@H@@@AH@@@@@A@@@@@F@@@@@A@@@@@AOO@@@A@@@@@AL@@@@B@@@@@AB@@@@B@@@@@AA@@@@B@@@@@A@H@@@B@@@@@A@D@@@A@@@@@A@D@@@A@@@@@A@B@@@A@@@@@A@A@@@@H@@@@@@A@@@@D@@@@@@A@@@@D@@@@@@@H@@@B@@@@@@@H@@@A@@@@@@@H@@@@H@@@@@@H@@@@F@@@@@A@@@@@A@@@@@A@@@@@@L@@@@A@@@@@@C@@@@B@@@@@@@N@@@L@@@@@@@AN@G@@@@@@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.ROTZ.HIGHLIGHT #*(45 38)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CO@@@@@@@@@AOOO@@@@@@@@GOOON@@@@@@@OOOOOH@@@@@AOOOOON@@@@@AOOOOOOOO@@@AOOOOOOL@@@@COOOOOON@@@@COOOOOOO@@@@COOOOOOOH@@@COOOOOOOL@@@AOOOOOOOL@@@AOOOOOOON@@@AOOOOOOOO@@@@OOOOOOOO@@@@GOOOOOOO@@@@GOOOOOOOH@@@COOOOOOOH@@@AOOOOOOOH@@@@OOOOOOOH@@@@GOOOOOO@@@@@AOOOOOO@@@@@@OOOOOO@@@@@@COOOON@@@@@@@OOOOL@@@@@@@AOOO@@@@@@@@@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.ROTATE #*(74 77)@@@@@@@@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@@@@AL@@@@@@@@@@@@@@@@@@AL@@@@@@@@@@@@@@@@@@BJ@@@@@@@@@@@@@@@@@@BJ@@@@@@@@@@@@@@@@@@DI@@@@@@@@@@@@@@@@@@DI@@@@@@@@@@@@@@@@@@HI@@@@@@@@@@@@@@@@@@HHH@@@@@@@@@@@@@@@@@HHH@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@IB@@@@@@@@@@@@@@@@@@HJ@@@@@@@@@@@@@@@@@@HF@@@@@@@@@@@@@@@@@@HB@@@@@@@@@@@@@@@@@@IB@@@@@@@@@@@@@@@@@@HL@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@@@H@@@@@@HH@@@@@@@@@@@H@@@@@@E@@@@@@@@@@@@H@@@@@@B@N@@@@@@@@@@H@@@@@@E@AH@@@@@@@@@H@@@@@@HH@F@@@@@@@@@H@@@@@@@@@AL@@@@@@@@OOOOOOOOOOOO@@@@@@@A@@@@@@@@@@AL@@@@@@@A@@@@@@@@@@F@@@@@@@@B@@@@@@@@@AH@@@@@@@@D@@@@@@@@@N@@@@@@@@@D@@@@@@@@@@@@@@@AN@@H@@@@@@@@@@@@@@@@B@A@@@@@@@@@@@@@@@@@D@A@@@@@@@@@@@@@@@@@H@B@@@@@@@@@@@@@@@@AN@D@@@@@@@@@@@@@@@@@@@D@@@@@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@@@@AA@@@@@@@@@@@@@@@@@@AA@@@@@@@@@@@@@@@@@@AB@@@@@@@@@@@@@@@@@@BD@@@@@@@@@@@@@@@@@@BDD@@@@@@@@@@@@@@@@@BHH@@@@@@@@@@@@@@@@@EA@@@@@@@@@@@@@@@@@@EF@@@@@@@@@@@@@@@@@@FH@@@@@@@@@@@@@@@@@@M@@@@@@@@@@@@@@@@@@@N@@@@@@@@@@@@@@@@@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.DELTA.LABEL #*(9 13)@@@@@H@@@H@@AD@@AD@@BB@@BB@@DA@@DA@@GO@@@@@@@@@@@@@@) - -(RPAQQ IV.THETA.LABEL #*(7 13)@@@@CH@@DD@@DD@@DD@@GL@@DD@@DD@@DD@@CH@@@@@@@@@@@@@@) - -(RPAQQ IV.TOWARD #*(35 38)@@@@@@H@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@G@@@L@@@@@@@DN@CD@@@@@@@FAONF@@@@@@@B@@@B@@@@@@@A@@@C@@@@@@@@L@@A@@@@@@@@CO@@H@@@@@@@@F@@D@@@@@@@@D@@B@@@@@@@@H@@A@@@@@@@A@@@@IB@@@@@B@@@@EN@@@@@D@@@@C@@@@@@HB@@@F@@@@@A@D@@@H@@@@@B@H@@@H@@@@@DA@D@A@@@@@@HB@H@B@@@@@A@DA@HD@@@@@B@JBA@H@@@@@DAALBA@@@@@@HB@DDB@@@@@@HD@GHD@@@@@@GH@@HH@@@@@@@@@@I@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.TOWARD.HIGHLIGHT #*(35 38)@@@@@@H@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@G@@@L@@@@@@@GN@CL@@@@@@@GOOON@@@@@@@COOON@@@@@@@AOOOO@@@@@@@@OOOO@@@@@@@@COOOH@@@@@@@@GOOL@@@@@@@@GOON@@@@@@@@OOOO@@@@@@@AOOOOHB@@@@@COOOOMN@@@@@GOOOOO@@@@@@OOOOON@@@@@AOOOOOH@@@@@COOOOOH@@@@@GOOOOO@@@@@@OOOOON@@@@@AOOOOOL@@@@@COKOOOH@@@@@GOAOOO@@@@@@ON@GON@@@@@@OL@GOL@@@@@@GH@@OH@@@@@@@@@@O@@@@@@@@@@@F@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IV.AWAY #*(36 34)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@C@@@@@@@@@@@G@@@@@@@@@@@K@@@@@@@@@@AE@@@@@@@@@@BE@@@@@@@@@@@E@@@@@@@@@@@I@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@B@@@@@@@@@@@B@@@@@@@@@@@B@@@@@@@@@@@D@@@@@@@@@@@D@@@@@@@@@@@D@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@@H@@@@@@@@@@A@@@@@@@@@@@A@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - - - -(* ; "fns for co-ordinating scenes") - -(DEFINEQ - -(IV.PROOF.SCENE - [LAMBDA (ITEM) (* gbn "21-Nov-85 01:14") - (LET ((OBJNO (fetch (IRISSCENE OBJNO) of IV.CURRENT.SCENE))) - (IV.ENSURE.SCENE IV.CURRENT.SCENE) (* makes sure the object is defined) - (IRIS.CALLOBJ OBJNO \IRISSTREAM) - (IRIS.SWAPBUFFERS \IRISSTREAM) - (ALIGN \IRISSTREAM) - (SPP.FORCEOUTPUT IRISCONN]) - -(IV.ENSURE.SCENE - [LAMBDA (SCENE) (* ; "Edited 29-Jan-87 01:22 by gbn") - (* ; - "makes sure that a scene's objno is defined.") - (LET ((OBJNO (fetch (IRISSCENE OBJNO) of SCENE))) - (if (ZEROP (IRIS.ISOBJ OBJNO \IRISSTREAM)) - then (IV.PROMPTPRINT "Creating object for " (fetch (IRISSCENE NAME) of SCENE)) - (RESETLST (RESETSAVE NIL (LIST 'IRIS.CLOSEOBJ \IRISSTREAM)) - (IRIS.MAKEOBJ OBJNO \IRISSTREAM) - (if (SETQ DRAWFN (fetch (IRISSCENE DRAWFN) of SCENE)) - then (EVAL DRAWFN) - else (IV.GETINPUT (CONCAT "Please remake " (fetch (IRISSCENE NAME) - of SCENE) - " then hit RETURN"))) - (IRIS.CLOSEOBJ \IRISSTREAM)) - (PRINTOUT IV.PROMPTWINDOW "...done" T]) - -(IV.NEW.SCENE.FROM.USER - [LAMBDA NIL (* gbn "20-Nov-85 23:21") - - (* * Reads a new scene from the user. Returns NIL if the scene is not - completed. Sets the scene menu to nil to cause it to be rebuilt when a new - scene is successfully read) - - (PROG (NAME DRAWFN OBJNO SCENE) - (SETQ NAME (IV.GETINPUT "Scene Name?")) - (if (NOT NAME) - then (RETURN)) - (SETQ SCENE (create IRISSCENE - NAME _ NAME - OBJNO _ (IRIS.CONS.OBJNO))) - (replace (IRISSCENE DRAWFN) of SCENE with (SETQ DRAWFN (IV.READ - "Form to eval to create scene? " - ))) - (if (NOT DRAWFN) - then (IRIS.MAKEOBJ (fetch (IRISSCENE OBJNO) of SCENE) - \IRISSTREAM) - (IV.GETINPUT "Make object, then type RETURN") - (IRIS.CLOSEOBJ \IRISSTREAM)) - (push IV.SCENES SCENE) - (SETQ IV.SCENES.MENU NIL) - (RETURN SCENE]) - -(IV.REDEFINE.SCENE - [LAMBDA (ITEM BUTTONS WINDOW) (* ; "Edited 29-Jan-87 01:20 by gbn") - (LET ((SCENE (IV.CHOOSE.SCENE))) - (if (MOUSECONFIRM (CONCAT "Redefine " (fetch NAME of SCENE)) - NIL IV.PROMPTWINDOW) - then (IRIS.DELOBJ (fetch OBJNO of SCENE) - \IRISSTREAM) - (REPLACE OBJNO OF SCENE WITH (IRIS.CONS.OBJNO)) - (IV.ENSURE.SCENE SCENE]) - -(IV.CHOOSE.SCENE - [LAMBDA NIL (* edited%: "12-Dec-85 20:58") - (MENU (OR IV.SCENES.MENU (IV.BUILD.SCENES.MENU]) - -(IV.BUILD.SCENES.MENU - [LAMBDA NIL (* ; "Edited 23-Jan-87 20:23 by gbn") - -(* ;;; "builds the menu used to prompt the user for scenes that can be loaded on the iris.") - - (SETQ IV.SCENES.MENU (create MENU - ITEMS _ (CONS '(New% Scene? (IV.NEW.SCENE.FROM.USER) - "allows specification of a new scene") - (for ENTRY in IV.SCENES - collect (LIST (fetch (IRISSCENE NAME) of ENTRY) - (KWOTE ENTRY]) - -(IV.FORGET.SCENE - [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "12-Dec-85 20:58") - (PROG ((NEWSCENE (IV.CHOOSE.SCENE)) - OBJNO) - (if NEWSCENE - then (DREMOVE NEWSCENE IV.SCENES) - (if (SETQ OBJNO (fetch (IRISSCENE OBJNO) of NEWSCENE)) - then (IRIS.DELOBJ OBJNO \IRISSTREAM)) - (SETQ IV.SCENES.MENU NIL]) - -(IV.DRAW.SCENE - [LAMBDA NIL (* gbn "21-Nov-85 02:09") - (OR IV.CURRENT.SCENE (ERROR "CAN'T DRAW NULL SCENE")) - (SELECTQ IV.MODE - (POLAR (IRIS.POLARVIEW IV.DIST IV.AZIM IV.INC IV.TWIST \IRISSTREAM)) - (XLATE NIL) - (LOOKAT (if (NOT (AND (EQUAL IV.OBJPT LASTIV.OBJPT) - (EQUAL IV.VIEWPT LASTIV.VIEWPT))) - then (* setup the viewing transformation, - since it has changed) - (IRIS.LOOKAT (fetch IVX of IV.VIEWPT) - (fetch IVX of IV.VIEWPT) - (fetch IVY of IV.VIEWPT) - (fetch IVZ of IV.OBJPT) - (fetch IVY of IV.OBJPT) - (fetch IVZ of IV.OBJPT) - IV.TWIST \IRISSTREAM) - (SETQ LASTIV.OBJPT IV.OBJPT) - (SETQ LASTIV.VIEWPT IV.VIEWPT))) - (ERROR "UNKNOWN IV.MODE")) - (if \IV.BACKGROUND - then (\CLEAR.IRIS \IV.BACKGROUND)) - (IRIS.CALLOBJ (fetch (IRISSCENE OBJNO) of IV.CURRENT.SCENE) - \IRISSTREAM) - (if \IV.DRAW.AXES - then (IRIS.CALLOBJ (fetch (IRISSCENE OBJNO) of AXES.SCENE) - \IRISSTREAM)) - (IRIS.SWAPBUFFERS \IRISSTREAM) - (ALIGN \IRISSTREAM]) - -(IV.SET.CURRENT.SCENE - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 4-Feb-87 19:28 by gbn") - (PROG ([NEWSCENE (MENU (OR IV.SCENES.MENU (IV.BUILD.SCENES.MENU] - SCENEITEM) - (if NEWSCENE - then (SETQ IV.CURRENT.SCENE NEWSCENE) - (SETQ SCENEITEM (FM.GETITEM 'CURRENTSCENE 'FILL-INS WINDOW)) - (OR SCENEITEM (ERROR "SCENE ITEM NOT FOUND")) - (FM.CHANGESTATE SCENEITEM (fetch (IRISSCENE NAME) of NEWSCENE) - WINDOW) (* IV.DISPLAY.FMITEM SCENEITEM WINDOW) - (IV.PROOF.SCENE SCENEITEM]) - -(IV.SCENE.SETUP - [LAMBDA NIL (* ; "Edited 4-Feb-87 19:22 by gbn") - [IF (NOT (BOUNDP 'AXES.SCENE)) - THEN (SETQ AXES.SCENE (CREATE IRISSCENE - NAME _ 'Axes - OBJNO _ (IRIS.CONS.OBJNO) - DRAWFN _ '(DRAW.AXES 2] - [IF (NOT (BOUNDP 'SKULL.SCENE)) - THEN (SETQ SKULL.SCENE (CREATE IRISSCENE - NAME _ 'Skull - OBJNO _ (IRIS.CONS.OBJNO) - DRAWFN _ '(SKULLO \IRISSTREAM] - (PUSHNEW IV.SCENES AXES.SCENE) - (PUSHNEW IV.SCENES SKULL.SCENE) - (SETQ IV.CURRENT.SCENE AXES.SCENE]) -) -(DEFINEQ - -(DRAW.AXES - [LAMBDA (WIDTH COLOR) (* edited%: "17-Dec-85 18:39") - - (* * draws tri-color axes with each axis being 200 in length in the positive - direction) - - (IRIS.PUSHATTRIBUTES \IRISSTREAM) - (IRIS.LINEWIDTH (OR WIDTH 5) - \IRISSTREAM) - (IRIS.COLOR (OR COLOR 1) - \IRISSTREAM) - (IRIS.MOVE 0 0 0 \IRISSTREAM) - (IRIS.DRAW 0 0 200 \IRISSTREAM) - (IRIS.CMOV 0 0 210 \IRISSTREAM) - (IRIS.CHARSTR "z" \IRISSTREAM) - (IRIS.COLOR (OR COLOR 2) - \IRISSTREAM) - (IRIS.MOVE 0 0 0 \IRISSTREAM) - (IRIS.DRAW 0 200 0 \IRISSTREAM) - (IRIS.CMOV 0 210 0 \IRISSTREAM) - (IRIS.CHARSTR "y" \IRISSTREAM) - (IRIS.COLOR (OR COLOR 3) - \IRISSTREAM) - (IRIS.MOVE 0 0 0 \IRISSTREAM) - (IRIS.DRAW 200 0 0 \IRISSTREAM) - (IRIS.CMOV 210 0 0 \IRISSTREAM) - (IRIS.CHARSTR "x" \IRISSTREAM) - (IRIS.POPATTRIBUTES \IRISSTREAM) - (F]) - -(F - [LAMBDA NIL (* edited%: "13-Dec-85 18:35") - (SPP.FORCEOUTPUT IRISCONN]) - -(IV.CLEARIRIS - [LAMBDA NIL (* gbn "21-Nov-85 00:51") - (DSPCOLOR (DICOLOR.FROM.USER T) - \IRISSTREAM) - (IRIS.CLEAR \IRISSTREAM) - (IRIS.SWAPBUFFERS \IRISSTREAM) - (F]) - -(IV.DOWN - [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 16:01") - (LET NIL (SELECTQ IV.MODE - (POLAR (add IV.AZIM IV.THETA)) - (XLATE (IRIS.TRANSLATE 0 (IMINUS IV.DXLATE) - 0 \IRISSTREAM)) - (PROGN (add (fetch IVX of IV.OBJPT) - IV.DXLATE))) - (IV.DRAW.SCENE]) - -(IV.GETINPUT - [LAMBDA (MSG) (* edited%: "21-Aug-85 04:10") - (CLEARW IV.PROMPTWINDOW) - (PROG1 (PROMPTFORWORD MSG NIL NIL IV.PROMPTWINDOW NIL 'TTY NIL NIL) - (WINDOWPROP IV.PROMPTWINDOW 'PROCESS NIL) (* some random process circularity fix) - ]) - -(IV.READ - [LAMBDA (PROMPT) (* gbn "20-Nov-85 23:19") - (CLEARW IV.PROMPTWINDOW) - (PRINTOUT IV.PROMPTWINDOW PROMPT) - (RESETFORM (TTYDISPLAYSTREAM IV.PROMPTWINDOW) - (LISPXREAD T T]) - -(IV.HOME - [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 18:31") - (PROG [(R (FM.ITEMPROP ITEM 'REGION] - (\FM.HIGHLIGHTITEM ITEM WINDOW) - (SELECTQ IV.MODE - (XLATE (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -5000 5000 IRISCONN) - (IV.VIEW)) - (POLAR (IRIS.POLARVIEW 500 0 0 0 \IRISSTREAM)) - (LOOKAT NIL) - (ERROR "UNKNOWN MODE")) - (IV.DRAW.SCENE) - (F]) - -(IV.2D.HOME - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 18:43 by gbn") - (PROG [(R (FM.ITEMPROP ITEM 'REGION] - (\FM.HIGHLIGHTITEM ITEM WINDOW) - (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -1000 1000 IRISCONN) - (IV.DRAW.SCENE) - (F]) - -(IV.PHOME - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 18:43 by gbn") - (PROG [(R (FM.ITEMPROP ITEM 'REGION] - (\FM.HIGHLIGHTITEM ITEM WINDOW) - (IV.PHOME.AUX) - (F]) - -(IV.PHOME.AUX - [LAMBDA NIL (* ; "Edited 27-Jan-87 18:31 by gbn") - (IRIS.ORTHO 0 SCREENWIDTH 0 SCREENHEIGHT -5000 5000 IRISCONN) - (IRIS.VIEWPORT 0 IRIS.XMAXSCREEN 0 IRIS.YMAXSCREEN IRISCONN) - (IRIS.PERSPECTIVE (IRIS.DEGREES 45) - (IQUOTIENT IRIS.XMAXSCREEN IRIS.YMAXSCREEN) - 0 10000 IRISCONN) (* ; - "The projection (world-space -> eye-space) transformation") - (IRIS.POLARVIEW 500 (IRIS.DEGREES 45) - (IRIS.DEGREES 45) - 0 IRISCONN) (* ; - "the viewing (placing eye-space in world-space) transformation") - (IV.DRAW.SCENE]) - -(IV.VIEW - [LAMBDA (Z) (* edited%: "17-Dec-85 18:32") - (IRIS.PERSPECTIVE (IRIS.DEGREES 45) - (IQUOTIENT IRIS.XMAXSCREEN IRIS.YMAXSCREEN) - 0 10000 IRISCONN) - (IRIS.POLARVIEW (OR Z 1000) - (IRIS.DEGREES 90) - (IRIS.DEGREES 90) - 0 IRISCONN]) - -(IV.LEFT - [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 15:59") - (LET NIL (SELECTQ IV.MODE - (POLAR (add IV.AZIM IV.THETA)) - (XLATE (IRIS.TRANSLATE (IMINUS IV.DXLATE) - 0 0 \IRISSTREAM)) - (PROGN (add (fetch IVX of IV.OBJPT) - IV.DXLATE))) - (IV.DRAW.SCENE]) - -(IV.RIGHT - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 17:55 by gbn") - (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT) - THEN (IMINUS IV.DXLATE) - ELSE IV.DXLATE))) - (IRIS.TRANSLATE MOVE 0 0 \IRISSTREAM) - (IV.DRAW.SCENE]) - -(IV.ROTX - [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 16:03") - (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT) - then (MINUS IV.THETA) - else IV.THETA) - IRIS.XAXIS \IRISSTREAM) - (IV.DRAW.SCENE]) - -(IV.DOUBLEBUFFER - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 29-Jan-87 00:03 by gbn") - (PROG [(STATE (FM.ITEMPROP ITEM 'STATE] - (if STATE - then (IRIS.DOUBLEBUFFER \IRISSTREAM) - (IRIS.FRONTBUFFER 0) - (IRIS.BACKBUFFER 1) - (IV.PROMPTPRINT "Double buffering.") - else (IRIS.SINGLEBUFFER \IRISSTREAM) - (IRIS.FRONTBUFFER 1) - (IRIS.BACKBUFFER 0) - (IV.PROMPTPRINT "Single buffering.")) - (IRIS.GCONFIG IRISCONN]) - -(IV.ROTY - [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 16:04") - (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT) - then (MINUS IV.THETA) - else IV.THETA) - IRIS.YAXIS \IRISSTREAM) - (IV.DRAW.SCENE]) - -(IV.ROTZ - [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 16:02") - (IRIS.ROTATE (if (SHIFTDOWNP 'SHIFT) - then (MINUS IV.THETA) - else IV.THETA) - IRIS.ZAXIS \IRISSTREAM) - (IV.DRAW.SCENE]) - -(IV.SWAPBUFFERS - [LAMBDA NIL (* gbn "14-Nov-85 18:27") - (IRIS.SWAPBUFFERS \IRISSTREAM) - (SPP.FORCEOUTPUT IRISCONN]) - -(IV.UP - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 17:55 by gbn") - (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT) - THEN (IMINUS IV.DXLATE) - ELSE IV.DXLATE))) - (IRIS.TRANSLATE 0 MOVE 0 \IRISSTREAM) - (IV.DRAW.SCENE]) - -(IV.THETA - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 01:13 by gbn") - - (* controls whether or not the background is cleared before drawing a scene) - - (LET ((NEW (RNUMBER "Enter new rotation in degrees"))) - (if NEW - then (SETQ IV.THETA (ITIMES 10 NEW)) - (FM.CHANGESTATE (FM.GETITEM 'THETA 'FILL-INS WINDOW) - NEW WINDOW]) - -(IV.AXES - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 29-Jan-87 00:17 by gbn") - (* ; - "controls whether or not axes are drawn in the scene.") - (if (FM.ITEMPROP ITEM 'STATE) - then (SETQ \IV.DRAW.AXES T) - (IV.ENSURE.SCENE AXES.SCENE) - else (SETQ \IV.DRAW.AXES)) - (IV.DRAW.SCENE]) - -(IV.BACKGROUND - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 28-Jan-87 17:01 by gbn") - (* ; - "controls whether or not the background is cleared before drawing a scene") - (LET ((NAME-OR-RGB (DICOLOR.FROM.USER T))) - (SETQ \IV.BACKGROUND (if NAME-OR-RGB - then (\IRIS.ASSURE.COLOR NAME-OR-RGB \IRISSTREAM) - else NIL)) - (FM.CHANGELABEL (FM.GETITEM 'BACKGROUND 'FILL-INS WINDOW) - (if NAME-OR-RGB - then (L-CASE (MKSTRING NAME-OR-RGB)) - else "none") - WINDOW) - (IV.DRAW.SCENE]) - -(IV.TOWARD - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 17:55 by gbn") - (LET ((MOVE (IF (SHIFTDOWNP 'SHIFT) - THEN (IMINUS IV.DXLATE) - ELSE IV.DXLATE))) - (IRIS.TRANSLATE 0 0 MOVE \IRISSTREAM) - (IV.DRAW.SCENE]) - -(IV.AWAY - [LAMBDA (ITEM WINDOW BUTTONS) (* edited%: "17-Dec-85 15:39") - (LET NIL (SELECTQ IV.MODE - (POLAR (add IV.AZIM IV.THETA)) - (XLATE (IRIS.TRANSLATE 0 0 (MINUS IV.DXLATE) - \IRISSTREAM)) - (PROGN (add (fetch IVX of IV.OBJPT) - IV.DXLATE))) - (IV.DRAW.SCENE]) - -(IV.DSPCOLOR - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 28-Jan-87 17:02 by gbn") - -(* ;;; "sets the dspcolor for the stream (foreground color)") - - (LET ((RGB (DICOLOR.FROM.USER T))) - (if RGB - then (DSPCOLOR RGB \IRISSTREAM) - (FM.CHANGESTATE (FM.GETITEM 'DSPCOLOR 'FILL-INS WINDOW) - (if RGB - then (L-CASE (MKSTRING RGB)) - else "none") - WINDOW) - else NIL]) - -(IV.DELTA - [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Jan-87 01:13 by gbn") - (LET ((NEW (RNUMBER "Enter new translation value"))) - (if NEW - then (FM.CHANGESTATE (FM.GETITEM 'DELTA 'FILL-INS WINDOW) - (SETQ IV.DXLATE NEW) - WINDOW]) - -(IV.VIEW.CHANGED - [LAMBDA NIL (* ; "Edited 3-Feb-87 00:00 by gbn") - 'JUNK]) - -(IV.NEWSTREAM - [LAMBDA (ITEM BUTTONS WINDOW) (* ; "Edited 29-Jan-87 00:59 by gbn") - (IF (MOUSECONFIRM "kill old stream? (lose fonts, etc.)" "left to confirm" IV.PROMPTWINDOW) - THEN (SETQ IRISCONN NIL) - (OPENIRISSTREAM IRISNSHOSTNUMBER]) - -(IV.PROMPTPRINT - [LAMBDA ARGS (* edited%: "21-Aug-85 06:10") - (CLEARW IV.PROMPTWINDOW) - (for F from 1 to ARGS do (PRIN1 (ARG ARGS F) - IV.PROMPTWINDOW]) - -(IV.PROOF.SKETCH - [LAMBDA (ARGS |...|) (* edited%: "21-Aug-85 10:39") - (IV.PROMPTPRINT "SKETCHing...") - (IRIS.SKETCH (PROG1 NIL (GETPOSITION))) - (ALIGN \IRISSTREAM) - (IV.PROMPTPRINT "done"]) - -(IV.INIT - [LAMBDA (MENU-POSITION) (* ; "Edited 4-Feb-87 19:23 by gbn") - -(* ;;; "uses freemenu to build the view controller menu ") - - (LET NIL (if (BOUNDP 'IV.DEMOW) - then (CLOSEW IV.DEMOW)) - (MOVEW (SETQ IV.DEMOW (FREEMENU *IV-MENUDESC*)) - MENU-POSITION) - (SETQ IV.PROMPTWINDOW (GETPROMPTWINDOW IV.DEMOW 2)) - (IV.NEWSTREAM NIL NIL NIL) (* ; "INIT LOOKAT PARAMS") - (SETQ LASTIV.OBJPT (create IVPOS - IVX _ 0 - IVY _ 0 - IVZ _ 1)) - (SETQ IV.OBJPT (create IVPOS - IVX _ 0 - IVY _ 0 - IVZ _ 0)) - (SETQ IV.VIEWPT (create IVPOS - IVX _ 0 - IVY _ 0 - IVZ _ -1000)) - (SETQ LASTIV.VIEWPT (create IVPOS - IVX _ 0 - IVY _ 0 - IVZ _ -1001)) (* ; - "The amount that a translate should move") - (SETQ IV.DXLATE 10) (* ; "INIT POLAR PARAMS") - (SETQ IV.DIST 500) - (SETQ IV.AZIM (SETQ IV.INC (SETQ IV.TWIST 0))) - (SETQ IV.MODE 'XLATE) - (IRIS.DOUBLEBUFFER \IRISSTREAM) - (IV.SCENE.SETUP) - (IV.ENSURE.SCENE AXES.SCENE) - (IV.PHOME.AUX) - (IV.DRAW.SCENE) - (IV.DRAW.SCENE) - (IRIS.GCONFIG \IRISSTREAM]) - -(\CLEAR.IRIS - [LAMBDA (COLOR) (* gbn "21-Nov-85 02:10") - (IRIS.PUSHATTRIBUTES \IRISSTREAM) - (IRIS.COLOR (\IRIS.ASSURE.COLOR COLOR \IRISSTREAM)) - (IRIS.CLEAR \IRISSTREAM) - (IRIS.POPATTRIBUTES]) - -(IRIS.DEGREES - [LAMBDA (DEGREES) (* edited%: "13-Dec-85 18:32") - - (* Takes an angle in degrees and returns an angle as the iris likes it - (tenths)) - - (FIX (TIMES DEGREES 10]) -) -(DEFINEQ - -(IV.ITEMMAPFN - [LAMBDA (ITEM) (* edited%: "21-Aug-85 02:05") - (if (EQUAL (FM.ITEMPROP ITEM 'NAME%:) - NAME) - then (SETQ RESULT ITEM]) - -(IV.DISPLAY.FMITEM - [LAMBDA (ITEM WINDOW) (* gbn "15-Nov-85 12:25") - (HELP)(* PROG ((STREAM (fetch (FREEMENU STREAM) of - (WINDOWPROP WINDOW (QUOTE FREEMENU)))) (FONT - (FM.ITEMPROP ITEM (QUOTE FONT%:))) (REGION - (FM.ITEMPROP ITEM (QUOTE REGION))) (LABEL - (FM.ITEMPROP ITEM (QUOTE LABEL)))) (DSPDESTINATION - (FM.ITEMPROP ITEM (QUOTE BITMAP)) STREAM) - (DSPXPOSITION 0 STREAM) (DSPYPOSITION (FONTPROP FONT - (QUOTE DESCENT)) STREAM) (DSPFONT FONT STREAM) - (PRIN1 LABEL STREAM) (replace (REGION WIDTH) of REGION with - (STRINGWIDTH LABEL FONT)) (FM.DISPLAYITEM ITEM WINDOW) - (BLTSHADE WHITESHADE WINDOW (IPLUS (fetch - (REGION LEFT) of REGION) (fetch (REGION WIDTH) of REGION)) - (fetch (REGION BOTTOM) of REGION) (IDIFFERENCE - (BITMAPWIDTH (FM.ITEMPROP ITEM (QUOTE BITMAP))) - (fetch (REGION WIDTH) of REGION)) (BITMAPHEIGHT - (FM.ITEMPROP ITEM (QUOTE BITMAP))))) - ]) -) -(DECLARE%: EVAL@COMPILE - -(RECORD IRISSCENE (NAME DRAWFN OBJNO) - OBJNO _ (IRIS.CONS.OBJNO)) - -(RECORD IVPOS (IVX IVY IVZ)) -) - -(RPAQQ HANDWIDTH 48) - -(RPAQQ IRIS.XAXIS 88) - -(RPAQQ IRIS.ZAXIS 90) - -(RPAQQ IV.DXLATE 10) - -(RPAQQ IV.MODE XLATE) - -(RPAQQ IV.OBJPT (0 0 0)) - -(RPAQQ IV.THETA 50) - -(RPAQQ IV.TRACE.FNS (IRIS.POPMATRIX IRIS.ROTATE IRIS.TRANSLATE)) - -(RPAQQ IV.TWIST 0) - -(RPAQQ IV.VIEWPT (0 0 -1000)) - -(RPAQQ LASTIV.OBJPT (0 0 1)) - -(RPAQQ LASTIV.VIEWPT (0 0 -1001)) - -(RPAQQ \IV.DRAW.AXES NIL) - -(RPAQQ \IV.BACKGROUND NIL) -(IV.SCENE.SETUP) -(IV.BUILD.SCENES.MENU) -(DEFINEQ - -(SKULLO - [LAMBDA (*STREAM*) - (FILLCIRCLE 529 377 192.0 '(NIL (255 0 0)) *STREAM*) - (DRAWCIRCLE 529 377 192.0 '(ROUND 1 (0 255 255)) 'NIL *STREAM*) - (FILLPOLYGON '((530 . 568) - (476 . 562) - (426 . 540) - (380 . 500) - (349 . 445) - (337 . 386) - (344 . 323) - (383 . 250) - (436 . 208) - (484 . 190) - (530 . 184)) '(NIL (0 0 255)) *STREAM*) - (DRAWLINE 530 568 476 562 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 476 562 426 540 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 426 540 380 500 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 380 500 349 445 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 349 445 337 386 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 337 386 344 323 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 344 323 383 250 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 383 250 436 208 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 436 208 484 190 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 484 190 530 184 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (DRAWLINE 530 184 530 568 '1 'NIL *STREAM* '(0 255 255) 'NIL) - (FILLCIRCLE 529 417 152.0526 '(NIL (255 255 255)) *STREAM*) - (DRAWCIRCLE 529 417 152.0526 '(ROUND 1 (255 255 255)) 'NIL *STREAM*) - (FILLPOLYGON '((639 . 312) - (642 . 301) - (642 . 291) - (640 . 283) - (635 . 276) - (629 . 273) - (620 . 272) - (611 . 294)) '(NIL (255 255 255)) *STREAM*) - (DRAWLINE 639 312 642 301 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 642 301 642 291 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 642 291 640 283 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 640 283 635 276 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 635 276 629 273 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 629 273 620 272 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 620 272 611 294 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 611 294 639 312 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (FILLPOLYGON '((446 . 300) - (439 . 271) - (439 . 254) - (440 . 245) - (446 . 236) - (455 . 231) - (465 . 227) - (529 . 220) - (602 . 227) - (611 . 229) - (618 . 236) - (622 . 245) - (622 . 256) - (620 . 271) - (615 . 302)) '(NIL (255 255 255)) *STREAM*) - (DRAWLINE 446 300 439 271 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 439 271 439 254 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 439 254 440 245 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 440 245 446 236 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 446 236 455 231 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 455 231 465 227 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 465 227 529 220 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 529 220 602 227 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 602 227 611 229 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 611 229 618 236 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 618 236 622 245 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 622 245 622 256 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 622 256 620 271 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 620 271 615 302 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 615 302 446 300 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (FILLPOLYGON '((468 . 228) - (466 . 222) - (468 . 216) - (474 . 218) - (478 . 212) - (481 . 213) - (486 . 202) - (493 . 205) - (499 . 194) - (505 . 198) - (514 . 186) - (522 . 191) - (530 . 187) - (538 . 192) - (546 . 186) - (554 . 192) - (559 . 190) - (566 . 196) - (572 . 194) - (578 . 202) - (584 . 201) - (589 . 210) - (593 . 209) - (598 . 214) - (601 . 214) - (604 . 219) - (600 . 226)) '(NIL (255 255 255)) *STREAM*) - (DRAWLINE 468 228 466 222 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 466 222 468 216 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 468 216 474 218 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 474 218 478 212 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 478 212 481 213 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 481 213 486 202 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 486 202 493 205 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 493 205 499 194 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 499 194 505 198 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 505 198 514 186 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 514 186 522 191 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 522 191 530 187 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 530 187 538 192 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 538 192 546 186 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 546 186 554 192 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 554 192 559 190 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 559 190 566 196 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 566 196 572 194 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 572 194 578 202 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 578 202 584 201 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 584 201 589 210 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 589 210 593 209 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 593 209 598 214 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 598 214 601 214 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 601 214 604 219 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 604 219 600 226 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 600 226 468 228 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (FILLPOLYGON '((422 . 310) - (419 . 298) - (419 . 283) - (420 . 278) - (424 . 274) - (431 . 272) - (439 . 271) - (451 . 292)) '(NIL (255 255 255)) *STREAM*) - (DRAWLINE 422 310 419 298 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 419 298 419 283 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 419 283 420 278 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 420 278 424 274 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 424 274 431 272 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 431 272 439 271 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 439 271 451 292 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 451 292 422 310 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (FILLCIRCLE 527 419 136.0 '(NIL (255 0 0)) *STREAM*) - (DRAWCIRCLE 527 419 136.0 '(ROUND 2 (255 255 255)) 'NIL *STREAM*) - (FILLPOLYGON '((564 . 550) - (582 . 544) - (609 . 527) - (632 . 506) - (650 . 478) - (662 . 441) - (664 . 404) - (654 . 369) - (638 . 340) - (616 . 316) - (591 . 299) - (565 . 286) - (532 . 280) - (490 . 286)) '(NIL (0 0 255)) *STREAM*) - (DRAWLINE 564 550 582 544 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 582 544 609 527 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 609 527 632 506 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 632 506 650 478 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 650 478 662 441 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 662 441 664 404 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 664 404 654 369 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 654 369 638 340 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 638 340 616 316 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 616 316 591 299 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 591 299 565 286 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 565 286 532 280 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 532 280 490 286 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 490 286 564 550 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (FILLPOLYGON '((564 . 550) - (560 . 532) - (568 . 530) - (548 . 492) - (574 . 492) - (536 . 432) - (572 . 433) - (522 . 378) - (559 . 378) - (492 . 286) - (510 . 362) - (482 . 363) - (518 . 418) - (496 . 418) - (542 . 480) - (520 . 480) - (554 . 525) - (545 . 524)) '(NIL (255 255 255)) *STREAM*) - (DRAWLINE 564 550 560 532 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 560 532 568 530 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 568 530 548 492 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 548 492 574 492 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 574 492 536 432 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 536 432 572 433 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 572 433 522 378 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 522 378 559 378 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 559 378 492 286 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 492 286 510 362 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 510 362 482 363 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 482 363 518 418 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 518 418 496 418 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 496 418 542 480 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 542 480 520 480 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 520 480 554 525 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 554 525 545 524 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWLINE 545 524 564 550 '1 'NIL *STREAM* '(255 255 255) 'NIL) - (DRAWCIRCLE 529 417 136.0 '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((420 . 311) - (390 . 354) - (377 . 415) - (387 . 470) - (409 . 511) - (444 . 542) - (488 . 563) - (528 . 569) - (581 . 559) - (630 . 531) - (657 . 498) - (677 . 453) - (679 . 392) - (662 . 342) - (640 . 312)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((565 . 547)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 565 547 547 522 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((547 . 522)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 547 522 555 522 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((555 . 522)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 555 522 522 478 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((522 . 478)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 522 478 545 479 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((545 . 479)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 545 479 499 416 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((499 . 416)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 499 416 521 416 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((521 . 416)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 521 416 483 362 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((483 . 362)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 483 362 512 360 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((512 . 360)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 512 360 493 285 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((493 . 285)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((566 . 548)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 566 548 562 529 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((562 . 529)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 562 529 570 529 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((570 . 529)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 570 529 550 490 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((550 . 490)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 550 490 575 490 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((575 . 490)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 575 490 538 430 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((538 . 430)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 538 430 573 431 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((573 . 431)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 573 431 526 377 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((526 . 377)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 526 377 561 376 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((561 . 376)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWLINE 561 376 493 285 '2 'NIL *STREAM* '(0 0 0) 'NIL) - (DRAWCURVE '((493 . 285)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCIRCLE 529 377 192.0 '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((478 . 260) - (471 . 258) - (462 . 256) - (459 . 268) - (462 . 283) - (457 . 289)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((513 . 256) - (520 . 260) - (508 . 266) - (490 . 267) - (481 . 264) - (478 . 260) - (486 . 258) - (499 . 253)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((589 . 261) - (593 . 261) - (605 . 265) - (605 . 273) - (605 . 285) - (605 . 293)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((549 . 253) - (545 . 257) - (545 . 265) - (561 . 267) - (569 . 267) - (577 . 265) - (585 . 261) - (589 . 261) - (581 . 257) - (573 . 257) - (561 . 253) - (553 . 253)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((638 . 312) - (640 . 302) - (641 . 291) - (639 . 280) - (629 . 273) - (617 . 271)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((619 . 271) - (621 . 256) - (620 . 240) - (611 . 230) - (602 . 226)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((438 . 271) - (438 . 253) - (442 . 240) - (453 . 231) - (465 . 227)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((421 . 310) - (418 . 294) - (420 . 276) - (431 . 271) - (436 . 271)) 'NIL '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((534 . 240) - (533 . 234) - (534 . 230) - (539 . 226) - (543 . 232) - (540 . 235)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((527 . 242) - (528 . 236) - (527 . 229) - (520 . 227) - (521 . 234) - (524 . 238)) 'T '(ROUND 2 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((465 . 226) - (466 . 219) - (469 . 215) - (472 . 218) - (473 . 223) - (470 . 228)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((474 . 222) - (475 . 215) - (478 . 211) - (481 . 214) - (482 . 219) - (479 . 224)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((483 . 219) - (486 . 222) - (493 . 219) - (493 . 213) - (493 . 206) - (486 . 203) - (482 . 209)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((494 . 216) - (496 . 219) - (501 . 218) - (505 . 213) - (505 . 203) - (505 . 199) - (502 . 195) - (497 . 195) - (495 . 200) - (494 . 205) - (494 . 210)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((507 . 209) - (510 . 213) - (517 . 212) - (520 . 206) - (521 . 199) - (521 . 193) - (519 . 189) - (513 . 186) - (509 . 190) - (506 . 196)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((523 . 208) - (526 . 212) - (533 . 211) - (536 . 205) - (537 . 198) - (537 . 192) - (535 . 188) - (529 . 185) - (525 . 189) - (522 . 195)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((539 . 208) - (542 . 212) - (549 . 211) - (552 . 205) - (553 . 198) - (553 . 192) - (551 . 188) - (545 . 185) - (541 . 189) - (538 . 195)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((553 . 212) - (555 . 215) - (560 . 214) - (564 . 209) - (564 . 199) - (564 . 195) - (561 . 191) - (556 . 191) - (554 . 196) - (553 . 201) - (553 . 206)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((565 . 215) - (567 . 218) - (572 . 217) - (576 . 212) - (576 . 202) - (576 . 198) - (573 . 194) - (568 . 194) - (566 . 199) - (565 . 204) - (565 . 209)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((578 . 217) - (581 . 220) - (588 . 217) - (588 . 211) - (588 . 204) - (581 . 201) - (577 . 207)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((588 . 220) - (589 . 213) - (592 . 209) - (595 . 212) - (596 . 217) - (593 . 222)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*) - (DRAWCURVE '((596 . 224) - (597 . 217) - (600 . 213) - (603 . 216) - (604 . 221) - (601 . 226)) 'T '(ROUND 3 (0 0 0)) 'NIL *STREAM*]) -) - - - -(* ;; "The order of these variables is important.") - - -(CL:DEFPARAMETER *IV-SCENES-MENUDESC* `(NIL ((LABEL "Draw Scene" SELECTEDFN IV.PROOF.SCENE HJUSTIFY - CENTER)) - ((LABEL "Forget Scene" SELECTEDFN IV.FORGET.SCENE - HJUSTIFY CENTER)) - ((LABEL "Redefine Scene" SELECTEDFN IV.REDEFINE.SCENE - HJUSTIFY CENTER))) ) - - -(CL:DEFPARAMETER *IV-FILLINS-MENUDESC* `[(GROUP (PROPS FORMAT TABLE ID FILL-INS) - ((LABEL "Change Scene" SELECTEDFN - IV.SET.CURRENT.SCENE) - (TYPE EDIT ID CURRENTSCENE LABEL "axes" MAXWIDTH 55) - ) - ((LABEL "" TYPE DISPLAY) - (LABEL "" TYPE DISPLAY)) - [(LABEL "Background:" SELECTEDFN IV.BACKGROUND) - (TYPE EDIT ID BACKGROUND LABEL "black" SELECTEDFN - IV.BACKGROUND MAXWIDTH ,(STRINGWIDTH - ">background<"] - [(LABEL "Foreground:" SELECTEDFN IV.DSPCOLOR) - (TYPE EDIT ID DSPCOLOR LABEL "red" SELECTEDFN - IV.DSPCOLOR MAXWIDTH ,(STRINGWIDTH - ">background<"] - [(LABEL ,IV.DELTA.LABEL SELECTEDFN IV.DELTA) - (TYPE EDIT ID DELTA LABEL ,(MKSTRING IV.DXLATE] - ((LABEL ,IV.THETA.LABEL SELECTEDFN IV.THETA) - (TYPE EDIT ID THETA LABEL ,(MKSTRING IV.THETA] - ) - - -(CL:DEFPARAMETER *IV-COMMANDS-MENUDESC* `[(GROUP (PROPS FORMAT ROW) - ((LABEL "New Stream" SELECTEDFN IV.NEWSTREAM - HJUSTIFY CENTER)) - ((TYPE TOGGLE LABEL "Axes" SELECTEDFN IV.AXES - HJUSTIFY CENTER INITSTATE NIL)) - ((TYPE TOGGLE LABEL "Double Buffer" SELECTEDFN - IV.DOUBLEBUFFER HJUSTIFY CENTER INITSTATE T)) - ((TYPE MOMENTARY LABEL "Swap buffers" SELECTEDFN - IV.SWAPBUFFERS HJUSTIFY CENTER)) - ((TYPE MOMENTARY LABEL "Clear IRIS" SELECTEDFN - IV.CLEARIRIS HJUSTIFY CENTER)) - ((TYPE DISPLAY LABEL "")) - ,@*IV-SCENES-MENUDESC* - (,@*IV-FILLINS-MENUDESC*] ) - - -(CL:DEFPARAMETER *IV-POSITIONING-MENU-DESC* `((GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BOX 0) - (LABEL ,IV.TOWARD HIGHLIGHT ,IV.TOWARD.HIGHLIGHT - LEFT 0 BOTTOM 0 HELDFN IV.TOWARD) - (LABEL ,IV.ROTZ HIGHLIGHT ,IV.ROTZ.HIGHLIGHT - LEFT ,(IPLUS -10 (BITMAPWIDTH IV.TOWARD)) - BOTTOM ,(BITMAPHEIGHT IV.TOWARD) HELDFN - IV.ROTZ) - [TYPE DISPLAY LABEL ,IV.ROTATE LEFT - ,(IPLUS (BITMAPWIDTH IV.TOWARD) - (IQUOTIENT (BITMAPWIDTH IV.ROTZ) - 2)) BOTTOM - ,(IPLUS (BITMAPHEIGHT IV.ROTZ) - (BITMAPHEIGHT IV.TOWARD] - (LABEL ,IV.RIGHT HIGHLIGHT ,IV.RIGHT.HIGHLIGHT - LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD) - (IQUOTIENT (BITMAPWIDTH - IV.ROTZ) - 2) - (BITMAPWIDTH IV.ROTATE) - (BITMAPWIDTH IV.ROTX)) - BOTTOM ,(IPLUS (BITMAPHEIGHT IV.ROTZ) - (BITMAPHEIGHT IV.TOWARD) - 20) HELDFN IV.RIGHT) - (LABEL ,IV.ROTX HIGHLIGHT ,IV.ROTX.HIGHLIGHT - LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD) - (IQUOTIENT (BITMAPWIDTH - IV.ROTZ) - 2) - (BITMAPWIDTH IV.ROTATE)) - BOTTOM ,(IPLUS (BITMAPHEIGHT IV.ROTZ) - (BITMAPHEIGHT IV.TOWARD)) - HELDFN IV.ROTX) - (LABEL ,IV.UP HIGHLIGHT ,IV.UP.HIGHLIGHT LEFT - ,(IPLUS (BITMAPWIDTH IV.TOWARD) - (IQUOTIENT (BITMAPWIDTH IV.ROTZ) - 2) - 10) BOTTOM - ,(IPLUS (BITMAPHEIGHT IV.TOWARD) - (BITMAPHEIGHT IV.ROTZ) - (BITMAPHEIGHT IV.ROTATE) - (BITMAPHEIGHT IV.ROTY) - -5) HELDFN IV.UP) - (LABEL "2D-Home" DOWNFN IV.2D.HOME LEFT - ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) - BOTTOM ,(BITMAPHEIGHT IV.TOWARD)) - [LABEL "Home" DOWNFN IV.HOME LEFT - ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) - BOTTOM ,(IPLUS -15 (BITMAPHEIGHT - IV.TOWARD] - [LABEL "Acute-Home" DOWNFN IV.PHOME LEFT - ,(FIX (TIMES 2.5 (BITMAPWIDTH IV.ROTZ))) - BOTTOM ,(IPLUS -30 (BITMAPHEIGHT - IV.TOWARD] - (LABEL ,IV.ROTY HIGHLIGHT ,IV.ROTY.HIGHLIGHT - LEFT ,(IPLUS (BITMAPWIDTH IV.TOWARD) - (IQUOTIENT (BITMAPWIDTH - IV.ROTZ) - 2) - 5) BOTTOM - ,(IPLUS (BITMAPHEIGHT IV.TOWARD) - (BITMAPHEIGHT IV.ROTZ) - (BITMAPHEIGHT IV.ROTATE)) HELDFN - IV.ROTY))) ) - - -(CL:DEFPARAMETER *IV-MENUDESC* `[(PROPS FORMAT ROW BOX 4) - ((TYPE DISPLAY LABEL "IRIS View Controller" HJUSTIFY CENTER FONT - (MODERN 10 BOLD))) - (,@*IV-POSITIONING-MENU-DESC* (GROUP (PROPS FORMAT COLUMN) - (,@*IV-COMMANDS-MENUDESC*] - ) - - -(PUTPROPS IRISVIEW FILETYPE :FAKE-COMPILE-FILE) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA IV.PROMPTPRINT) -) -(PUTPROPS IRISVIEW COPYRIGHT ("Xerox Corporation" 1985 1987)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (11707 19606 (IV.PROOF.SCENE 11717 . 12158) (IV.ENSURE.SCENE 12160 . 13349) ( -IV.NEW.SCENE.FROM.USER 13351 . 14631) (IV.REDEFINE.SCENE 14633 . 15155) (IV.CHOOSE.SCENE 15157 . 15334 -) (IV.BUILD.SCENES.MENU 15336 . 16056) (IV.FORGET.SCENE 16058 . 16516) (IV.DRAW.SCENE 16518 . 18096) ( -IV.SET.CURRENT.SCENE 18098 . 18798) (IV.SCENE.SETUP 18800 . 19604)) (19607 33829 (DRAW.AXES 19617 . -20587) (F 20589 . 20727) (IV.CLEARIRIS 20729 . 20978) (IV.DOWN 20980 . 21419) (IV.GETINPUT 21421 . -21757) (IV.READ 21759 . 22011) (IV.HOME 22013 . 22529) (IV.2D.HOME 22531 . 22857) (IV.PHOME 22859 . -23110) (IV.PHOME.AUX 23112 . 23926) (IV.VIEW 23928 . 24278) (IV.LEFT 24280 . 24719) (IV.RIGHT 24721 . -25050) (IV.ROTX 25052 . 25354) (IV.DOUBLEBUFFER 25356 . 25967) (IV.ROTY 25969 . 26271) (IV.ROTZ 26273 - . 26575) (IV.SWAPBUFFERS 26577 . 26758) (IV.UP 26760 . 27086) (IV.THETA 27088 . 27554) (IV.AXES 27556 - . 28039) (IV.BACKGROUND 28041 . 28829) (IV.TOWARD 28831 . 29161) (IV.AWAY 29163 . 29601) (IV.DSPCOLOR - 29603 . 30179) (IV.DELTA 30181 . 30534) (IV.VIEW.CHANGED 30536 . 30675) (IV.NEWSTREAM 30677 . 30986) -(IV.PROMPTPRINT 30988 . 31255) (IV.PROOF.SKETCH 31257 . 31518) (IV.INIT 31520 . 33296) (\CLEAR.IRIS -33298 . 33558) (IRIS.DEGREES 33560 . 33827)) (33830 35177 (IV.ITEMMAPFN 33840 . 34061) ( -IV.DISPLAY.FMITEM 34063 . 35175)) (35819 55207 (SKULLO 35829 . 55205))))) -STOP diff --git a/obsolete/lispusers/KOTOLOGO b/obsolete/lispusers/KOTOLOGO deleted file mode 100644 index 3e73f0e5..00000000 --- a/obsolete/lispusers/KOTOLOGO +++ /dev/null @@ -1,70 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(filecreated "17-Aug-88 03:42:15" {erinyes}medley>kotologo.\;1 3467 - - |changes| |to:| (vars kotologocoms) - (fns kotologow)) - - -; Copyright (c) 1988 by Xerox Corporation. All rights reserved. - -(prettycomprint kotologocoms) - -(rpaqq kotologocoms ((fns kotologow \\drawlogowindowimage))) -(defineq - -(kotologow - (lambda (string where title angledelta) (* |edited:| " 1-AUG-83 22:55") - (* |creates| \a |logo| |window.|) - (prog ((circlesize 60) - (logoxcenter 70) - (logoycenter 65) - (logowindowheight 180) - w logowindowwidth wimagewidth wimageheight (string (or string "Interlisp-D"))) - (or angledelta (setq angledelta 23)) - (setq wimagewidth (fix (ftimes circlesize 0.62))) - (setq wimageheight (fix (ftimes circlesize 0.5))) - (setq logowindowwidth (iplus logoxcenter 30 wimagewidth (stringwidth string - '(timesromand 36)))) - (setq w (cond - ((typenamep where 'window) - where) - (t (createw (cond - ((positionp where) - (|create| region - left _ (|fetch| (position xcoord) |of| where) - bottom _ (|fetch| (position ycoord) |of| where) - width _ logowindowwidth - height _ logowindowheight)) - (t (getboxregion logowindowwidth logowindowheight nil nil nil - "Specify location for logo window."))) - (or title (concat "Copyright (c) by Xerox Corporation" " " - (or makesysdate (date)))))))) - (|for| angle |from| 0 |to| 270 |by| angledelta - |do| (\\drawlogowindowimage (iplus logoxcenter (ftimes circlesize (cos angle))) - (iplus logoycenter (ftimes circlesize (sin angle))) - wimagewidth wimageheight 2 w)) - (moveto (iplus logoxcenter 10 wimagewidth) - (iplus 2 (idifference logoycenter circlesize)) - w) - (dspfont '(timesromand 36) - w) - (prin3 string w) - (return w)))) - -(\\drawlogowindowimage - (lambda (xpos ypos width height border w) (* |rrb| "22-FEB-82 18:04") - (* |makes| \a |window| |image.| - |This| |is| |part| |of| |the| |logo| - |drawing.|) - (bitblt nil nil nil w xpos ypos width height 'texture 'replace blackshade) - (bitblt nil nil nil w (iplus border xpos) - (iplus border ypos) - (idifference width (itimes border 2)) - (idifference height (itimes border 3)) - 'texture - 'replace whiteshade))) -) -(putprops kotologo copyright ("Xerox Corporation" 1988)) -(declare\: dontcopy - (filemap (nil (393 3387 (kotologow 403 . 2682) (\\drawlogowindowimage 2684 . 3385))))) -stop diff --git a/obsolete/lispusers/KOTOLOGO.TEDIT b/obsolete/lispusers/KOTOLOGO.TEDIT deleted file mode 100644 index ecb4ce39..00000000 Binary files a/obsolete/lispusers/KOTOLOGO.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/LISPNERD b/obsolete/lispusers/LISPNERD deleted file mode 100644 index b633b3ea..00000000 --- a/obsolete/lispusers/LISPNERD +++ /dev/null @@ -1,223 +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 diff --git a/obsolete/lispusers/LISPNERD.TEDIT b/obsolete/lispusers/LISPNERD.TEDIT deleted file mode 100644 index a0c733ba..00000000 Binary files a/obsolete/lispusers/LISPNERD.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/LOADIRIS b/obsolete/lispusers/LOADIRIS deleted file mode 100644 index 72a4f502..00000000 --- a/obsolete/lispusers/LOADIRIS +++ /dev/null @@ -1,246 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "10-May-88 00:44:06" {ERINYES}MEDLEY>LOADIRIS.;1 15990 - - previous date%: " 4-Feb-87 20:09:38" {ERINYES}LYRIC>LOADIRIS.;1) - - -(* " -Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LOADIRISCOMS) - -(RPAQQ LOADIRISCOMS ((FILES FREEMENU) - (FNS LI.CIRCLES LI.LOAD LI.MAKEMENU LI.SETUP IRIS.CREATE.ICON IRIS.DOMENU - IRIS.TRY LOADIRIS INSTALLIRIS LI.TRAVEL) - (VARS (IRIS.DIRECTORY '{ERIS}NEXT>) - IRIS.MENU.COMMANDS IRISFILES LI.SETUP.ALL LI.SETUP.CLEAR - LI.SETUP.DEBUG LI.SETUP.STANDARD LI.SHADE LOCATED.IRISFILES - LOCATED.IRISPATCHFILE (LI.MENU)) - (BITMAPS LI.DOIT LI.IRISLOGO IRIS.ICON IRIS.ICON.MASK) - (P (IRIS.CREATE.ICON) - (printout T - "Boot the IRIS, then choose 'create IRISview Panel' from the IRIS icon menu." - T)))) -(FILESLOAD FREEMENU) -(DEFINEQ - -(LI.CIRCLES - [LAMBDA (X) (* gbn " 5-Aug-85 15:25") - (for F to (OR X 100) do (IRIS.COLOR (RAND 0 7)) - (IRIS.CIRCF (RAND 0 1000) - (RAND 0 800) - (RAND 50 200))) - (IRIS.GFLUSH]) - -(LI.LOAD - [LAMBDA (item window button) (* ; "Edited 9-Jan-87 15:28 by gbn") - (printout PROMPTWINDOW T "[Loading Iris Files]") - (RESETLST [RESETSAVE (BITBLT NIL NIL NIL window NIL NIL NIL NIL 'TEXTURE 'INVERT LI.SHADE) - `(BITBLT NIL NIL NIL ,window NIL NIL NIL NIL TEXTURE INVERT ,LI.SHADE] - (* (QUOTE LIST) (QUOTE REDISPLAYW) - window) - (* ;; "This cruft seems to count on the fact that the only the buttons that are selected are in fm.getstate. (so the list looks like (file1 t file2 t), and not (file1 t file2 nil file3 t))") - - (FOR FILENAME IN (FM.GETSTATE WINDOW) WHEN (NEQ FILENAME T) - DO (SETQ FILENAME (PACKFILENAME 'DIRECTORY IRIS.DIRECTORY 'BODY FILENAME)) - (IF (FILENAMEFIELD FILENAME 'EXTENSION) - THEN (LOAD FILENAME) - ELSE (LOAD FILENAME 'PROP]) - -(LI.MAKEMENU - [LAMBDA NIL (* ; "Edited 9-Jan-87 15:30 by gbn") - (if (WINDOWP LI.MENU) - then (CLOSEW LI.MENU)) - (SETQ LI.MENU - (FREEMENU `(((LABEL Setup%: TYPE DISPLAY FONT (HELVETICA 10 BOLD)) - (LABEL CLEAR TYPE MOMENTARY SELECTEDFN LI.SETUP) - (LABEL Standard TYPE MOMENTARY SELECTEDFN LI.SETUP) - (LABEL Debug TYPE MOMENTARY SELECTEDFN LI.SETUP) - (LABEL ALL TYPE MOMENTARY SELECTEDFN LI.SETUP)) - ,@[LET* ([strLength (ADD1 (APPLY (FUNCTION MAX) - (MAPCAR IRISFILES (FUNCTION NCHARS] - (spaces (ALLOCSTRING strLength " "))) - (MAPCAR IRISFILES (FUNCTION (LAMBDA (FILENAME) - `((LABEL ,(SUBSTRING (CONCAT FILENAME ":" - spaces) - 1 strLength) TYPE DISPLAY - FONT (GACHA 8 BOLD)) - (LABEL ,COMPILE.EXT ID - ,(PACKFILENAME 'NAME FILENAME - 'EXTENSION COMPILE.EXT) TYPE - TOGGLE FONT (GACHA 8 STANDARD)) - (LABEL Source ID ,FILENAME TYPE TOGGLE FONT - (GACHA 8 STANDARD] - ((LABEL "Load --" TYPE DISPLAY FONT (HELVETICA 12 BOLD)) - (LABEL ,LI.IRISLOGO TYPE MOMENTARY SELECTEDFN LI.LOAD MESSAGE - "Loads the selected Iris files"))) "Iris Loadup Panel")) - (for setup in LI.SETUP.STANDARD when (CDR setup) - do (FM.CHANGESTATE (FM.GETITEM (CAR setup) - NIL LI.MENU) - (CDR setup) - LI.MENU)) - (printout PROMPTWINDOW T "Please put the LoadIris menu somewhere") - (MOVEW LI.MENU LASTMOUSEX LASTMOUSEY) - (MOVEW LI.MENU) - LI.MENU]) - -(LI.SETUP - [LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 24-Dec-86 14:29 by gbn") - (FOR SETUP IN [EVALV (PACK* 'LI.SETUP. (U-CASE (FM.ITEMPROP ITEM 'LABEL] - DO (* ; "THIS IS RIDICULOUS...") - (IF (EQ (FM.CHANGESTATE (FM.GETITEM (CAR SETUP) - NIL WINDOW) - (CDR SETUP) - WINDOW) - (CDR SETUP)) - THEN (FM.CHANGESTATE (FM.GETITEM (CAR SETUP) - NIL WINDOW) - (CDR SETUP) - WINDOW]) - -(IRIS.CREATE.ICON - [LAMBDA (position) (* ; "Edited 2-Feb-87 23:34 by gbn") - (if (NOT position) - then (printout PROMPTWINDOW T "Please position the Iris icon somewhere")) - (LET ((window (ICONW IRIS.ICON IRIS.ICON.MASK position))) - (WINDOWPROP window 'SHRINKFN 'DON'T) - (WINDOWPROP window 'BUTTONEVENTFN 'IRIS.DOMENU]) - -(IRIS.DOMENU - [LAMBDA (window) (* LeL, " 9-Sep-85 01:36") - (if (NOT (WINDOWPROP window 'MENU)) - then (WINDOWPROP window 'MENU (create MENU - ITEMS _ IRIS.MENU.COMMANDS))) - (MENU (WINDOWPROP window 'MENU]) - -(IRIS.TRY - [LAMBDA NIL (* LeL, " 4-Sep-85 15:42") - (* opens a connection and runs two - dumb demos) - (OPEN.IRISCONN) (* this defaults to the value of - IRISNSHOSTNUMBER) - (IRIS.GINIT) - (* must be executed before the iris is ready to accept graphic commands) - (for I to 5 do (LI.CIRCLES) - (LI.TRAVEL]) - -(LOADIRIS - [LAMBDA (options) (* LeL, " 3-Sep-85 11:55") - (* * loads the files necessary to open a connection to the iris and use the - graphics library) - [if (FMEMB %'DCOMS options) - then (MAPC LOCATED.IRISFILES (FUNCTION (LAMBDA (file) - (LOAD? (PACK* file %'.DCOM] - [if (FMEMB %'SOURCES options) - then (MAPC LOCATED.IRISFILES (FUNCTION (LAMBDA (file) - (LOAD? file %'PROP] - (if (FMEMB %'PATCHES options) - then (LOAD LOCATED.IRISPATCHFILE]) - -(INSTALLIRIS - [LAMBDA (NODCOMS NOSOURCES) (* BDV "19-Jul-85 19:08") - (* * moves the iris files from my working dir to {eris}current>) - (COPYFILES IRISFILES %'{ERIS}CURRENT>) - (COPYFILES (for F in IRISFILES collect (PACK* F ".DCOM")) - %'{ERIS}CURRENT>) - (COPYFILES %'IRISIO.DCOM %'{ERIS}CURRENT>]) - -(LI.TRAVEL - [LAMBDA (COLOR) (* gbn " 5-Aug-85 21:33") - (* dumb demo to try double buffering) - (IRIS.DOUBLEBUFFER) - (IRIS.GCONFIG) - (if (NOT COLOR) - then (SETQ COLOR (RAND 0 6))) - (for I from 5 to 1000 by 10 do (IRIS.COLOR 8) - (IRIS.CLEAR) - (IRIS.COLOR COLOR) - (IRIS.CIRCF I (IQUOTIENT I 2) - (IQUOTIENT I 5)) - (IRIS.SWAPBUFFERS)) - (IRIS.GFLUSH) - (IRIS.SINGLEBUFFER) - (IRIS.GCONFIG]) -) - -(RPAQQ IRIS.DIRECTORY {ERIS}NEXT>) - -(RPAQQ IRIS.MENU.COMMANDS (("Clear IRIS" (CLEARIRIS)) - ("Open IRIS stream" (if (MOUSECONFIRM - "New stream? (lose fonts, etc.) Left to confirm" - ) - then - (SETQ IRISCONN) - (OPENIRISSTREAM))) - ("Create IRISview panel" (IV.INIT)) - ("Enable bootserver" (if (GETD 'IRISBOOTSERVER) - then - (IRISBOOTSERVER T) - else - (PROMPTPRINT - "IRISNET must be loaded to use the boot server" - )) - "Allows the Lisp Machine to boot the IRIS") - ("Disable bootserver" (if (GETD 'IRISBOOTSERVER) - then - (IRISBOOTSERVER NIL) - else - (PROMPTPRINT - "IRISNET must be loaded to use the boot server" - )) - "Prevents the Lisp Machine from booting the IRIS"))) - -(RPAQQ IRISFILES (IRISSTREAM IRISNET IRISVIEW)) - -(RPAQQ LI.SETUP.ALL ((IRISSTREAM . T) - (IRISSTREAM.LCOM . T) - (IRISNET . T) - (IRISNET.LCOM . T) - (IRISVIEW.LCOM T) - (IRISVIEW T))) - -(RPAQQ LI.SETUP.CLEAR ((IRISSTREAM) - (IRISSTREAM.LCOM) - (IRISNET) - (IRISNET.LCOM) - (IRISVIEW) - (IRISVIEW.LCOM))) - -(RPAQQ LI.SETUP.DEBUG ((IRISSTREAM . T) - (IRISSTREAM.LCOM . T) - (IRISVIEW . T) - (IRISVIEW.LCOM . T) - (IRISNET.LCOM . T))) - -(RPAQQ LI.SETUP.STANDARD ((IRISSTREAM.LCOM . T) - (IRISNET.LCOM . T) - (IRISVIEW.LCOM . T))) - -(RPAQQ LI.SHADE 18432) - -(RPAQQ LOCATED.IRISFILES ({QV}IRIS>GL2>IRISLIB {ERIS}IRISSTREAM {ERIS}IRISNET - {QV}IRIS>GL2>IRISIO {ERIS}IRISDIGDEMO)) - -(RPAQQ LOCATED.IRISPATCHFILE {QV}IRIS>GL2>IRISPATCH) - -(RPAQQ LI.MENU NIL) - -(RPAQQ LI.DOIT #*(20 12)@@@@@@@@GOOOL@@@D@@@D@@@EHIGD@@@EEEBD@@@EEEBD@@@EEEBD@@@EHIBD@@@D@@@D@@@GOOOL@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ LI.IRISLOGO #*(16 16)@NG@CJELFBDFCHAL@NG@NCLGKHAMHNGAHBDAKJEMNBDGHJEACJELFBDFCJEL@NG@) - -(RPAQQ IRIS.ICON #*(75 82)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@N@@@@@@@@@@@@@@@@COAOH@@@@@@@@@@@@@@@OOAON@@@@@@@@@@@@@@COOAOOH@@@@@@@@@@@@@OOOAOON@@@@@@@@@@@@COOOAOOOH@@@@@@@@@@@OOLOANGON@@@@@@@@@@COO@OANAOOH@@@@@@@@@OOL@OAN@GON@@@@@@@@COO@@OAN@AOOH@@@@@@@OOL@@OAN@@GON@@@@@@COO@@@OAN@@AOOH@@@@@OOL@@@OAN@@@GON@@@@COO@@@@OAN@@@AOOH@@@OOL@@@@OAN@@@@GON@@AOO@@@@@OAN@@@@AOO@@COL@@@@@OAN@@@@@GOH@COH@@@@@OAN@@@@@COH@CON@@@@@OAN@@@@@OOH@AOOH@@@@OAN@@@@COO@@@OON@@@@OAN@@@@OON@@@COOH@@@OAN@@@COOH@@@@OON@@@OAN@@@OON@@@A@COOH@@OAN@@COOHA@@CL@OON@@OAN@@OON@GH@CO@COOH@OAN@COOHAOH@COL@OON@OAN@OON@GOH@COO@COOHOANCOOHAOOH@COOL@OONCAHOON@GOOH@COOO@COOH@COOHAOOOH@CLOOL@OON@OON@GONGH@CLCOO@COOKOOHAOOHGH@CL@OOL@OOOON@GON@GH@CL@COO@COOOHAOOH@GH@CL@@OOL@OON@GON@@GH@CL@@COO@COHAOOH@@GH@CL@@@OOL@N@GON@@@GH@CL@@@COO@@AOOH@@@GH@CL@@@@OOL@GON@@@@GH@CL@@@@CON@OOH@@@@GH@CL@@@@@OOAON@@@@@GH@CL@@@@BCOAOHH@@@@GH@CL@@@@OHOANCN@@@@GH@CL@@@COLOANGOH@@@GH@CL@@@OOLOANGON@@@GH@CL@@COO@OANAOOH@@GH@CL@@OOL@OAN@GON@@GH@CL@COO@BOANHAOOH@GH@CL@OOL@NOANN@GON@GH@CLCOO@CNOANOHAOOHGH@CLOOL@ONOANON@GONGH@COOO@CONOANOOHAOOOH@COOL@OOLOANGON@GOOH@COO@COO@OANAOOHAOOH@COL@OOL@OAN@GON@GOH@CO@COO@@OAN@AOOHAOH@CL@OOL@@OAN@@GON@GH@A@COO@@@OAN@@AOOHA@@@@OOL@@@OAN@@@GON@@@@COO@@@@OAN@@@AOOH@@@GOL@@@@OAN@@@@GOL@@@OO@@@@@OAN@@@@AON@@@OL@@@@@OAN@@@@@GN@@@OO@@@@@OAN@@@@AON@@@OOL@@@@OAN@@@@GOL@@@COO@@@@OAN@@@AOOH@@@@OOL@@@OAN@@@GON@@@@@COO@@@OAN@@AOOH@@@@@@OOL@@OAN@@GON@@@@@@@COO@@OAN@AOOH@@@@@@@@OOL@OAN@GON@@@@@@@@@COO@OANAOOH@@@@@@@@@@OOLOANGON@@@@@@@@@@@COOOAOOOH@@@@@@@@@@@@OOOAOON@@@@@@@@@@@@@COOAOOH@@@@@@@@@@@@@@OOAON@@@@@@@@@@@@@@@CN@OH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ -) - -(RPAQQ IRIS.ICON.MASK #*(75 82)@@@@@@@COKOH@@@@@@@@@@@@@@@OOOON@@@@@@@@@@@@@@COOOOOH@@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@OOOOOOOON@@@@@@@@@@COOOOOOOOOH@@@@@@@@@OOOOOOOOOON@@@@@@@@COOOOOOOOOOOH@@@@@@@OOOOOOOOOOOON@@@@@@COOOOOOOOOOOOOH@@@@@OOOOOOOOOOOOOON@@@@COOOOOCOOOIOOOOOH@@@OOOOOLCOOOHGOOOON@@COOOOO@COOOHAOOOOOH@GOOOOL@COOOH@GOOOOL@OOOOO@@COOOH@AOOOON@OOOOL@@COOOH@@GOOON@OOOO@@@COOOH@@AOOON@OOON@@@COOOH@@@GOON@OOOOH@@COOOH@@AOOON@OOOON@@COOOH@@GOOON@OOOOOH@COOOH@AOOOON@GOOOON@COOOH@OOOOOL@OOOOOOHCOOOHCOOOOON@OOOOOONCOOOHOOOOOON@OOOOOOOKOOOKOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOCOOOOOOOOOOOOOION@OO@OOOOOOOOOOOONAON@OO@COOOOOOOOOOOHAON@OO@@OOOOOOOOOON@AON@OO@@COOOOOOOOOH@AON@OO@@@OOOOOOOON@@AON@OO@@@COOOOOOOH@@AON@OO@@@OOOOOOOON@@AON@OO@@COOOOOOOOOH@AON@OO@@OOOOOOOOOON@AON@OO@COOOOOOOOOOOHAON@OO@OOOOOOOOOOOONAON@OOCOOOOOOOOOOOOOION@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOCOOOIOOOOOON@OOOOOOLCOOOHGOOOOON@OOOOOO@COOOHAOOOOON@GOOOOL@COOOH@GOOOOL@COOOO@@COOOH@AOOOOH@COOOL@@COOOH@@GOOOH@COOO@@@COOOH@@AOOOH@COOOL@@COOOH@@GOOOH@COOOO@@COOOH@AOOOOH@COOOOL@COOOH@GOOOOH@AOOOOO@COOOHAOOOOO@@@OOOOOLCOOOHGOOOON@@@COOOOOCOOOIOOOOOH@@@@OOOOOOOOOOOOOON@@@@@COOOOOOOOOOOOOH@@@@@@OOOOOOOOOOOON@@@@@@@COOOOOOOOOOOH@@@@@@@@OOOOOOOOOON@@@@@@@@@COOOOOOOOOH@@@@@@@@@@OOOOOOOON@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@@COOOOOH@@@@@@@@@@@@@@OOKON@@@@@@@@ -) -(IRIS.CREATE.ICON) -(printout T "Boot the IRIS, then choose 'create IRISview Panel' from the IRIS icon menu." T) -(PUTPROPS LOADIRIS COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1223 9129 (LI.CIRCLES 1233 . 1608) (LI.LOAD 1610 . 2687) (LI.MAKEMENU 2689 . 5066) ( -LI.SETUP 5068 . 5825) (IRIS.CREATE.ICON 5827 . 6230) (IRIS.DOMENU 6232 . 6559) (IRIS.TRY 6561 . 7221) -(LOADIRIS 7223 . 7894) (INSTALLIRIS 7896 . 8300) (LI.TRAVEL 8302 . 9127))))) -STOP diff --git a/obsolete/lispusers/LUPINE b/obsolete/lispusers/LUPINE deleted file mode 100644 index 866cb921..00000000 --- a/obsolete/lispusers/LUPINE +++ /dev/null @@ -1,1485 +0,0 @@ -(FILECREATED "30-Jun-86 16:38:25" {PHYLUM}RPC>LUPINE.;1 57734 - - changes to: (FNS \MakeUnmarshalRecord) - - previous date: " 1-Aug-85 12:16:27" {PHYLUM}KOTO>LISPUSERS>LUPINE.;1) - - -(* Copyright (c) 1984, 1985, 1986 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT LUPINECOMS) - -(RPAQQ LUPINECOMS [(DECLARE: DONTCOPY (RECORDS ArgSpec Fragment FunctionSpec FieldSpec LupineType - RecordLayout TypeSpec)) - (* Basic stub construction) - (FNS Lupine \ServerComs \MakeUnmarshal \MakeUnmarshal1 \MakeUnmarshalRecord - \FixedFetch \MakeArgsUnmarshal \ClientComs \MakeMarshal \MakeMarshal1 - \MakeMarshalRecord \FixedStore \MakeArgsMarshal) - (* Checking of declarations) - (FNS \CheckSpec \CheckType \CheckType1 \CheckRecordDecl) - (* Type table construction) - (FNS \DeclareTypes \Allocate \AllocateRecord) - (* Utilities) - (FNS \TypeName \BaseType \TypeLayout \TypeSize \LupineNotFixed \StaticsFirst - \IsStatic) - (VARS \LupineGetFns \LupinePutFns \LupinePrimativeTypes \LupineInitialTypeTable - \LupineNumberTypes \LupineNotFixedTypes \LupineDummyTypes \LupineStatics - \LupineTypesWithParm) - (GLOBALVARS \LupineGetFns \LupinePutFns \LupineStatics \LupineTypesWithParm - \LupinePrimativeTypes \LupineDummyTypes \LupineNotFixedTypes - \LupineNumberTypes \LupineInitialTypeTable) - (DECLARE: DONTCOPY (CONSTANTS (\FirstLupineUserCall 4) - (\FirstLupineSignal 4]) -(DECLARE: DONTCOPY -[DECLARE: EVAL@COMPILE - -(RECORD ArgSpec (argName argType)) - -(RECORD Fragment (fixed . notFixed)) - -(RECORD FunctionSpec (fn . specs)) - -(RECORD FieldSpec (fieldName fieldType)) - -(RECORD LupineType (typeName . typeParm)) - -(RECORD RecordLayout (need . fields)) - -(RECORD TypeSpec (type typeType definedStubs typeSize . typeBits)) -] -) - - - -(* Basic stub construction) - -(DEFINEQ - -(Lupine - [LAMBDA (packageName functionSpecList signalSpecList typeList lupineTypeString noServer noClient) - (* ht: "31-Jul-85 11:47") - (if (NOT (LITATOM packageName)) - then (ERROR "package name must be an atom" packageName)) - (if (AND functionSpecList (NLISTP functionSpecList)) - then (ERROR "function spec must be a list" functionSpecList)) - (if (AND signalSpecList (NLISTP signalSpecList)) - then (ERROR "signal spec must be a list" signalSpecList)) - (if (AND typeList (NLISTP typeList)) - then (ERROR "type declarations must be a list" typeList)) - (if (NOT lupineTypeString) - then (printout T "type string defaulted to " [lupineTypeString_(MKSTRING - (PACK (LIST packageName (GDATE) - (ETHERHOSTNUMBER] - T)) - (if (NOT (STRINGP lupineTypeString)) - then lupineTypeString_(MKSTRING lupineTypeString)) - (RESETLST (RESETSAVE DFNFLG T) - (LET ((typeTable (\DeclareTypes typeList)) - sName cName) - (for s in functionSpecList do (\CheckSpec s typeTable)) - (for s in signalSpecList do (\CheckSpec s typeTable T)) - [if (NOT noServer) - then (SET sName_(PACK (LIST (U-CASE packageName) - 'SERVERCOMS)) - (\ServerComs packageName functionSpecList signalSpecList typeTable - lupineTypeString)) - (ADDFILE (PACK (LIST (U-CASE packageName) - 'SERVER] - [if (NOT noClient) - then (SET cName_(PACK (LIST (U-CASE packageName) - 'CLIENTCOMS)) - (\ClientComs packageName functionSpecList signalSpecList typeTable - lupineTypeString)) - (ADDFILE (PACK (LIST (U-CASE packageName) - 'CLIENT] - (CONS sName cName]) - -(\ServerComs - [LAMBDA ($packageName$ functionSpecList signalSpecList typeTable lupineTypeString) - (* ht: " 1-Aug-85 12:13") - (DECLARE (SPECVARS $packageName$)) - (LET ($fns$ dfn iName selTerms $rNames$ catchTerms labelTerms movds hideFn loads) - (DECLARE (SPECVARS $fns$ $rNames$)) - - (* * the NCONC is because some stuff gets pushed onto $fns$ underneath here) - - - $fns$_(NCONC (bind (i _ \FirstLupineUserCall) - argNames nameMap rec rfl fn argSets end result for spec in functionSpecList - unless (spec:fn= '*) - collect [fn_(PACK (LIST spec:fn 'ServerStub] - [argNames_(for aSpec in spec:specs as i from 1 - until (if (U-CASE aSpec:argName)= 'RETURNS - then result_aSpec) - collect (CDAR (push nameMap (CONS aSpec:argName - (PACK* 'l..arg - i] - [argSets_(for aSpec in (\StaticsFirst spec:specs typeTable) - collect (LIST 'SETQ - (CDR (ASSOC aSpec:argName nameMap)) - (\MakeUnmarshal aSpec:argType spec:fn - aSpec:argName typeTable] - (end_(if result - then (\MakeArgsMarshal result:argType fn 'RESULT - 'l..result - typeTable))) - [APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, fn (l..cPup l..conv) - (* Lupine generated stub) - (DECLARE (SPECVARS l..cPup l..conv)) - (PROG (l..result ,. argNames) - ,. - argSets - (SETQ l..result (, (fetch fn of spec) - ,. argNames)) - (\StartReturn l..cPup) - ,. - end (RETURN l..cPup] - [selTerms_(NCONC1 selTerms (BQUOTE (, i (, fn l..pup l..conv] - (push movds (CONS spec:fn (CONS (PACK* 'Hidden. - spec:fn) - fn))) - (add i 1) - fn) - $fns$) - dfn_(PACK (LIST $packageName$ 'ServerDispatch)) - (if signalSpecList - then (bind (j _ \FirstLupineSignal) - cName specs resultSpec margs umres for sSpec in signalSpecList - unless (sSpec:fn= '*) - do (specs_sSpec:specs) - (margs_(if (U-CASE specs:1:argName)= 'ARGS - then (\MakeArgsMarshal (pop specs):argType sSpec:fn 'SIGARGS - 'arg - typeTable))) - (if (U-CASE specs:1:argName)= 'RETURNS - then umres_(\MakeArgsUnmarshal specs:1:argType sSpec:fn 'RESULT - typeTable)) - [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, [SETQ cName - (PACK (LIST 'Catch - (fetch fn of sSpec] - (arg l..conv) - (* Lupine generated signal catcher) - (DECLARE (USEDFREE l..cPup)) - (\StartSignal l..cPup) - (\AddPupWord l..cPup , j) - ., margs (SETQ l..cPup - (\Call l..cPup NIL l..conv)) - , umres] - [catchTerms_(NCONC catchTerms (APPEND (BQUOTE (, (fetch fn of sSpec)=> - (sresume (, cName arg l..conv] - (add j 1))) - - (* * the (, (QUOTE enable)) is to keep the form from being prettyprinted) - - - [APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, dfn (l..pup request l..conv) (* Lupine generated dispatcher) - (, 'enable - ., catchTerms (SELECTQ request ., selTerms (SHOULDNT)) - ., labelTerms] - (push $fns$ dfn) - iName_(PACK (LIST $packageName$ 'ServerInterface)) - (if (NOT (BOUNDP iName)) - then (SET iName NIL)) - [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, (PACK (LIST 'Unexport - $packageName$)) - NIL (* Lupine generated interface) - [UnexportInterface (OR , iName (ERROR "not exported" - (QUOTE , - $packageName$] - (SETQ , iName NIL] - [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, (PACK (LIST 'Export - $packageName$)) - (type instance version user password) - (* Lupine generated interface) - (if , iName - then (ERROR "Already exported" (QUOTE , $packageName$))) - (SETQ , iName (ExportInterface user password - (OR type , lupineTypeString) - instance version - (FUNCTION , dfn] - [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, [SETQ hideFn (PACK (LIST 'Hide - $packageName$ - 'ServerMovds] - NIL (* Lupine generated utility) - (for p in (QUOTE , movds) - do (PUTD (CADR p) - (GETD (CAR p))) - (PUTD (CAR p)) - (CHANGENAME (CDDR p) - (CAR p) - (CADR p] - [LET [(files (NCONC1 (bind wh res for r in $rNames$ - when (if wh_(WHEREIS r 'RECORDS) - else (printout T T "Note - the record " r - " is not on any known file" - T)) - do (pushnew res wh:1) finally (RETURN res)) - 'SIGNAL] - loads_(LIST (BQUOTE (DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (FILES (LOADCOMP) - ., files] - (BQUOTE ( (* Created by Lupine , (GDATE)) - (FNS ,. $fns$) - (VARS (, iName)) - (GLOBALVARS , iName) - ., loads (DECLARE: EVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES (SYSLOAD) - RPC)) - (P (COND - ((EQ 'Y - (ASKUSER 15 'N - "Hide server fns (must have been already loaded)? ")) - (, hideFn]) - -(\MakeUnmarshal - [LAMBDA (type fn name typeTable pupName) (* ht: " 1-Aug-85 08:57") - (if type - then (if (NOT pupName) - then pupName_ 'l..cPup) - (LET (fragment) - fragment_(\MakeUnmarshal1 type fn name typeTable 0 16 pupName) - (if NOT (fragment:notFixed) - then fragment:fixed - else (BQUOTE (LET ((l..datum , (fetch fixed of fragment))) - ., - (fetch notFixed of fragment) - l..datum]) - -(\MakeUnmarshal1 - [LAMBDA (type fn name typeTable whereAreWe size pupName) (* ht: " 1-Aug-85 09:09") - (LET ((typeName (\TypeName type)) - (typeParm (if (LISTP type) - then type:typeParm)) - afn typeSpec) - (SELECTQ typeName - ((RECORD SEQRECORD) - (SHOULDNT)) - [LIST (create Fragment - fixed _(BQUOTE (PROGN (SETQ , pupName (\CheckPupExhausted , pupName 2)) - (for l..i from 1 to (\GetArgDblWord , pupName - l..conv) - collect , (\MakeUnmarshal (CAR typeParm) - fn name typeTable - pupName] - [REF (* no-op except for SEQRECORDs) - (LET ((trueType (\BaseType typeParm:1 typeTable)) - typeSpec) - (if (AND (LISTP trueType) - trueType:typeName= - 'SEQRECORD) - then - - (* * have to back up one) - - - (\MakeUnmarshalRecord (OR typeSpec_(for tte in typeTable thereis - - tte:typeType=trueType) - (SHOULDNT)) - fn name typeTable whereAreWe - (if size=16 - then typeSpec:typeSize - else (SHOULDNT)) - pupName) - else (create Fragment - fixed _(LET [(nilCheck (BQUOTE (\GetArgBool , pupName l..conv] - [if pupName= 'l..pup - then nilCheck_(BQUOTE (PROG1 , nilCheck (SETQ l..pup - l..cPup] - (BQUOTE (if , nilCheck - then NIL - else , (\MakeUnmarshal (CAR typeParm) - fn name typeTable pupName] - [BITS (* Just a bit special) - (create Fragment - fixed _(if (ILESSP size 16) - then (\FixedFetch size type whereAreWe fn name typeTable) - elseif whereAreWe~=0 - then (HELP "bad layout") - elseif (ILEQ typeParm:1 16) - then - - (* * note that even if we get here with a BITS record of <16 size, we just get a whole word) - - - (BQUOTE (\GetArgWord , pupName l..conv)) - elseif typeParm:1=32 - then (* closest we get to LONG CARDINAL) - (BQUOTE (\GetArgDblWord , pupName l..conv)) - else (SHOULDNT] - (if (FMEMB typeName \LupinePrimativeTypes) - then (if (ILESSP size 16) - then (create Fragment - fixed _(\FixedFetch size type whereAreWe fn name typeTable)) - elseif whereAreWe~=0 - then (HELP "bad layout") - elseif afn_(CDR (ASSOC typeName \LupineGetFns)) - then - - (* * note that even if we get here with a BITS record of <16 size, we just get a whole word courtesy of the GetFns  - table entry) - - - [create Fragment - fixed _(LET [(sr (BQUOTE (, afn , pupName ., - (if typeParm - then (LIST (KWOTE typeParm))) - l..conv] - (if pupName= 'l..cPup - then sr - else (BQUOTE (PROG1 , sr (SETQ l..pup l..cPup] - else (SHOULDNT)) - elseif typeSpec_(ASSOC typeName typeTable) - then (if typeSpec:typeType:type= 'RECORD - then (\MakeUnmarshalRecord typeSpec fn name typeTable whereAreWe - (if (AND size=16 (IGREATERP typeSpec:typeSize - 16)) - then typeSpec:typeSize - else size) - pupName) - else (\MakeUnmarshal1 typeSpec:typeType fn name typeTable whereAreWe size - pupName)) - else (ERROR "Invalid spec" (LIST fn name type]) - -(\MakeUnmarshalRecord - [LAMBDA (spec fn name typeTable startBit bitWidth pupName) - (* smL "30-Jun-86 16:17") - (LET ((fnName (PACK* (QUOTE Unmarshal) - $packageName$ - (fetch type of spec) - (QUOTE %#) - startBit - (QUOTE %#) - bitWidth)) - (bits (fetch typeBits of spec)) - (seq? (EQ (fetch typeName of (fetch typeType of spec)) - (QUOTE SEQRECORD))) - fetches createExpr indirects umc notFixed someNot res seqSpec seqEltFetch seqSubSpec - seqStatic? leftOver) - [if (NOT (FMEMB fnName (fetch definedStubs of spec))) - then (push $rNames$ (fetch type of spec)) - (if (ILESSP (fetch typeSize of spec) - bitWidth) - then (SETQ bits (CONS (IPLUS (CAR bits) - (DIFFERENCE bitWidth - (fetch typeSize - of spec))) - (CDR bits))) - elseif (AND (IGREATERP (fetch typeSize of spec) - bitWidth) - (NOT (ZEROP startBit))) - then (HELP "bad layout")) - [SETQ fetches - (bind (whereAreWe _ startBit) - (nFixed _ 0) - last for field in (fetch typeParm of (fetch typeType - of spec)) - as size in bits - join - (if (AND (LISTP (fetch fieldType of field)) - (EQ (fetch typeName of (fetch fieldType of field)) - (QUOTE SEQUENCE))) - then (if seq? - then (SETQ seqSpec field) - [SETQ seqSubSpec - (CAR (fetch typeParm - of (fetch fieldType of field] - - (* * * This should be a call to \MakeUnmarshal1, but because of a CEDAR Lupine bug, is not  - (see below for more discussion) - - If CEDAR is ever fixed, the call should be as follows: (SETQ seqEltFetch (\MakeUnmarshal1 seqSubSpec fn name  - typeTable whereAreWe size (QUOTE l..pup)))) - - - [SETQ seqEltFetch (\MakeUnmarshal - seqSubSpec fn name typeTable - (if (SETQ seqStatic? (\IsStatic seqSubSpec - typeTable)) - then (QUOTE l..pup) - else (QUOTE l..cPup] - else (SHOULDNT)) - NIL - elseif (\LupineNotFixed field typeTable) - then (add nFixed 1) - (SETQ someNot T) - NIL - else (SETQ umc (\MakeUnmarshal1 (fetch fieldType of field) - fn name typeTable whereAreWe size - (QUOTE l..pup))) - [if (fetch notFixed of umc) - then - (SETQ notFixed - (NCONC1 notFixed - (BQUOTE - (LET ((l..datum (fetch (, (fetch type - of spec) - , - (fetch fieldName - of field)) - of l..datum))) - ., (fetch notFixed of umc] - (SETQ umc (fetch fixed of umc)) - (SETQ whereAreWe (LOGAND 15 (IPLUS whereAreWe size))) - (if (NOT (ZEROP nFixed)) - then (SETQ umc (BQUOTE (PROGN (SETQ l..pup - (\SkipWordsIn - l..pup , - (LLSH nFixed 1))) - , umc))) - (SETQ nFixed 0)) - (SETQ last (LIST (fetch fieldName of field) - (QUOTE _) - umc))) - finally (if (NOT (ZEROP nFixed)) - then (SETQ leftOver (BQUOTE (SETQ l..pup - (\SkipWordsIn - l..pup , - (LLSH nFixed 1] - (SETQ createExpr (BQUOTE (create , (fetch type of spec) - ., fetches))) - [if leftOver - then (SETQ createExpr (BQUOTE (PROG1 , createExpr , leftOver] - (if someNot - then [SETQ indirects (for field in (fetch typeParm - of (fetch typeType - of spec)) - when (\LupineNotFixed field typeTable) - collect (SETQ umc - (\MakeUnmarshal (fetch fieldType - of field) - fn name typeTable - (QUOTE l..cPup))) - (BQUOTE (replace - (, (fetch type - of spec) - , - (fetch fieldName - of field)) - of l..datum - with , umc] - (SETQ notFixed (NCONC notFixed indirects))) - (SETQ createExpr - (if seq? - then [LET (prelim term f nf) - - (* * the code in this comment is the way this **should** work, with only the non-statics following after, but in  - fact as CEDAR Lupine stands if a sequence's element type has any non-static parts, the WHOLE element gets repeated. - There is a further patch associated with this higher up in this function. If this ever gets fixed, replace the if  - statement which follows this comment with this code: (if (fetch notFixed of seqEltFetch) then  - (SETQ f (fetch fixed of seqEltFetch)) (SETQ nf (fetch notFixed of seqEltFetch)) elseif (\LupineNotFixed  - (fetch fieldType of seqSpec) typeTable) then (SETQ prelim (BQUOTE (first (\SkipWordsIn l..pup  - (LLSH size 1))))) (SETQ nf (fetch fixed of seqEltFetch)) else (SETQ f (fetch fixed of seqEltFetch)))) - - - (if seqStatic? - then (SETQ f seqEltFetch) - else [SETQ prelim - (BQUOTE (first - (\SkipWordsIn - l..pup - (ITIMES , (LRSH (\TypeSize - seqSubSpec - typeTable) - 4) - l..size] - (SETQ nf seqEltFetch)) - [if nf - then [SETQ term - (if f - then (BQUOTE (LET ((l..datum (CAR l..p))) - ., - nf)) - else (BQUOTE (RPLACA l..p , nf] - (SETQ notFixed - (NCONC1 - notFixed - (BQUOTE (for l..p - on (fetch (, (fetch type - of spec) - , - (fetch fieldName - of seqSpec)) - of l..datum) - do , term] - (BQUOTE ((SETQ l..pup (\CheckPupExhausted l..pup 3)) - (if (\GetArgBool l..pup l..conv) - then NIL - else (LET ((l..size (\GetArgDblWord l..pup - l..conv))) - (bind (l..result _ , createExpr) - ., prelim for l..i - from 1 to l..size - collect , f - finally - (replace (, (fetch type - of spec) - , - (fetch fieldName - of seqSpec)) - of l..result with $$VAL) - (RETURN l..result] - else (LIST createExpr))) - [if (AND seq? notFixed) - then (SETQ notFixed (LIST (BQUOTE (if l..datum - then ., notFixed] - (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, fnName (l..pup l..conv) - (* Lupine generated stub) - ., createExpr))) - - (* * must record the notFixed generated here so they get used if the function gets re-used) - - - (PUT fnName (QUOTE LupineNotFixed) - notFixed) - (push $fns$ fnName) - (push (fetch definedStubs of spec) - fnName) - else (SETQ notFixed (APPEND (GETP fnName (QUOTE LupineNotFixed] - (SETQ res (BQUOTE (, fnName , pupName l..conv))) - [if pupName=(QUOTE l..pup) - then - - (* * horrible kludge as our function may have reset l..cPup but our caller won't see that) - - - (SETQ res (LIST (QUOTE PROG1) - res - (QUOTE (SETQ l..pup l..cPup] - (create Fragment - fixed _ res - notFixed _ notFixed]) - -(\FixedFetch - [LAMBDA (size type whereAreWe fn name typeTable) (* ht: " 1-Aug-85 08:54") - (LET ((typeName (\TypeName type)) - (typeParm (if (LISTP type) - then type:typeParm)) - ff bitNum form) - (SELECTQ typeName - (RECORD (SHOULDNT)) - ((BOOLEAN BITS ENUMERATION) - - (* * compute the field descriptor) - - - bitNum_ - (IPLUS (LLSH whereAreWe 4) - size-1) - - (* * make the call to FETCHFIELD) - - - ff_ - (BQUOTE (FETCHFIELD '(NIL 0 (BITS ., bitNum)) - (\CurrentPupBase l..pup))) - form_ - (SELECTQ typeName - (BITS ff) - [ENUMERATION (BQUOTE (CAR (NTH (QUOTE , typeParm) - (ADD1 , ff] - [BOOLEAN (BQUOTE (NOT (ZEROP , ff] - (SHOULDNT)) - (if (ZEROP whereAreWe) - then - - (* * need to check there is room in the l..pup) - - - (BQUOTE (PROGN (SETQ l..pup (\CheckPupExhausted l..pup 1)) - , form)) - elseif (IPLUS whereAreWe size)=16 - then - - (* * must advance the counter) - - - (BQUOTE (PROG1 , form (\IncrDataOffset l..pup 1))) - else form)) - (SHOULDNT]) - -(\MakeArgsUnmarshal - [LAMBDA (spec fn multTypeName typeTable) (* ht: " 1-Aug-85 08:51") - (LET (resultSpec) - (if (AND (LITATOM spec) - resultSpec_(\BaseType spec typeTable) - (LISTP resultSpec) - resultSpec:typeName=multTypeName) - then (* create the record) - (push $rNames$ spec) - [NCONC (LIST 'create - spec) - (for rSpec in (\StaticsFirst resultSpec:typeParm typeTable) - join (BQUOTE (, (fetch fieldName of rSpec)_ , (\MakeUnmarshal (fetch - fieldType - of rSpec) - fn - (fetch - fieldName - of rSpec) - typeTable] - else (\MakeUnmarshal spec fn 'l..result - typeTable]) - -(\ClientComs - [LAMBDA ($packageName$ functionSpecList signalSpecList typeTable lupineTypeString) - (* ht: " 1-Aug-85 09:39") - (DECLARE (SPECVARS $packageName$)) - (LET ($fns$ dfn selTerms iName cName typeSels $rNames$ sDisp sigTerms movds movdFn result loads) - (DECLARE (SPECVARS $fns$ $rNames$)) - iName_(PACK (LIST $packageName$ 'ClientInterface)) - sDisp_(PACK (LIST 'Dispatch - $packageName$ - 'Signals)) - - (* * the NCONC is because some stuff gets pushed onto $fns$ underneath here) - - - $fns$_(NCONC (bind (i _ \FirstLupineUserCall) - argNames rec rfl fn argPuts end stubFn for spec in functionSpecList - unless spec:fn= '* - collect (fn_spec:fn) - (stubFn_(PACK (LIST 'RPCClientStub. - fn))) - (argPuts_(for aSpec in (\StaticsFirst spec:specs typeTable) - join (\MakeMarshal aSpec:argType aSpec:argName fn - aSpec:argName typeTable))) - [argNames_(NCONC (for aSpec in spec:specs until (if (U-CASE - aSpec:argName)= - 'RETURNS - then result_aSpec) - collect aSpec:argName) - (LIST 'l..interfaceArg - 'l..conv] - (end_(if result - then (\MakeArgsUnmarshal result:argType fn 'RESULT - typeTable))) - [APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, stubFn , argNames - (* Lupine generated stub) - (PROG [l..cPup (l..interface (OR l..interfaceArg - (CAR , iName] - (DECLARE (SPECVARS l..cPup)) - (SETQ l..cPup (\StartCall (CAR l..interface) - (CDR l..interface) - l..conv)) - (\AddPupWord l..cPup , i l..conv) - ,. - argPuts - (SETQ l..cPup (\Call l..cPup - (FUNCTION , sDisp) - l..conv)) - (RETURN (PROG1 , end (\RELEASE.PUP l..cPup] - (push movds (CONS stubFn fn)) - (add i 1) - stubFn) - $fns$) - sigTerms_(bind (j _ \FirstLupineSignal) - mres umargs specs for sSpec in signalSpecList unless sSpec:fn= '* - collect (specs_sSpec:specs) - (umargs_(if (U-CASE specs:1:argName)= 'ARGS - then (\MakeArgsUnmarshal (pop specs):argType sSpec:fn - 'SIGARGS - typeTable))) - (if (U-CASE specs:1:argName)= 'RETURNS - then mres_(\MakeArgsMarshal specs:1:argType sSpec:fn 'RESULT - 'l..result - typeTable)) - (PROG1 (BQUOTE (, j (PROG (l..result) - (SETQ l..result - (Signal (QUOTE , (fetch fn of sSpec)) - , umargs)) - (\StartReturn l..cPup) - ., - mres))) - (add j 1))) - (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, sDisp (l..cPup l..conv) (* Lupine generated dispatcher) - (DECLARE (SPECVARS l..cPup l..conv)) - (SELECTQ (\GetArgWord l..cPup l..conv) - ., sigTerms (SHOULDNT)) - l..cPup))) - (push $fns$ sDisp) - (if (NOT (BOUNDP iName)) - then (SET iName NIL)) - [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, (PACK (LIST 'Unimport - $packageName$)) - (l..interface) (* Lupine generated interface) - (if l..interface - then (if (FMEMB l..interface , iName) - then (UnimportInterface l..interface) - (SETQ , iName (DREMOVE l..interface , - iName)) - else (ERROR "not imported" l..interface)) - else (for e in , iName do (UnimportInterface e)) - (SETQ , iName NIL] - [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, (PACK (LIST 'Import - $packageName$)) - (type instance version) - (* Lupine generated interface) - (CAR (push , iName (ImportInterface (OR type , - lupineTypeString) - instance version] - [push $fns$ (CAR (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, (SETQ movdFn (PACK (LIST 'MovdsFor - $packageName$))) - NIL (* Lupine generated utility) - (for p in (QUOTE , movds) - do (PUTD (CDR p) - (GETD (CAR p] - [if $rNames$ - then (LET [(files (bind wh res for r in $rNames$ - when (if wh_(WHEREIS r 'RECORDS) - else (printout T T "Note - the record " r - " is not on any known file" - T)) - do (pushnew res wh:1) finally (RETURN res] - loads_(LIST (BQUOTE (DECLARE: DONTCOPY EVAL@COMPILE EVAL@LOAD (FILES (LOADCOMP) - ., files] - (BQUOTE ( (* Created by Lupine , (GDATE)) - (FNS ,. $fns$) - (VARS (, iName)) - (GLOBALVARS , iName) - (P (, movdFn)) - ., loads (DECLARE: EVAL@LOAD DONTEVAL@COMPILE DOCOPY (FILES (SYSLOAD) - RPC]) - -(\MakeMarshal - [LAMBDA (type val fn name typeTable pupName) (* ht: " 1-Aug-85 08:57") - (if type - then (if (NOT pupName) - then pupName_ 'l..cPup) - (LET (fragment) - fragment_(\MakeMarshal1 type val fn name typeTable 0 16 pupName) - (if NOT (fragment:notFixed) - then fragment:fixed - else (NCONC fragment:fixed (if val~= 'l..datum - then [LIST (BQUOTE (LET ((l..datum , val)) - ., - (fetch notFixed of fragment] - else fragment:notFixed]) - -(\MakeMarshal1 - [LAMBDA (type val fn name typeTable whereAreWe size pupName) - (* ht: " 1-Aug-85 08:59") - (LET ((typeName (\TypeName type)) - (typeParm (if (LISTP type) - then type:typeParm)) - afn typeSpec) - (SELECTQ typeName - ((RECORD SEQRECORD) - (SHOULDNT)) - [LIST (create Fragment - fixed _(LIST (BQUOTE (PROGN (\CheckPupOverflow , pupName 4) - (\AddPupDblWord , pupName (LENGTH , val) - l..conv) - (for l..v in , val - do ., (\MakeMarshal (CAR typeParm) - 'l..v - fn name typeTable - pupName] - [REF (* no-op except for SEQRECORDs) - (LET ((trueType (\BaseType typeParm:1 typeTable)) - typeSpec) - (if (AND (LISTP trueType) - trueType:typeName= - 'SEQRECORD) - then - - (* * have to back up one) - - - (\MakeMarshalRecord (OR typeSpec_(for tte in typeTable thereis - tte:typeType=trueType) - (SHOULDNT)) - val fn name typeTable whereAreWe - (if size=16 - then typeSpec:typeSize - else (SHOULDNT)) - pupName) - else (create Fragment - fixed _(LIST (BQUOTE (if , val - then (\AddPupBoolean , pupName NIL - l..conv) - ., - (\MakeMarshal (CAR typeParm) - val fn name - typeTable pupName) - else (\AddPupBoolean , pupName T l..conv] - [BITS (create Fragment - fixed _(if (ILESSP size 16) - then (\FixedStore size type val whereAreWe fn name typeTable) - elseif whereAreWe~=0 - then (HELP "bad layout") - elseif (ILEQ typeParm:1 16) - then - - (* * note that even if we get here with a BITS record of <16 size, we just put a whole word) - - - (LIST (BQUOTE (\AddPupWord , pupName , val l..conv))) - elseif typeParm:1=32 - then (* closest we get to LONG CARDINAL) - (LIST (BQUOTE (\AddPupDblWord , pupName , val l..conv))) - else (SHOULDNT] - (if (FMEMB typeName \LupinePrimativeTypes) - then (if (ILESSP size 16) - then (create Fragment - fixed _(\FixedStore size type val whereAreWe fn name - typeTable)) - elseif whereAreWe~=0 - then (HELP "bad layout") - elseif afn_(CDR (ASSOC typeName \LupinePutFns)) - then - - (* * note that if we get here with a BITS record of <16 size, we just get a whole word courtesy of the PutFns table  - entry) - - - [create Fragment - fixed _(LIST (BQUOTE (, afn , pupName ., - (if typeParm - then (LIST (KWOTE typeParm))) - , val l..conv] - else (SHOULDNT)) - elseif typeSpec_(ASSOC typeName typeTable) - then (if typeSpec:typeType:type= 'RECORD - then (\MakeMarshalRecord typeSpec val fn name typeTable whereAreWe - (if (AND size=16 (IGREATERP typeSpec:typeSize 16) - ) - then typeSpec:typeSize - else size) - pupName) - else (\MakeMarshal1 typeSpec:typeType val fn name typeTable whereAreWe size - pupName)) - else (ERROR "Invalid spec" (LIST fn name type]) - -(\MakeMarshalRecord - [LAMBDA (spec val fn name typeTable startBit bitWidth pupName) - (* ht: " 1-Aug-85 12:16") - (LET ((fnName (PACK* 'Marshal - $packageName$ spec:type '# - startBit - '# - bitWidth)) - (bits spec:typeBits) - (seq? spec:typeType:typeName= 'SEQRECORD) - seqSpec seqSubSpec seqEltStore seqStatic? stores notFixed indirects mc someNot) - [if (NOT (FMEMB fnName spec:definedStubs)) - then (push $rNames$ spec:type) - (if (ILESSP spec:typeSize bitWidth) - then bits_(CONS (IPLUS bits:1 bitWidth-spec:typeSize) - bits::1) - elseif (AND (IGREATERP spec:typeSize bitWidth) - (NOT (ZEROP startBit))) - then (HELP "bad layout")) - [stores_(bind (whereAreWe _ startBit) - (nFixed _ 0) for field in spec:typeType:typeParm as size in bits - join (if (AND (LISTP field:fieldType) - field:fieldType:typeName= - 'SEQUENCE) - then (if seq? - then (seqSpec_field) - (seqSubSpec_field:fieldType:typeParm:1) - - (* * * This should be a call to \MakeMarshal1 but because of a CEDAR Lupine bug, is not (see below for more  - discussion) - - If CEDAR is ever fixed, the call should be as follows: (SETQ seqEltStore (\MakeMarshal1 seqSubSpec  - (QUOTE l..datum) fn name typeTable whereAreWe size (QUOTE l..pup)))) - - - [seqEltStore_(\MakeMarshal seqSubSpec 'l..datum - fn name typeTable - (if seqStatic?_(\IsStatic - seqSubSpec - typeTable) - then 'l..pup - else 'l..cPup] - else (SHOULDNT)) - NIL - elseif (\LupineNotFixed field typeTable) - then (add nFixed 1) - (someNot_T) - NIL - else (mc_(\MakeMarshal1 field:fieldType - (BQUOTE (fetch (, (fetch type of spec) - , - (fetch fieldName - of field)) - of l..datum)) - fn name typeTable whereAreWe size - 'l..pup)) - [if mc:notFixed - then - notFixed_(NCONC1 - notFixed - (BQUOTE (LET ((l..datum (fetch (, (fetch type - of spec) - , - (fetch fieldName - of field)) - of l..datum))) - ., - (fetch notFixed of mc] - (mc_mc:fixed) - (whereAreWe_(LOGAND 15 (IPLUS whereAreWe size))) - (if (NOT (ZEROP nFixed)) - then (PROG1 (CONS (BQUOTE (\SkipBytesOut l..pup , - (LLSH nFixed 2))) - mc) - nFixed_0) - else mc)) - finally (if (NOT (ZEROP nFixed)) - then $$VAL_(NCONC1 $$VAL (BQUOTE (\SkipBytesOut l..pup , - (LLSH nFixed 2] - (if someNot - then [indirects_(for field in spec:typeType:typeParm when (\LupineNotFixed field - typeTable) - join (\MakeMarshal field:fieldType - (BQUOTE (fetch (, (fetch type of spec) - , - (fetch fieldName - of field)) - of l..datum)) - fn name typeTable 'l..cPup] - (notFixed_(NCONC notFixed indirects))) - [if seq? - then (LET (code f nf) - - (* * the code in this comment is the way this **should** work, with only the non-statics following after, but in  - fact as CEDAR Lupine stands if a sequence%'s element type has any non-static parts, the WHOLE element gets repeated. - There is a further patch associated with this higher up in this function. If this ever gets fixed, replace the if  - statement which follows this comment with this code: (if (fetch notFixed of seqEltStore) then  - (SETQ f (fetch fixed of seqEltStore)) (SETQ nf (fetch notFixed of seqEltStore)) elseif (\LupineNotFixed  - (fetch fieldType of seqSpec) typeTable) then (SETQ code (LIST (QUOTE (\SkipBytesOut l..pup (LLSH  - (LENGTH l..sequence) 2))))) (SETQ nf (fetch fixed of seqEltStore)) else (SETQ f (fetch fixed of seqEltStore)))) - - - (if seqStatic? - then f_seqEltStore - else [code_(LIST (BQUOTE (\SkipBytesOut l..pup - (ITIMES , - (LRSH (\TypeSize - seqSubSpec - typeTable) - 3) - (LENGTH l..sequence] - (nf_seqEltStore)) - [if f - then code_(LIST (BQUOTE (for l..datum in l..sequence do ., f] - [if nf - then notFixed_(NCONC1 notFixed - (BQUOTE (for l..datum - in (fetch (, (fetch type of spec) - , - (fetch fieldName - of seqSpec)) - of l..datum) - do ., nf] - stores_(BQUOTE ((\CheckPupOverflow l..pup 6) - (if l..datum - then (LET ((l..sequence (fetch (, (fetch type - of spec) - , - (fetch fieldName - of seqSpec)) - of l..datum))) - (\AddPupBoolean l..pup NIL l..conv) - (\AddPupDblWord l..pup (LENGTH l..sequence) - l..conv) - ., stores ., code) - else (\AddPupBoolean l..pup T l..conv] - [if (AND seq? notFixed) - then notFixed_(LIST (BQUOTE (if l..datum - then ., notFixed] - (APPLY* (FUNCTION DEFINEQ) - (BQUOTE (, fnName (l..pup l..datum l..conv) - (* Lupine generated stub) - ., stores))) - - (* * must record the notFixed generated here so they get used if the function gets re-used) - - - (PUT fnName 'LupineNotFixed - notFixed) - (push $fns$ fnName) - (push spec:definedStubs fnName) - else notFixed_(APPEND (GETP fnName 'LupineNotFixed] - (create Fragment - fixed _(LIST (BQUOTE (, fnName , pupName , val l..conv))) - notFixed _ notFixed]) - -(\FixedStore - [LAMBDA (size type val whereAreWe fn name typeTable) (* ht: " 1-Aug-85 09:10") - (LET ((typeName (\TypeName type)) - (typeParm (if (LISTP type) - then type:typeParm)) - rf bitNum form) - (SELECTQ typeName - (RECORD (SHOULDNT)) - ((BOOLEAN BITS ENUMERATION) - - (* * compute the field descriptor) - - - bitNum_ - (IPLUS (LLSH whereAreWe 4) - size-1) - - (* * make the call to FETCHFIELD) - - - form_ - (SELECTQ typeName - (BITS val) - [ENUMERATION (BQUOTE (for l..i from 0 as l..t in (QUOTE , typeParm) - do (if (EQ l..t , val) - then (RETURN l..i)) - finally (Signal 'BoundsCheck - (CONS , val (QUOTE , typeParm] - (BOOLEAN (BQUOTE (if , val - then 1 - else 0))) - (SHOULDNT)) - rf_ - (BQUOTE (REPLACEFIELD '(NIL 0 (BITS ., bitNum)) - (\CurrentPupPosition l..pup) - , form)) - (if (ZEROP whereAreWe) - then - - (* * need to check there is room in the l..pup) - - - (BQUOTE ((\CheckPupOverflow l..pup 2) - , rf)) - elseif (IPLUS whereAreWe size)=16 - then - - (* * must advance the counter - - must use LIST here because BQUOTE causes NCONC problems) - - - (LIST rf '(\IncrPupLength l..pup 2)) - else (LIST rf))) - (SHOULDNT]) - -(\MakeArgsMarshal - [LAMBDA (spec fn multTypeName varName typeTable) (* ht: "31-Jul-85 11:44") - (LET (resultSpec) - (if (AND (LITATOM spec) - resultSpec_(\BaseType spec typeTable) - (LISTP resultSpec) - resultSpec:typeName=multTypeName) - then (* unpack a record) - (push $rNames$ spec) - (for rBit in (\StaticsFirst resultSpec:typeParm typeTable) - join (\MakeMarshal rBit:fieldType (BQUOTE (fetch (, spec , (fetch fieldName - of rBit)) - of , varName)) - fn rBit:fieldName typeTable)) - else (\MakeMarshal spec varName fn varName typeTable]) -) - - - -(* Checking of declarations) - -(DEFINEQ - -(\CheckSpec - [LAMBDA (spec typeTable sigFlg) (* ht: "31-Jul-85 11:35") - (if (NLISTP spec) - then (ERROR "each spec must be a list" spec)) - (if spec:fn~= '* - then (if (NOT (LITATOM spec:fn)) - then (ERROR "the fn/signal of a spec must be an atom" spec:fn)) - (if (NLISTP spec:specs) - then (if spec:specs - then (ERROR "the arg specs of a spec must be a list" spec:specs))) - (if (OR spec:specs=NIL (U-CASE spec:specs:1:argName)= 'RETURNS) - then (printout T "Note: " spec:fn " has no args" T)) - (bind aSpec argsAlready [an _(if (AND (NOT sigFlg) - (GETD (fetch fn of spec))) - then (ARGLIST (fetch fn of spec] - for specP on spec:specs - do (if (U-CASE specP:1:argName)= 'RETURNS - then (if specP::1 - then (ERROR "RETURNS must be the last spec" specP) - else (GO $$OUT)) - else aSpec_specP:1) - (if sigFlg - then (if (AND (U-CASE specP:1:argName)= 'ARGS - (NOT argsAlready)) - then argsAlready_T - else (ERROR "first and only arg spec for a signal must be called ARGS")) - (\CheckType aSpec typeTable NIL T) - else (if an - then [if aSpec:argName=an:1 - then (pop an) - else (ERROR "arg name not right" (CONS aSpec:argName - (pop an] - else (if (NOT (LITATOM aSpec:argName)) - then (ERROR "arg name must be litatom" aSpec)) - (if (GETD spec:fn) - then (printout T "Note: spec has more arguments than function" , - spec:fn , aSpec T))) - (\CheckType aSpec typeTable)) - finally (if an - then (printout T "Note: spec has fewer arguments than function" , spec:fn - T))) - (LET ((last spec:-1)) - (if (U-CASE last:argName)= 'RETURNS - then (\CheckType last typeTable NIL T) - else (printout T "Note: " spec:fn " has no result" T]) - -(\CheckType - [LAMBDA (spec typeTable inDecl inSpecial inRef inSeq) (* ht: "30-Jul-85 09:01") - (\CheckType1 spec (\TypeName spec:argType) - (if (LISTP spec:argType) - then spec:argType:typeParm) - typeTable inDecl inSpecial inRef inSeq]) - -(\CheckType1 - [LAMBDA (spec typeName typeParm typeTable inDecl inSpecial inRef inSeq) - (* ht: "31-Jul-85 15:57") - (LET (trueType) - (if (FMEMB typeName \LupinePrimativeTypes) - then (if (FMEMB typeName \LupineTypesWithParm) - then (if (NOT typeParm) - then (ERROR "Must have type parm for type" spec)) - (SELECTQ typeName - ((LIST REF SEQUENCE) - (if (AND typeName= 'SEQUENCE - (NOT inSeq)) - then (ERROR "SEQUENCE field can occur only in SEQRECORDs" spec) - ) - (\CheckType spec:argType typeTable NIL NIL typeName= 'REF)) - (BITS (if (NOT (AND (NUMBERP typeParm:1) - (IGREATERP typeParm:1 0) - (OR (ILEQ typeParm:1 16) - typeParm:1=32) - typeParm::1=NIL)) - then (ERROR - "BITS type must have exactly one numeric parameter in [1..16] U [32]" - spec))) - ((RECORD RESULT SIGARGS) - (if (NOT inDecl) - then (ERROR - "In line RECORDs/RESULTs/SIGARGSs not allowed - must be pre-declared as a named type" - spec)) - (\CheckRecordDecl spec typeParm) - (for fs in typeParm do (\CheckType fs typeTable))) - (SEQRECORD (if (NOT inDecl) - then (ERROR - "In line SEQRECORDs not allowed - must be pre-declared as a named type" - spec)) - (\CheckRecordDecl spec typeParm) - (if [NOT (for fieldSpecPointer on typeParm - thereis (PROG1 (if (U-CASE (\TypeName - fieldSpecPointer:1:fieldType))= - 'SEQUENCE - then (if - fieldSpecPointer::1 - then - (ERROR - "SEQUENCE must be the last field of a SEQRECORD" - spec) - else T)) - (\CheckType fieldSpecPointer:1 - typeTable NIL NIL - NIL T] - then (ERROR - "SEQRECORD must end with a SEQUENCE field" - spec)) - (if (NOT (FMEMB (\TypeName typeParm:-2:fieldType) - \LupineNumberTypes)) - then (printout T - "Warning - next to last field in SEQRECORD not a numeric type?" - , spec))) - NIL) - elseif typeParm - then (ERROR "Shouldnt have type parm for type" spec)) - elseif (ASSOC typeName typeTable) - then (if typeParm - then (ERROR "Shouldnt have type parm for user-defined type" spec)) - (trueType_(\BaseType typeName typeTable)) - (if (LISTP trueType) - then (if (AND (FMEMB trueType:typeName \LupineDummyTypes) - (NOT inSpecial)) - then (ERROR "Can't use RESULT/SIGARGS except from RETURNS/ARGS spec" spec) - elseif (AND trueType:typeName= 'SEQRECORD - (NOT inRef)) - then (ERROR "Must get to SEQRECORD via a REF, not directly" spec))) - else (ERROR "Not a type" spec]) - -(\CheckRecordDecl - [LAMBDA (spec fieldSpecs) (* ht: "30-Jul-85 09:41") - (LET ((recFields (RECORDFIELDNAMES spec:fieldName))) - (if (NOT recFields) - then (ERROR "No record declaration for record type" spec)) - (if [NOT (AND (LENGTH recFields)=(LENGTH fieldSpecs) - (for fieldSpec in fieldSpecs always (FMEMB fieldSpec:fieldName recFields] - then (ERROR "Field names in type declaration don't match up with those of record" - (LIST recFields spec]) -) - - - -(* Type table construction) - -(DEFINEQ - -(\DeclareTypes - [LAMBDA (typeDecls) (* ht: "31-Jul-85 14:50") - (bind newEntry (typeTable _(APPEND \LupineInitialTypeTable)) - allocation for ty in typeDecls unless ty:type= '* - do (if (NOT (AND ty:type (LITATOM ty:type))) - then (ERROR "type declaration must begin with an atomic type name" ty)) - (if (OR NOT (ty:typeType) - ty::2) - then (ERROR "there must be one and only one type in a type declaration" ty)) - (if (U-CASE ty:type)= 'INCLUDE - then (if (AND ty:typeType (LITATOM ty:typeType)) - then typeTable_(NCONC typeTable (\DeclareTypes (EVALV ty:typeType))) - else (ERROR "INCLUDE must be of the form (INCLUDE )" ty)) - else (\CheckType ty typeTable T) - (newEntry_(create TypeSpec - type _ ty:type - typeType _ ty:typeType)) - (if (NOT (AND (LISTP ty:typeType) - (FMEMB (U-CASE ty:typeType:typeName) - \LupineDummyTypes))) - then (allocation_(\Allocate ty:typeType typeTable)) - (newEntry:typeSize_allocation:need) - (newEntry:typeBits_allocation:fields)) - (push typeTable newEntry)) - finally (RETURN typeTable]) - -(\Allocate - [LAMBDA (type typeTable subFlg) (* ht: "29-Jul-85 13:38") - (let ((typeName (\TypeName type)) - (typeParm (if (LISTP type) - then type:typeParm)) - res rRes) - res_[SELECTQ typeName - ((STRING ATOM LIST STREAM ARB FIXP REF SEQUENCE) - 32) - (SSMALLP 16) - ((RECORD SEQRECORD) - rRes_ - (\AllocateRecord typeName typeParm typeTable) - (if subFlg - then rRes:need - else rRes)) - (if (FMEMB typeName \LupinePrimativeTypes) - then (let [(need (SELECTQ typeName - (BOOLEAN 1) - (BITS typeParm:1) - [ENUMERATION - (IMAX 1 (bind (max _(SUB1 (LENGTH typeParm))) - until (ZEROP max) - count max_(LRSH max 1] - (SHOULDNT] - (if (IGREATERP need 16) - then (SHOULDNT "Too big") - else need)) - else (* user defined type) - (fetch typeSize of (\TypeLayout typeName typeTable] - (if subFlg - then (LIST res) - else (OR (LISTP res) - (create RecordLayout - need _ res - fields _(LIST res]) - -(\AllocateRecord - [LAMBDA (typeName typeParm typeTable) (* ht: "24-Jul-85 19:33") - (bind (bitsLeft _ 16) - (wordsUsed _ 0) - left sub need for t in typeParm - join (sub_(\Allocate t:fieldType typeTable T)) - (need_sub:1) - (if (IGREATERP need bitsLeft) - then (if (ZEROP bitsLeft) - then - - (* * run out - - fix it) - - - (add wordsUsed 1) - elseif bitsLeft~=16 - then - - (* * expand the leftmost bit of the last thing to fit) - - - (add left:1 bitsLeft) - (add wordsUsed 1)) - (bitsLeft_16) - (if (IGREATERP need 15) - then - - (* * must be some number of words) - - - (add wordsUsed (LRSH need 4)) - (need_0) - else bitsLeft_bitsLeft-need) - else bitsLeft_bitsLeft-need) - (left_sub) - finally (if (ZEROP bitsLeft) - then (add wordsUsed 1) - elseif (AND (NOT (ZEROP wordsUsed)) - bitsLeft~=16) - then - - (* * only sub-word records are allowed to be not a multiple of 16 - - pad) - - - (add left:1 bitsLeft) - (add wordsUsed 1)) - (RETURN (create RecordLayout - need _(if (ZEROP wordsUsed) - then 16-bitsLeft - else (LLSH wordsUsed 4)) - fields _ $$VAL]) -) - - - -(* Utilities) - -(DEFINEQ - -(\TypeName - [LAMBDA (type) (* ht: "26-Jul-85 09:14") - (LET ((typen (if (LISTP type) - then type:typeName - else type))) - (if (FMEMB (U-CASE typen) - \LupinePrimativeTypes) - then (U-CASE typen) - else typen]) - -(\BaseType - [LAMBDA (type typeTable) (* ht: "26-Jul-85 09:04") - (LET ((typeName (\TypeName type))) - (if (FMEMB typeName \LupinePrimativeTypes) - then type - else (\BaseType (fetch typeType of (\TypeLayout typeName typeTable)) - typeTable]) - -(\TypeLayout - [LAMBDA (typeName typeTable) (* ht: "24-Jul-85 11:32") - (OR (ASSOC typeName typeTable) - (HELP "Type not defined" typeName]) - -(\TypeSize - [LAMBDA (type typeTable) (* ht: "31-Jul-85 09:21") - (LET ((typeName (\TypeName type)) - entry) - (if entry_(ASSOC typeName typeTable) - then entry:typeSize - elseif (FMEMB typeName \LupineNotFixedTypes) - then 32 - else 16]) - -(\LupineNotFixed - [LAMBDA (field typeTable) (* ht: "26-Jul-85 09:08") - (FMEMB (\TypeName (\BaseType field:fieldType typeTable)) - \LupineNotFixedTypes]) - -(\StaticsFirst - [LAMBDA (specs typeTable) (* ht: "25-Jul-85 16:13") - (bind nonStatics for s in specs when (if (U-CASE s:argName) - ~= - 'RETURNS - then (if (\IsStatic s:argType typeTable) - else (nonStatics_(NCONC1 nonStatics s)) - NIL)) - collect s finally (RETURN (NCONC $$VAL nonStatics]) - -(\IsStatic - [LAMBDA (type typeTable) (* ht: "26-Jul-85 09:01") - (LET* ((trueType (\BaseType type typeTable)) - (typeName (\TypeName trueType))) - (OR (MEMB typeName \LupineStatics) - (AND typeName= 'RECORD - (for f in trueType:typeParm always (\IsStatic f:fieldType typeTable]) -) - -(RPAQQ \LupineGetFns ((SSMALLP . \GetArgSmallp) - (FIXP . \GetArgDblWord) - (BOOLEAN . \GetArgBool) - (STRING . \UnmarshalString) - (ATOM . \UnmarshalAtom) - (STREAM . \UnmarshalStream) - (ENUMERATION . \GetArgEnum) - (ARB . \UnmarshalArb))) - -(RPAQQ \LupinePutFns ((SSMALLP . \AddPupSmallp) - (FIXP . \AddPupDblWord) - (BOOLEAN . \AddPupBoolean) - (STRING . \MarshalString) - (ATOM . \MarshalAtom) - (STREAM . \MarshalStream) - (ENUMERATION . \AddPupEnum) - (ARB . \MarshalArb) - (BITS . \AddPupWord))) - -(RPAQQ \LupinePrimativeTypes (SSMALLP FIXP BOOLEAN STRING ATOM STREAM ENUMERATION ARB BITS LIST - RECORD RESULT SIGARGS REF SEQRECORD SEQUENCE)) - -(RPAQQ \LupineInitialTypeTable ((CARDINAL (BITS 16) - NIL 16 16) - (* the next is not true, but is as close as we get) - (LONGCARDINAL (BITS 32) - NIL 32 32))) - -(RPAQQ \LupineNumberTypes (FIXP SSMALLP ENUMERATION BITS)) - -(RPAQQ \LupineNotFixedTypes (STRING ATOM STREAM ARB LIST REF)) - -(RPAQQ \LupineDummyTypes (RESULT SIGARGS)) - -(RPAQQ \LupineStatics (SSMALLP FIXP BOOLEAN ENUMERATION BITS)) - -(RPAQQ \LupineTypesWithParm (ENUMERATION BITS LIST REF SEQRECORD SEQUENCE RECORD RESULT SIGARGS - STREAM)) -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \LupineGetFns \LupinePutFns \LupineStatics \LupineTypesWithParm \LupinePrimativeTypes - \LupineDummyTypes \LupineNotFixedTypes \LupineNumberTypes \LupineInitialTypeTable) -) -(DECLARE: DONTCOPY -(DECLARE: EVAL@COMPILE - -(RPAQQ \FirstLupineUserCall 4) - -(RPAQQ \FirstLupineSignal 4) - -(CONSTANTS (\FirstLupineUserCall 4) - (\FirstLupineSignal 4)) -) -) -(PUTPROPS LUPINE COPYRIGHT ("Xerox Corporation" 1984 1985 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (1917 43384 (Lupine 1927 . 3884) (\ServerComs 3886 . 10078) (\MakeUnmarshal 10080 . -10581) (\MakeUnmarshal1 10583 . 14428) (\MakeUnmarshalRecord 14430 . 22709) (\FixedFetch 22711 . 23977 -) (\MakeArgsUnmarshal 23979 . 24867) (\ClientComs 24869 . 30430) (\MakeMarshal 30432 . 31021) ( -\MakeMarshal1 31023 . 34722) (\MakeMarshalRecord 34724 . 41100) (\FixedStore 41102 . 42627) ( -\MakeArgsMarshal 42629 . 43382)) (43422 49673 (\CheckSpec 43432 . 45630) (\CheckType 45632 . 45912) ( -\CheckType1 45914 . 49088) (\CheckRecordDecl 49090 . 49671)) (49710 53777 (\DeclareTypes 49720 . 51058 -) (\Allocate 51060 . 52323) (\AllocateRecord 52325 . 53775)) (53800 56008 (\TypeName 53810 . 54128) ( -\BaseType 54130 . 54457) (\TypeLayout 54459 . 54650) (\TypeSize 54652 . 54975) (\LupineNotFixed 54977 - . 55188) (\StaticsFirst 55190 . 55629) (\IsStatic 55631 . 56006))))) -STOP diff --git a/obsolete/lispusers/LoadPatches b/obsolete/lispusers/LoadPatches deleted file mode 100644 index 2de5a1e6..00000000 --- a/obsolete/lispusers/LoadPatches +++ /dev/null @@ -1,72 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "16-Nov-88 14:11:42" {PHYLUM}LISP>LYRIC>LOADPATCHES.;3 3441 - - changes to%: (VARS LOADPATCHESCOMS) - (FNS LoadPatches COLLECT-PATCH-FILES) - - previous date%: "27-Sep-88 22:56:49" {PHYLUM}LISP>LYRIC>LOADPATCHES.;1) - - -(* " -Copyright (c) 1985, 1988 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT LOADPATCHESCOMS) - -(RPAQQ LOADPATCHESCOMS ((FNS LoadPatches COLLECT-PATCH-FILES) - (DECLARE%: DONTCOPY (PROP FILETYPE LOADPATCHES)))) -(DEFINEQ - -(LoadPatches - [LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 16-Nov-88 13:08 by Burwell") - -(* ;;; "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 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 16-Nov-88 13:13 by Burwell") - - (* ;; "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))))]) -) -(DECLARE%: DONTCOPY - -(PUTPROPS LOADPATCHES FILETYPE :COMPILE-FILE) -) -(PUTPROPS LOADPATCHES COPYRIGHT ("Xerox Corporation" 1985 1988)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (608 3275 (LoadPatches 618 . 2308) (COLLECT-PATCH-FILES 2310 . 3273))))) -STOP diff --git a/obsolete/lispusers/MATHSERVER b/obsolete/lispusers/MATHSERVER deleted file mode 100644 index c52bd79f..00000000 --- a/obsolete/lispusers/MATHSERVER +++ /dev/null @@ -1,3637 +0,0 @@ -(FILECREATED "15-Apr-87 10:54:01" {IVY}LISP>MATHSERVER.;1 129647 - - changes to: (METHODS Server.ExecuteCommandFile) - (FNS Server.ExecuteCommandFile MS.TopLevel MS.ExpandFilename MS.SubmitBatchJob - MS.RunInteractiveJob MS.Compile MS.Link MS.CompileLink MS.CompileLinkRun - MS.StartDefaultFE) - (VARS MATHSERVERCOMS) - - previous date: "12-Dec-86 19:13:28" {PHYLUM}KOTO>MATHSERVER.;1) - - -(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT MATHSERVERCOMS) - -(RPAQQ MATHSERVERCOMS ((* * SERVER MENU - Sets up the main Server Free Menu) - (* MENU AND WINDOW FUNCTIONS) - (FNS MS.TopLevel MS.CreateFreeMenu MS.SelectHost MS.ExpandFilename MS.CloseErrorWindow - MS.CleanupErrorFile MS.AttachErrorWindow MS.MostRoom MS.GetMessageWindow - MS.MakeIconWindow PrintMsg) - (* SERVER METACLASS FUNCTIONS) - (FNS MS.MakeMenuOfKnownHosts MS.DestroyInstances) - (* MATH SERVER FUNCTIONS) - (FNS MS.SubmitBatchJob MS.AbortBatchJob MS.Status MS.DisplayStatus MS.RunInteractiveJob - MS.Compile MS.Link MS.CompileLink MS.CLR.Check MS.CLR.NoCheck MS.CompileLinkRun) - (* FORTRAN EDITOR FUNCTIONS) - (FNS MS.StartNewFE MS.StartDefaultFE MS.FindFortranEdit MS.CheckForDirtyFile) - (* ERROR HANDLING FUNCTIONS) - (FNS MS.BatchErrors? MS.BatchLog) - (* Icon BITMAPS) - (BITMAPS MS.Icon MS.IconMask) - (* VARS) - (ADDVARS (BackgroundMenuCommands (Server% Menu (QUOTE (MS.TopLevel)) - "Start the Server Menu"))) - (VARS (BackgroundMenu NIL)) - (GLOBALVARS MS.HostPopMenu) - (* * FORTRAN EDIT - Sets up a Fortran Edit Process) - (* MAIN FUNCTIONS) - (FNS FE.TopLevel FE.AdjustProps FE.CaretPosition TEDIT.PARA&CHAR FE.CharFn FE.GetEditProps - FE.GetSourceFileName FE.LoopFn) - (* WINDOW FUNCTIONS) - (FNS FE.GetPositionWindow FE.GetEditWindow FE.GetMessageWindow FE.ReshapeFn FE.ShadeWindow) - (* LOCALMENU FUNCTIONS) - (FNS FE.CreateLocalMenu FE.SetHost FE.SetDirectory FE.MyGet FE.MyPut FE.StripVersion - FE.Compile FE.Link FE.CompileLinkRun FE.RunInteractive) - (* SERVER METACLASS FUNCTIONS) - (FNS FE.ValidHostname FE.GetServer) - (* ICON STUFF) - (FNS FE.ShrinkIconCreate) - (BITMAPS FE.Icon FE.IconMask) - (INITVARS (FE.defaultFont (FONTCLASS (QUOTE FORTRANEDITFONT) - (QUOTE (1 (GACHA 12) - (GACHA 10) - (GACHA 10))))) - (FE.iconFont (FONTCREATE (QUOTE HELVETICA) - 8 - (QUOTE BOLD))) - (FE.iconTitleRegion (create REGION LEFT _ 8 BOTTOM _ 8 WIDTH _ 110 HEIGHT _ 40)) - (FE.titledIconTemplate (create TITLEDICON ICON _ FE.Icon MASK _ FE.IconMask - TITLEREG _ FE.iconTitleRegion))) - (* VARS) - (ADDVARS (BackgroundMenuCommands (Fortran% Edit (QUOTE (FE.TopLevel)) - "Start a Fortran Edit"))) - (VARS (BackgroundMenu NIL)) - (GLOBALVARS FE.defaultFont FE.iconFont FE.titledIconTemplate TEDIT.READTABLE) - (* * SERVERS -- Defines the Loops MathServer objects) - (CLASSES Cray FortranServer MathServer Server VMSServer) - (METHODS FortranServer.Compile FortranServer.Compiled? FortranServer.Link - FortranServer.Linked? MathServer.AlertManager Server.AbortJob - Server.CommandFileExtension Server.Description Server.Error? Server.ErrorFile - Server.ErrorString Server.ExecuteCommandFile Server.ExtractFilename Server.GetQueues - Server.GetTime Server.Host Server.MakeError Server.MakeFullName - Server.MakePartialName Server.Name Server.PutErrorInWindow Server.PutTextInWindow - Server.Result Server.RunFile Server.RunJob Server.ServerDirectory - Server.SourceExtension Server.Status Server.SubmitJob Server.UserDirectory - VMSServer.MakeCommandString) - (FNS MS.MakeInstances StripPA) - (P (MS.DestroyInstances) - (MS.MakeInstances)) - (* * PROGRAMCHAT - Windowless CHAT for communication) - (FNS OPENCHATSTREAM PROGRAMCHAT PROGRAMCHAT.LOGIN PROGRAMCHAT.OUTPUT) - (* VARS for our site) - (VARS NETWORKLOGINFO) - (P (pushnew NETWORKOSTYPES (QUOTE (GSLVAX . VMS)) - (QUOTE (SITKA . VMS)) - (QUOTE (MADVAX . VMS)))) - (* * PROGRAMMER'S INTERFACE - use remote servers with LISP calls) - (FNS PRIN.RunRemote PRIN.ValidateHost PRIN.ValidateFilename PRIN.Error))) - (* * SERVER MENU - Sets up the main Server Free Menu) - - - - -(* MENU AND WINDOW FUNCTIONS) - -(DEFINEQ - -(MS.TopLevel - (LAMBDA NIL (* DSB "15-Apr-87 10:19") - (* Sets up the ServerFreeMenu, with PopUpMenu for host - selection and with attached messageWindow) - (PROG (menuWindow menuRegion messageWindow side) - (SETQ menuWindow (MS.CreateFreeMenu 470 470)) - (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE QUEUE)) - menuWindow) - (SETQ menuRegion (WINDOWPROP menuWindow (QUOTE REGION))) - - (* * Create PopUp menu for selection of Host) - - - (SETQ MS.HostPopMenu (MS.MakeMenuOfKnownHosts)) - - (* * create, attach and save pointer to messageWindow) - - - (SETQ messageWindow (CREATEW (CREATEREGION 0 0 200 150) - "Message Window" NIL T)) - (SETQ side (QUOTE LEFT)) - (COND - ((EQ (QUOTE LEFT) - (MS.MostRoom menuWindow)) - (SETQ side (QUOTE RIGHT))) - (T NIL)) - (ATTACHWINDOW messageWindow menuWindow side (QUOTE JUSTIFY)) - (WINDOWPROP menuWindow (QUOTE MessageWindow) - messageWindow) - (WINDOWPROP menuWindow (QUOTE ICONFN) - (FUNCTION MS.MakeIconWindow)) - (OPENW menuWindow)))) - -(MS.CreateFreeMenu - (LAMBDA (LEFT BOTTOM) (* DSB " 9-Dec-86 15:50") - (* returns a free menu window at specified position) - (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL FortranEdit-Commands: FONT (MODERN 12 BOLD)) - (LABEL StartNew SELECTEDFN MS.StartNewFE) - (LABEL StartWithDefault SELECTEDFN MS.StartDefaultFE)) - ((TYPE TITLE LABEL PlotMenu-Commands: FONT (MODERN 12 BOLD)) - (LABEL SimplePlot SELECTEDFN MAPL.Simple.TopLevel) - (LABEL Gen.Plot SELECTEDFN MAPL.Gen.TopLevel) - (LABEL MetaPlot SELECTEDFN MAPL.Meta.TopLevel)) - ((TYPE TITLE LABEL Compiler-Commands: FONT (MODERN 12 BOLD)) - (LABEL Compile SELECTEDFN MS.Compile) - (LABEL Link SELECTEDFN MS.Link) - (LABEL C/L SELECTEDFN MS.CompileLink)) - ((TYPE TITLE LABEL Run-Commands: FONT (MODERN 12 BOLD)) - (LABEL RunInteractive SELECTEDFN MS.RunInteractiveJob) - (LABEL C/L/R SELECTEDFN MS.CLR.NoCheck) - (LABEL C?/L?/R SELECTEDFN MS.CLR.Check)) - ((TYPE TITLE LABEL Batch-Commands: FONT (MODERN 12 BOLD)) - (LABEL Submit SELECTEDFN MS.SubmitBatchJob) - (LABEL Status SELECTEDFN MS.Status) - (LABEL Errors? SELECTEDFN MS.BatchErrors?) - (LABEL Abort SELECTEDFN MS.AbortBatchJob) - (LABEL Log SELECTEDFN MS.BatchLog)) - ((TYPE TITLE LABEL "COMPUTE SERVER FILE INFO" FONT (MODERN 12 BOLD))) - ((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD) - ITEMS - (FILENAME)) - (TYPE EDIT ID FILENAME LABEL "")) - ((TYPE EDITSTART LABEL DefaultDirectory: FONT (MODERN 12 BOLD) - ITEMS - (DEFAULTDIRECTORY)) - (TYPE EDIT ID DEFAULTDIRECTORY LABEL "")) - ((TYPE EDITSTART LABEL JobParameters: FONT (MODERN 12 BOLD) - ITEMS - (PARAMETERSTRING)) - (TYPE EDIT ID PARAMETERSTRING LABEL "")) - ((TYPE EDITSTART LABEL LinkParameters: FONT (MODERN 12 BOLD) - ITEMS - (LINKSTRING)) - (TYPE EDIT ID LINKSTRING LABEL "")) - ((TYPE TITLE LABEL "COMPUTE SERVER HOST INFO" FONT (MODERN 12 BOLD))) - ((TYPE TITLE LABEL HostName: FONT (MODERN 12 BOLD) - SELECTEDFN MS.SelectHost) - (TYPE TITLE ID HOST LABEL "")) - ((TYPE TITLE LABEL Queue: FONT (MODERN 12 BOLD)) - (TYPE NWAY ID QUEUE LABEL Fast CLASSNAME FastQueue) - (TYPE NWAY ID QUEUE LABEL Medium CLASSNAME MediumQueue) - (TYPE NWAY ID QUEUE LABEL Slow CLASSNAME SlowQueue)) - ((TYPE EDITSTART LABEL JobNumber: FONT (MODERN 12 BOLD) - ITEMS - (JOBNUMBER)) - (TYPE EDIT ID JOBNUMBER LABEL "")) - ((TYPE TITLE LABEL SERVERBROWSER-Command: FONT (MODERN 12 BOLD)) - (LABEL MakeBrowser SELECTEDFN MS.MakeInstances)) - (WINDOWPROPS TITLE "Server Menu" LEFT , LEFT BOTTOM , BOTTOM)))))) - -(MS.SelectHost - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "10-Jun-86 18:17") - (* Uses the pop-up menu MS.HostPopMenu to return a  - label and a pointer to the Host Server.) - (PROG ((promptW (GETPROMPTWINDOW WINDOW)) - (sItem (FM.ITEMFROMID WINDOW (QUOTE HOST))) - server) - - (* * Opens the PopUp menu. Returns the object name of the selected server.) - - - (CLEARW promptW) - (PRIN1 "Select host." promptW) - (SETQ server (MENU MS.HostPopMenu)) - (CLEARW promptW) - - (* * if the server exists, set the Host prop of the "HOST" item in the menu to point to the Server object. - Then change the item label to be the name of the Server object.) - - - (COND - (server (FM.ITEMPROP sItem (QUOTE Host) - server) - (FM.CHANGELABEL sItem WINDOW (_ server Name))) - (T - - (* * otherwise, set both the Host prop and the label of the "HOST" item in the menu to nil.) - - - (FM.ITEMPROP sItem (QUOTE Host) - NIL) - (FM.CHANGELABEL sItem WINDOW "")))))) - -(MS.ExpandFilename - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:22") - (* if filename contains a directory, expand it into  - separate slots) - (* this is a shortened version of MAPL.ExpandFilename) - (PROG ((state (FM.READSTATE WINDOW)) - filename defaultDirectory name) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - - (* * strip off any extensions and version numbers) - - - (SETQ name (UNPACKFILENAME filename (QUOTE NAME))) - (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE FILENAME)) - WINDOW name) - - (* * if there is a directory, place it in the menu) - - - (SETQ defaultDirectory (UNPACKFILENAME filename (QUOTE DIRECTORY))) - (COND - (defaultDirectory (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE DEFAULTDIRECTORY)) - WINDOW defaultDirectory))) - - (* * update "state" and return) - - - (SETQ state (FM.READSTATE WINDOW)) - (RETURN state)))) - -(MS.CloseErrorWindow - (LAMBDA (mainWindow) (* DSB "15-Aug-86 15:27") - - (* * Check if an errorWindow already exists. If so, delete the {core} file behind it, clean up props, and finally  - close the window.) - - - (LET (oldWindow oldFile) - (SETQ oldWindow (find item in (ATTACHEDWINDOWS mainWindow) - suchthat (WINDOWPROP item (QUOTE ERRORFILE)))) - (COND - (oldWindow (MS.CleanupErrorFile oldWindow) - (CLOSEW oldWindow)))))) - -(MS.CleanupErrorFile - (LAMBDA (errorWindow) (* DSB "15-Aug-86 15:30") - (* deletes the error file that resides in {core}, if  - it exists, and resets errorWindow prop to NIL) - (LET ((oldFile (WINDOWPROP errorWindow (QUOTE ERRORFILE)))) - (COND - (oldFile (CLOSEF? oldFile) - (DELFILE oldFile) - (WINDOWPROP errorWindow (QUOTE ERRORFILE) - NIL))) - NIL))) - -(MS.AttachErrorWindow - (LAMBDA (mainWindow title) (* DSB "15-Aug-86 15:22") - (* Attaches an error window to the main menu window) - - (* * MS.CloseErrorWindow should have been called prior to this. Nevertheless, we check for an old errorWindow, and  - if it exists, we call MS.CloseErrorWindow) - - - - (* * Make the error window and attach it to the appropriate side of the main window) - - - (LET (oldWindow errorWindow) - (SETQ oldWindow (find item in (ATTACHEDWINDOWS mainWindow) - suchthat (WINDOWPROP item (QUOTE ERRORFILE)))) - (AND oldWindow (MS.CloseErrorWindow mainWindow)) - (SETQ errorWindow (CREATEW (QUOTE (0 0 470 300)) - title NIL T)) - (ATTACHWINDOW errorWindow mainWindow (MS.MostRoom mainWindow) - (QUOTE JUSTIFY) - (QUOTE LOCALCLOSE)) - errorWindow))) - -(MS.MostRoom - (LAMBDA (WINDOW) (* DSB " 7-Aug-86 11:55") - (* determines if attached window should be on right or - left side of main window) - (LET ((region (WINDOWPROP WINDOW (QUOTE REGION))) - leftSpace rightSpace) - (SETQ leftSpace (fetch (REGION LEFT) of region)) - (SETQ rightSpace (DIFFERENCE 1025 (PLUS leftSpace (fetch (REGION WIDTH) - of region)))) - (COND - ((GEQ leftSpace rightSpace) - (QUOTE LEFT)) - (T (QUOTE RIGHT)))))) - -(MS.GetMessageWindow - (LAMBDA (WINDOW) (* DSB " 6-Jun-86 15:57") - (* maybe later, we'll check if the message window  - exists and if not, will make it first) - (WINDOWPROP WINDOW (QUOTE MessageWindow)))) - -(MS.MakeIconWindow - (LAMBDA (WINDOW OLDICON) (* DSB " 9-Dec-86 15:44") - - (* * Creates a window with an icon formed by two bit maps.) - - - (OR OLDICON (ICONW MS.Icon MS.IconMask)))) - -(PrintMsg - (LAMBDA (place msg) (* thh: " 6-Nov-85 11:04") - (* prints message in appropriate prompt window) - (* no message if place = DON'T) - (COND - ((Object? place) - (_ place ClearPromptWindow) - (_ place PromptPrint msg)) - ((TYPENAMEP place (QUOTE PLOT)) - (LET ((w (PLOTPROP place (QUOTE PLOTPROMPTWINDOW)))) - (CLEARW w) - (PRIN1 msg w))) - ((WINDOWP place) - (LET ((w (GETPROMPTWINDOW place 2))) - (CLEARW w) - (PRIN1 msg w))) - ((EQ place (QUOTE DON'T))) - (T (CLRPROMPT) - (PROMPTPRINT msg))))) -) - - - -(* SERVER METACLASS FUNCTIONS) - -(DEFINEQ - -(MS.MakeMenuOfKnownHosts - (LAMBDA NIL (* DSB "19-Aug-86 17:05") - (* makes the MS.HostPopMenu) - (create MENU - ITEMS _(for server in (_ ($ Server) - AllInstances!) - collect (LIST (_ server Name) - server - (_ server Description)))))) - -(MS.DestroyInstances - (LAMBDA NIL (* DSB "19-Aug-86 15:37") - (* obvious! Use MS.MakeInstances after this.) - (for instance in (_ ($ Server) - AllInstances!) - do (_ instance Destroy)))) -) - - - -(* MATH SERVER FUNCTIONS) - -(DEFINEQ - -(MS.SubmitBatchJob - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:28") - (* Creates the SubmitJob message to be sent to the  - appropriate host) - (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - filename defaultDirectory host validQueues queue parameterString result) - - (* * check that all required data is specified) - - - (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PrintMsg WINDOW "Unspecified file name.") - (RETURN))) - (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) - (COND - ((EQUAL defaultDirectory "") - (PrintMsg WINDOW "Unspecified default directory.") - (RETURN))) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - (SETQ validQueues (_ host GetQueues)) - (SETQ queue (LISTGET state (QUOTE QUEUE))) - (COND - ((NOT queue) - (PrintMsg WINDOW "Unspecified queue.") - (RETURN)) - ((NOT (MEMBER queue validQueues)) - (CLEARW promptW) - (PRIN1 "Not a valid queue for this server" promptW) - (TERPRI promptW) - (PRINTOUT promptW "Valid queues: " validQueues) - (RETURN))) - (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING))) - (COND - ((STRPOS "," parameterString) - (PrintMsg WINDOW "Remove comma(s) from JobParameters") - (RETURN))) - - (* * return the SubmitJob message) - - - (PrintMsg WINDOW "Submitting Batch Job ...") - (CLEARW messageW) - (MS.CloseErrorWindow WINDOW) - (COND - ((EQUAL parameterString "") - (SETQ result (_ host SubmitJob (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename) - queue))) - (T (SETQ result (_ host SubmitJob (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename) - queue - (LIST (MKSTRING parameterString)))))) - (PRIN1 result messageW) - (CLEARW promptW) - (PRIN1 "Done" promptW) - (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE JOBNUMBER)) - WINDOW - (CAR result))))) - -(MS.AbortBatchJob - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "12-Aug-86 09:52") - (* Creates the AbortJob message to be sent to the  - appropriate host) - (PROG ((state (FM.READSTATE WINDOW)) - (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - host jobNumber queue validQueues result) - - (* * check that the host name is specified) - - - (CLEARW promptW) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - - (* * check that the job number is specified) - - - (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER))) - (COND - ((EQUAL jobNumber "") - (SETQ jobNumber NIL) - (PrintMsg WINDOW "Unspecified job number.") - (RETURN))) - - (* * check that the queue is specified and valid) - - - (SETQ validQueues (_ host GetQueues)) - (SETQ queue (LISTGET state (QUOTE QUEUE))) - (COND - ((NOT queue) - (PrintMsg WINDOW "Unspecified queue.") - (RETURN)) - ((NOT (MEMBER queue validQueues)) - (CLEARW promptW) - (PRIN1 "Not a valid queue for this server" promptW) - (TERPRI promptW) - (PRINTOUT promptW "Valid queues: " validQueues) - (RETURN))) - - (* * abort the job and return the result) - - - (CLEARW promptW) - (PRINTOUT promptW "Job " jobNumber " on queue " queue " is being aborted ...") - (SETQ result (_ host AbortJob jobNumber queue)) - (TERPRI promptW) - (PRIN1 "Done" promptW) - (CLEARW messageW) - (PRIN1 result messageW)))) - -(MS.Status - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "12-Aug-86 17:53") - (* Creates the Status message to be sent to the  - appropriate host) - (PROG ((state (FM.READSTATE WINDOW)) - (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - host jobNumber result) - - (* * check that the host name is specified) - - - (CLEARW promptW) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - - (* * give notice if no job number is supplied) - - - (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER))) - (COND - ((NUMBERP (MKATOM jobNumber)) - (PRIN1 "Finding Status ..." promptW)) - (T (SETQ jobNumber NIL) - (PRIN1 "Unspecified job number." promptW) - (TERPRI promptW) - (PRIN1 "Finding status of all batch jobs ..." promptW))) - - (* * return the Status message) - - - (CLEARW messageW) - (SETQ result (_ host Status jobNumber)) - (MS.DisplayStatus result messageW) - (CLEARW promptW) - (PRIN1 "Done" promptW)))) - -(MS.DisplayStatus - (LAMBDA (result messageW) (* DSB "12-Aug-86 18:00") - (* Displays the status in nice format in  - messageWindow) - (PROG (number time) - (TERPRI messageW) - (PRIN1 " JOB CPU" messageW) - (TERPRI messageW) - (PRIN1 "- - - - - - - - - - - - - - - - -" messageW) - - (* * is it a single data item (JOB in CAAR) or...) - - - (COND - ((EQ (CAAR result) - (QUOTE JOB)) - (SETQ number (CADAR result)) - (SETQ time (CADADR result)) - (TERPRI messageW) - (PRIN1 (CONCAT " " number " " time) - messageW)) - (T (for item in result - do (SETQ number (CADAR item)) - (SETQ time (CADADR item)) - (TERPRI messageW) - (PRIN1 (CONCAT " " number " " time) - messageW))))))) - -(MS.RunInteractiveJob - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:30") - (* Creates the RunJob message to be sent to the  - appropriate host) - (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - filename defaultDirectory host parameterString result errorFile errorWindow) - - (* * check that all required data is specified) - - - (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PrintMsg WINDOW "Unspecified file name.") - (RETURN))) - (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) - (COND - ((EQUAL defaultDirectory "") - (PrintMsg WINDOW "Unspecified default directory.") - (RETURN))) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING))) - (COND - ((STRPOS "," parameterString) - (PrintMsg WINDOW "Remove comma(s) from JobParameters") - (RETURN))) - - (* * return the RunJob message) - - - (CLEARW promptW) - (PRIN1 "Running interactive job ..." promptW) - (CLEARW messageW) - (MS.CloseErrorWindow WINDOW) - (COND - ((EQUAL parameterString "") - (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename)))) - (T (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename) - (LIST (MKSTRING parameterString)))))) - (PRIN1 result messageW) - (CLEARW promptW) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN1 "Run-time warning or error" promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Run-time Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow WINDOW)) - (T (PRIN1 "Done" promptW)))))) - -(MS.Compile - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:14") - (* Creates the Compile message to be sent to the  - appropriate host) - (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - filename defaultDirectory host result errorFile errorWindow) - (CLEARW messageW) - - (* * check that all required data is specified) - - - (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PrintMsg WINDOW "Unspecified file name.") - (RETURN))) - (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) - (COND - ((EQUAL defaultDirectory "") - (PrintMsg WINDOW "Unspecified default directory.") - (RETURN))) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - - (* * check for dirty file in a Fortran Edit) - - - (COND - ((MS.CheckForDirtyFile filename promptW messageW) - (RETURN))) - - (* * send the Compile message) - - - (CLEARW promptW) - (PRIN1 "Compiling source file ..." promptW) - (MS.CloseErrorWindow WINDOW) - (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename))) - (CLEARW messageW) - (PRIN1 result messageW) - (CLEARW promptW) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN1 "Compilation Error" promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow WINDOW)) - (T (PRIN1 "Successful Compilation" promptW)))))) - -(MS.Link - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:31") - (* Creates the Link message to be sent to the  - appropriate host) - (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - filename defaultDirectory host linkString result errorFile errorWindow) - - (* * check that all required data is specified) - - - (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PrintMsg WINDOW "Unspecified file name.") - (RETURN))) - (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) - (COND - ((EQUAL defaultDirectory "") - (PrintMsg WINDOW "Unspecified default directory.") - (RETURN))) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - (SETQ linkString (LISTGET state (QUOTE LINKSTRING))) - (COND - ((STRPOS " " linkString) - (PrintMsg WINDOW "Remove spaces from LinkParameters") - (RETURN))) - - (* * return the Link message) - - - (CLEARW promptW) - (PRIN1 "Linking ..." promptW) - (CLEARW messageW) - (MS.CloseErrorWindow WINDOW) - (COND - ((EQUAL linkString "") - (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename)))) - (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename) - (LIST (MKSTRING linkString)))))) - (PRIN1 result messageW) - (CLEARW promptW) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN1 "Linking Error" promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow WINDOW)) - (T (PRIN1 "Done: successful link" promptW)))))) - -(MS.CompileLink - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:31") - (* Creates the Compile and Link messages to be sent to - the appropriate host) - (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - filename defaultDirectory host linkString result errorFile errorWindow) - (CLEARW messageW) - - (* * check that all required data is specified) - - - (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PrintMsg WINDOW "Unspecified file name.") - (RETURN))) - (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) - (COND - ((EQUAL defaultDirectory "") - (PrintMsg WINDOW "Unspecified default directory.") - (RETURN))) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - (SETQ linkString (LISTGET state (QUOTE LINKSTRING))) - (COND - ((STRPOS " " linkString) - (PrintMsg WINDOW "Remove spaces from LinkParameters") - (RETURN))) - - (* * check for dirty file in a Fortran Edit) - - - (COND - ((MS.CheckForDirtyFile filename promptW messageW) - (RETURN))) - - (* * send the Compile message) - - - (CLEARW promptW) - (PRIN1 "Compiling source file ..." promptW) - (MS.CloseErrorWindow WINDOW) - (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename))) - (CLEARW messageW) - (PRIN1 result messageW) - (CLEARW promptW) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN1 "Compilation error" promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow WINDOW) - (RETURN)) - (T (PRIN1 "Compile finished. Now linking..." promptW))) - - (* * return the Link message) - - - (COND - ((EQUAL linkString "") - (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename)))) - (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename) - (LIST (MKSTRING linkString)))))) - (CLEARW messageW) - (PRIN1 result messageW) - (CLEARW promptW) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN1 "Linking Error" promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow WINDOW)) - (T (PRIN1 "Done: successful link" promptW)))))) - -(MS.CLR.Check - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "12-Aug-86 10:17") - (* This functin calls MS.CompileLinkRun with the check - flag T) - (MS.CompileLinkRun ITEM WINDOW BUTTONS T))) - -(MS.CLR.NoCheck - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "12-Aug-86 10:18") - (* This functin calls MS.CompileLinkRun with the check - flag NIL) - (MS.CompileLinkRun ITEM WINDOW BUTTONS NIL))) - -(MS.CompileLinkRun - (LAMBDA (ITEM WINDOW BUTTONS checkFlag) (* DSB "15-Apr-87 10:34") - (* Sequentially creates the Compile, Link and RunJob  - messages, to be sent to the appropriate host) - (PROG (state (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - filename defaultDirectory host parameterString linkString result errorFile - errorWindow) - (CLEARW messageW) - - (* * check that all required data is specified) - - - (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PrintMsg WINDOW "Unspecified file name.") - (RETURN))) - (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) - (COND - ((EQUAL defaultDirectory "") - (PrintMsg WINDOW "Unspecified default directory.") - (RETURN))) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - (SETQ linkString (LISTGET state (QUOTE LINKSTRING))) - (COND - ((STRPOS " " linkString) - (PrintMsg WINDOW "Remove spaces from LinkParameters") - (RETURN))) - (SETQ parameterString (LISTGET state (QUOTE PARAMETERSTRING))) - (COND - ((STRPOS "," parameterString) - (PrintMsg WINDOW "Remove comma(s) from JobParameters") - (RETURN))) - - (* * check for dirty file in a Fortran Edit) - - - (COND - ((MS.CheckForDirtyFile filename promptW messageW) - (RETURN))) - - (* * send the Compile message) - - - (CLEARW promptW) - (MS.CloseErrorWindow WINDOW) - (COND - ((AND checkFlag (_ host Compiled? host defaultDirectory filename)) - (PRIN1 "Source file already compiled. " promptW)) - (T (PRIN1 "Compiling source file ..." promptW) - (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename))) - (CLEARW messageW) - (PRIN1 result messageW) - (CLEARW promptW) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN1 "Compilation error" promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Compilation Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow WINDOW) - (RETURN)) - (T (PRIN1 "Compile finished. " promptW))))) - - (* * return the Link message) - - - (COND - ((AND checkFlag (_ host Linked? host defaultDirectory filename)) - (TERPRI promptW) - (PRIN1 " Exec. file exists. Now running it..." promptW)) - (T (PRIN1 " Now linking..." promptW) - (COND - ((EQUAL linkString "") - (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename)))) - (T (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename) - (LIST (MKSTRING linkString)))))) - (CLEARW messageW) - (PRIN1 result messageW) - (CLEARW promptW) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN1 "Linking Error" promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Link Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow WINDOW) - (RETURN)) - (T (PRIN1 "Link finished. Now running job ..." promptW))))) - - (* * return the RunJob message) - - - (COND - ((EQUAL parameterString "") - (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename)))) - (T (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) - defaultDirectory - (QUOTE BODY) - filename) - (LIST (MKSTRING parameterString)))))) - (CLEARW messageW) - (PRIN1 result messageW) - (CLEARW promptW) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN1 "Run-time warning or error" promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Run-time Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow WINDOW)) - (T (PRIN1 "Done" promptW)))))) -) - - - -(* FORTRAN EDITOR FUNCTIONS) - -(DEFINEQ - -(MS.StartNewFE - (LAMBDA NIL (* DSB "21-Aug-86 15:38") - (* starts a new Fortran Edit process without setting  - defaults or getting a file) - (FE.TopLevel))) - -(MS.StartDefaultFE - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Apr-87 10:35") - - (* Starts a FE, sets defaults according to the values in the ServerMenu, and gets the source file named in the  - server menu, if it exists.) - - - (PROG (state textStream host hostname defaultDirectory directory filename name getFilename) - (SETQ textStream (FE.TopLevel)) - (SETQ state (MS.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - (host (TEXTPROP textStream (QUOTE MS.HOST) - host) - (SETQ hostname (_ host Name)) - (TEXTPROP textStream (QUOTE MS.HOSTNAME) - hostname) - (TEXTPROP textStream (QUOTE MS.DIRECTORY) - (_ host UserDirectory)))) - (COND - ((NOT (EQUAL defaultDirectory "")) - (SETQ directory (MKATOM defaultDirectory)) - (TEXTPROP textStream (QUOTE MS.DIRECTORY) - directory))) - (COND - ((NOT (EQUAL filename "")) - (SETQ name (MKATOM filename)))) - (COND - ((AND host directory name) - (SETQ getFilename (PACKFILENAME (QUOTE HOST) - hostname - (QUOTE DIRECTORY) - directory - (QUOTE NAME) - name - (QUOTE EXTENSION) - (_ host SourceExtension))) - (COND - ((INFILEP getFilename) - (TEDIT.GET (TEXTOBJ textStream) - getFilename) - (TEXTPROP textStream (QUOTE FILENAME) - getFilename) - (TEDIT.PROMPTPRINT textStream (CONCAT "Retrieved file " getFilename))) - (T (TEDIT.PROMPTPRINT textStream (CONCAT "File " getFilename " not found"))))))) - )) - -(MS.FindFortranEdit - (LAMBDA (filename) (* DSB "22-Aug-86 09:36") - - (* * searches through all open windows and returns a stream number of a Fortran Edit process whose filename matches - the parameter filename If no such process exists, it returns NIL.) - - - (LET (textStream fullEditFilename editFilename) - (for window in (OPENWINDOWS) do (COND - ((WINDOWPROP window (QUOTE FORTRANEDIT)) - (SETQ textStream (TEXTSTREAM window)) - (SETQ fullEditFilename (TEXTPROP - textStream - (QUOTE FILENAME))) - (SETQ editFilename (UNPACKFILENAME - fullEditFilename - (QUOTE NAME))) - (COND - ((EQUAL (U-CASE editFilename) - (U-CASE (MKATOM filename))) - (RETURN textStream)) - (T NIL)))))))) - -(MS.CheckForDirtyFile - (LAMBDA (filename promptW messageW) (* DSB "22-Aug-86 09:42") - - (* * returns T (to abort the operation) only if there exists a dirty file with the same name and the user does not  - click the left button.) - - - (PROG (textStream dirty) - - (* * see if there is an active FE with filename) - - - (SETQ textStream (MS.FindFortranEdit filename)) - (COND - ((NOT textStream) - (RETURN NIL))) - - (* * if the file has been changed, give the user the option to abort the operation) - - - (SETQ dirty (TEDIT.STREAMCHANGEDP textStream)) - (COND - (dirty (CLEARW promptW) - (COND - ((MOUSECONFIRM "Not saved yet; LEFT to use previous version." T promptW) - (PRIN1 "Using old version on the server" messageW) - (RETURN NIL)) - (T (PRIN1 "Operation aborted. Put file in Fortran Edit to server." messageW) - (RETURN T)))) - (T (PRIN1 "File in Fortran Editor has not been changed. Operation proceeds" messageW) - (RETURN NIL)))))) -) - - - -(* ERROR HANDLING FUNCTIONS) - -(DEFINEQ - -(MS.BatchErrors? - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Aug-86 18:07") - (* If Batch errors have occurred, it displays them in  - the error window) - (PROG ((state (FM.READSTATE WINDOW)) - (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - host defaultDirectory jobNumber errorFile localErrorFile resultFile stream result - errorWindow) - - (* * check that all required data is specified) - - - (CLEARW promptW) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - (SETQ defaultDirectory (LISTGET state (QUOTE DEFAULTDIRECTORY))) - (COND - ((EQUAL defaultDirectory "") - (PrintMsg WINDOW "Unspecified default directory.") - (RETURN))) - (SETQ jobNumber (LISTGET state (QUOTE JOBNUMBER))) - (COND - ((EQUAL jobNumber "") - (SETQ jobNumber NIL) - (PrintMsg WINDOW "Unspecified job number.") - (RETURN))) - - (* * get the error file) - - - (CLEARW promptW) - (CLEARW messageW) - (MS.CloseErrorWindow WINDOW) - (SETQ resultFile (INFILEP (PACKFILENAME (QUOTE HOST) - (_ host Name) - (QUOTE DIRECTORY) - defaultDirectory - (QUOTE NAME) - jobNumber - (QUOTE EXTENSION) - (QUOTE RES)))) - (SETQ errorFile (INFILEP (PACKFILENAME (QUOTE HOST) - (_ host Name) - (QUOTE DIRECTORY) - defaultDirectory - (QUOTE NAME) - jobNumber - (QUOTE EXTENSION) - (QUOTE ERR)))) - (COND - (errorFile (PRIN1 "Retrieving error messages..." promptW) - (SETQ stream (OPENFILE resultFile (QUOTE INPUT))) - (SETQ result (READ stream)) - (CLOSEF stream) - (DELFILE resultFile) - (PRIN1 result messageW) - (SETQ localErrorFile (COPYFILE errorFile (QUOTE {core}localErrorFile))) - (DELFILE errorFile) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Batch Errors")) - (_ host PutErrorInWindow localErrorFile errorWindow WINDOW)) - (T (PRIN1 "No batch errors found" promptW)))))) - -(MS.BatchLog - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Aug-86 18:07") - (* opens a window to display the batch log file) - (PROG ((state (FM.READSTATE WINDOW)) - (promptW (GETPROMPTWINDOW WINDOW)) - (messageW (MS.GetMessageWindow WINDOW)) - filename host logfile localLogfile errorWindow) - - (* * check that all required data is specified) - - - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PrintMsg WINDOW "Unspecified file name.") - (RETURN))) - (SETQ host (FM.ITEMPROP (FM.ITEMFROMID WINDOW (QUOTE HOST)) - (QUOTE Host))) - (COND - ((NOT host) - (PrintMsg WINDOW "Unspecified host.") - (RETURN))) - - (* * get the logfile) - - - (CLEARW promptW) - (CLEARW messageW) - (MS.CloseErrorWindow WINDOW) - (SETQ logfile (INFILEP (PACKFILENAME (QUOTE HOST) - (_ host Name) - (QUOTE DIRECTORY) - (_ host UserDirectory) - (QUOTE BODY) - filename - (QUOTE EXTENSION) - (QUOTE LOG)))) - (COND - (logfile (SETQ localLogfile (COPYFILE logfile (QUOTE {core}localLogfile))) - (DELFILE logfile) - (PRIN1 "fetching Batch Log File..." promptW) - (SETQ errorWindow (MS.AttachErrorWindow WINDOW "Batch Log File")) - (_ host PutErrorInWindow localLogfile errorWindow WINDOW)) - (T (PRIN1 "Batch Log File not found" promptW)))))) -) - - - -(* Icon BITMAPS) - - -(RPAQ MS.Icon (READBITMAP)) -(78 74 -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"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@@@@@@@@O@@@@@@@@@L" -"L@@@@@@@@I@GH@@@@@@L" -"L@@@@@@B@O@DHGH@@@@L" -"L@@@@@@B@O@@HDH@@@@L" -"L@@@@@@B@I@AHGH@@@@L" -"L@@@@@@B@O@C@GH@@@@L" -"L@@@@@@B@@@GLDH@@@@L" -"L@@@@@@B@@@@@GH@@@@L" -"L@@@@@@@@@@D@@@D@@@L" -"L@@@@@@@@@@F@@@L@@@L" -"L@@@@CN@@@@C@DAH@@@L" -"L@@@@@F@@@@A@DA@@@@L" -"L@@@@@L@@@@AHDC@@@@L" -"L@@@@AH@@@@@HDB@@@@L" -"L@@@CA@@@@@@LDF@@@@L" -"L@@@CC@@@@@@D@D@@@@L" -"L@@@@@@@@@@@D@D@CO@L" -"L@@@@@@@@@@@FNL@CO@L" -"L@@@GH@@@@@@BJH@AH@L" -"L@@@DH@@@@@@BJH@AH@L" -"L@@@@H@@@COOOOOOIH@L" -"L@@@AH@@@B@@@@@@IH@L" -"L@@@C@@@@B@@@@@@IH@L" -"L@@@GL@@@B@@@@@@IH@L" -"L@@@@@@@@B@D@@@@IH@L" -"L@@@@@@@@B@D@@L@IH@L" -"L@@@@@@@@B@D@@@@IH@L" -"L@COOOH@@BCOHCO@IH@L" -"L@COOOH@@B@D@@@@IH@L" -"L@CH@CH@@B@D@@L@IH@L" -"L@C@@AH@@B@D@@@@OH@L" -"L@C@@AH@@B@@@@@@OH@L" -"L@C@@AH@@B@@@@@@H@@L" -"L@C@@AH@@B@@@@@@H@@L" -"L@C@@AH@@BBDH@@@H@@L" -"L@C@@AH@@BAE@@@@H@@L" -"L@C@@AH@@B@N@@@@H@@L" -"L@C@@AH@@BCOHCO@H@@L" -"L@C@@AH@@B@N@@@@H@@L" -"L@CH@CKFMJAE@@@@H@@L" -"L@COOOH@@BBDH@@@H@@L" -"L@COOOH@@B@@@@@@H@@L" -"L@@AO@@@@COOOOOOH@@L" -"LAOOOON@@@@@@@@@@@@L" -"LA@@@@B@@@@@@@@@@@@L" -"LA@@@@B@@@@@@@@@@@@L" -"LA@@@@B@@@@@@@@@@@@L" -"LAOOOON@@@@@@@@@@@@L" -"L@@@@@@@@@@@@@@@@@@L" -"L@@@@@@@@@@@@@@@@@@L" -"LC@HNGLICLOCNDBOCN@L" -"LCOIOA@IB@HBBDBHBB@L" -"LBNIAA@ICLNCNFFNCN@L" -"LBDIOA@O@DHCHCLHCH@L" -"LB@IAA@IBDHBLAHHBL@L" -"LB@IAA@ICLOBFAHOBF@L" -"L@@@@@@@@@@@@@@@@@@L" -"L@@@@@@@@@@@@@@@@@@L" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL") - -(RPAQ MS.IconMask (READBITMAP)) -(78 74 -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOH@COOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOO@@AOOOOOOOOOOOOOL" -"OOOH@COOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL" -"OOOOOOOOOOOOOOOOOOOL") - - - -(* VARS) - - -(ADDTOVAR BackgroundMenuCommands (Server% Menu (QUOTE (MS.TopLevel)) - "Start the Server Menu")) - -(RPAQQ BackgroundMenu NIL) -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS MS.HostPopMenu) -) - (* * FORTRAN EDIT - Sets up a Fortran Edit Process) - - - - -(* MAIN FUNCTIONS) - -(DEFINEQ - -(FE.TopLevel - (LAMBDA (program window) (* DSB "22-Aug-86 11:49") - - (* * Edit a Fortran program using a specialized TEdit.) - - - - (* * Program is either a File name, an open Stream, or a string. If NIL, an empty edit window is open.) - - - - (* * Window is an optional window to be used for editing. If NIL, the user will be asked to sweep out a window on  - the screen.) - - - (PROG (editProps editWindow messageWindow processHandle textStream) - - (* * Get prop list for edit props) - - - (SETQ editProps (FE.GetEditProps)) - - (* * Get the window to be used) - - - (SETQ editWindow (FE.GetEditWindow window)) - - (* * Get the message window) - - - (SETQ messageWindow (FE.GetMessageWindow editWindow)) - - (* * Set up the edit process) - - - (SETQ processHandle (TEDIT program editWindow NIL editProps)) - - (* * Get the textstream parameter of the edit process) - - - (SETQ textStream (TEXTSTREAM editWindow)) - - (* * Do any final modifications) - - - (FE.AdjustProps processHandle textStream) - (WINDOWPROP editWindow (QUOTE FORTRANEDIT) - T) - (TEXTPROP textStream (QUOTE EDITWINDOW) - editWindow) - (TEXTPROP textStream (QUOTE MESSAGEWINDOW) - messageWindow) - (TEXTPROP textStream (QUOTE PROCESS) - processHandle) - (TEXTPROP textStream (QUOTE FE.POSITIONWINDOW) - (WINDOWPROP editWindow (QUOTE POSITIONWINDOW))) - - (* * Finally, return the process handle) - - - (RETURN textStream)))) - -(FE.AdjustProps - (LAMBDA (processHandle textStream) (* DSB " 7-Jul-86 15:52") - - (* * Do final adjustments to Fortran editor) - - - (LET NIL - (COND - ((PROCESSP processHandle) - - (* * The following gives the process a name) - - - (PROCESSPROP processHandle (QUOTE NAME) - (QUOTE FORTRAN% EDITOR)) - - (* * The following disables image object insertion into the document) - - - (until (PROCESSPROP processHandle (QUOTE TEDITTTYWINDOW)) do (BLOCK) - finally (WINDOWPROP (PROCESSPROP processHandle (QUOTE TEDITTTYWINDOW)) - (QUOTE COPYINSERTFN) - NIL))))))) - -(FE.CaretPosition - (LAMBDA (textStream) (* DSB " 7-Jul-86 15:48") - - (* * Write the line# and the column# of the position of the caret in Textstream) - - - (PROG* (charWidth column midpoint position positionWindow textWindow (margin 8) - (textStream (TEXTSTREAM textStream))) - (COND - ((AND (TEXTSTREAMP textStream) - (WINDOWP (SETQ positionWindow (TEXTPROP textStream (QUOTE - FE.POSITIONWINDOW))))) - (SETQ textWindow (WINDOWP (CAR (LISTP (fetch (TEXTOBJ \WINDOW) - of (TEXTOBJ textStream)))))) - (SETQ charWidth (CHARWIDTH (CHCON1 "X") - (TEXTPROP textStream (QUOTE FONT)))) - (COND - ((NOT (EQUAL (SETQ position (TEDIT.PARA&CHAR textStream)) - (TEXTPROP textStream (QUOTE FE.POSITION)))) - (SETQ midpoint (IPLUS 3 (IQUOTIENT (IQUOTIENT (WINDOWPROP positionWindow - (QUOTE - WIDTH)) - (CHARWIDTH (CHARCODE - X) - (DSPFONT - NIL - positionWindow))) - 2))) - (SETQ column (IPLUS (QUOTIENT (IDIFFERENCE (DSPXPOSITION NIL textWindow) - margin) - charWidth) - 1)) - (CLEARW positionWindow) - (printout positionWindow .TAB0 0 (COND - ((MINUSP (IDIFFERENCE column (CDR position))) - " ? ") - (T "")) - .CENTER midpoint (CONCAT "L: " (CAR position)) - .TAB0 midpoint .CENTER 0 (CONCAT "C: " (COND - ((NOT (ZEROP charWidth)) - column) - (T -1)))) - (TEXTPROP textStream (QUOTE FE.POSITION) - position))) - (RETURN position)))))) - -(TEDIT.PARA&CHAR - (LAMBDA (TEXTSTREAM SEL) (* RAR " 9-Oct-85 15:49") - - (* * Given a text stream, (and optionally a selection) find the pagagraph %# and ch within paragraph that the caret - is at) - - - (PROG (CH# PC PCTB (TEXTOBJ (TEXTOBJ TEXTSTREAM)) - (PARA# 1) - (CHAR# 1) - (LASTPARACH# 1)) - (SETQ PCTB (fetch PCTB of TEXTOBJ)) - (SETQ PC (ELT PCTB 3)) - (SETQ CH# (TEDIT.GETPOINT TEXTOBJ SEL)) - (COND - ((ZEROP (fetch TEXTLEN of TEXTOBJ)) - (RETURN (CONS 1 0)))) - (RETURN (while PC - do (COND - ((IGREATERP (add CHAR# (fetch PLEN of PC)) - CH#) (* Passed the relevant char; - return a result) - (RETURN (CONS PARA# (IDIFFERENCE CH# LASTPARACH#)))) - (T (* Not past the caret; keep going) - (COND - ((fetch PPARALAST of PC) - (* Crossing a paragraph boundary. - Count (QUOTE em) up.) - (add PARA# 1) - (SETQ LASTPARACH# CHAR#))))) - (SETQ PC (fetch NEXTPIECE of PC)) - finally (RETURN (CONS PARA# (IDIFFERENCE CH# LASTPARACH#)))))))) - -(FE.CharFn - (LAMBDA (textObj charCode) (* DSB " 7-Jul-86 15:51") - - (* * This function filters out the effects of someone trying to alter the "LOOKS" of something in the  - FORTRANEDITOR) - - - (COND - ((ILEQ charCode 127) - charCode)))) - -(FE.GetEditProps - (LAMBDA NIL (* DSB "20-Aug-86 14:19") - - (* * Return a prop list for TEdit call) - - - (PROG (charWidth (font FE.defaultFont)) - (SETQ charWidth (CHARWIDTH (CHCON1 "X") - font)) - (RETURN (APPEND (QUOTE (CLEARGET T)) - (QUOTE (CLEARPUT T)) - (LIST (QUOTE FONT) - font) - (LIST (QUOTE MENU) - (FE.CreateLocalMenu)) - (LIST (QUOTE PARALOOKS) - (LIST (QUOTE TABS) - (CONS (ITIMES 8 charWidth) - NIL))) - (LIST (QUOTE LOOPFN) - (FUNCTION FE.LoopFn)) - (LIST (QUOTE CHARFN) - (FUNCTION FE.CharFn)) - (QUOTE (COPYBYBKSYSBUF T)) - (LIST (QUOTE READTABLE) - (PROG ((table (COPYREADTABLE TEDIT.READTABLE))) - - (* * Return the read table to be used with this process) - - - (TEDIT.SETSYNTAX 15 NIL table) - (* Turns of inserting with CTRL-O) - (RETURN table)))))))) - -(FE.GetSourceFileName - (LAMBDA (textObj) (* DSB "22-Aug-86 14:08") - - (* * Return filename associated with textObj) - - - - (* * Due to a TEDIT bug, we can't use (FULLNAME (fetch TXTFILE of textObj)), because this can be changed when a  - file is opened to the same non-leaf server. Thus, we use the same FILENAME textprop that FE.MyPut uses and FE.MyGet - updates.) - - - (PROG (fileStream textStream filename messageWindow promptWindow dirty) - - (* * Make sure we have a text object) - - - (COND - ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) - (RETURN NIL))) - - (* * See if the file is ready to use) - - - (SETQ fileStream (fetch TXTFILE of textObj)) - (SETQ textStream (TEXTSTREAM textObj)) - (SETQ filename (TEXTPROP textStream (QUOTE FILENAME))) - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - (SETQ promptWindow (fetch PROMPTWINDOW of textObj)) - (CLEARW promptWindow) - (SETQ dirty (TEDIT.STREAMCHANGEDP textStream)) - (COND - ((NOT dirty) - (RETURN filename))) - (COND - ((AND dirty (NOT fileStream)) - (PRIN1 "Can't. No file has been saved yet." promptWindow) - (RETURN NIL))) - (COND - ((AND dirty fileStream) - (COND - ((MOUSECONFIRM "Not saved yet; LEFT to use previous version." T promptWindow) - (PRIN1 "Using old version on the server" messageWindow) - (RETURN filename)) - (T (RETURN NIL)))))))) - -(FE.LoopFn - (LAMBDA (textStream) (* DSB " 7-Jul-86 17:08") - - (* * Things to be done each time around TEdit command loop) - - - (LET NIL - - (* * Shade the edit window) - - - (FE.ShadeWindow textStream) - - (* * Update the position display) - - - (FE.CaretPosition textStream)))) -) - - - -(* WINDOW FUNCTIONS) - -(DEFINEQ - -(FE.GetPositionWindow - (LAMBDA (mainWindow) (* DSB " 7-Jul-86 17:13") - - (* * Return the window to be used as the caret-position indicator window) - - - (PROG (height positionWindow (font FE.defaultFont)) - (SETQ height (HEIGHTIFWINDOW (FONTPROP font (QUOTE HEIGHT)))) - (SETQ positionWindow (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW - (WINDOWPROP mainWindow - (QUOTE WIDTH))) - height) - NIL NIL T)) - (DSPFONT font positionWindow) - (DSPTEXTURE BLACKSHADE positionWindow) - (DSPOPERATION (QUOTE INVERT) - positionWindow) - (WINDOWPROP positionWindow (QUOTE CLOSEFN) - (QUOTE (DETACHWINDOW))) - (WINDOWPROP positionWindow (QUOTE MINSIZE) - (CONS 0 height)) - (WINDOWPROP positionWindow (QUOTE MAXSIZE) - (CONS 64000 height)) - (WINDOWPROP positionWindow (QUOTE PAGEFULLFN) - (FUNCTION NILL)) - (RETURN positionWindow)))) - -(FE.GetEditWindow - (LAMBDA (window) (* DSB "15-Aug-86 09:19") - - (* * Return a window to be used by the Fortran editor) - - - (PROG (fontHeight minWidth minHeight positionWindow (font FE.defaultFont)) - - (* * Set the minimum window dimensions to be 20 characters wide by four lines high) - - - (SETQ minWidth (WIDTHIFWINDOW (ITIMES 20 (CHARWIDTH (CHCON1 "X") - font)))) - (SETQ minHeight (HEIGHTIFWINDOW (ITIMES 4 (SETQ fontHeight (FONTPROP - font - (QUOTE HEIGHT)))) - T)) - - (* * If not passed a window, then create one) - - - (COND - ((NOT (WINDOWP window)) - (SETQ window (CREATEW (GETREGION minWidth minHeight) - (QUOTE Fortran% Editor) - NIL T)))) - - (* * Add our window properties) - - - (WINDOWADDPROP window (QUOTE RESHAPEFN) - (FUNCTION FE.ReshapeFn)) - (WINDOWPROP window (QUOTE ICONFN) - (FUNCTION FE.ShrinkIconCreate)) - (WINDOWPROP window (QUOTE MINSIZE) - (CONS minWidth minHeight)) - - (* * Now add a window for displaying the caret position) - - - (SETQ positionWindow (FE.GetPositionWindow window)) - (ATTACHWINDOW positionWindow window (QUOTE TOP) - (QUOTE JUSTIFY)) - (WINDOWPROP positionWindow (QUOTE PASSTOMAINCOMS) - T) (* needed due to bug in ATTACHWINDOW which does not  - set the prop correctly when WINDOWCOMACTION=MAIN) - (WINDOWPROP window (QUOTE POSITIONWINDOW) - positionWindow) - - (* * Return the main window) - - - (RETURN window)))) - -(FE.GetMessageWindow - (LAMBDA (editWindow) (* DSB "19-Aug-86 17:55") - - (* * Create, attach, and return the messageWindow on the bottom of the editWindow) - - - (PROG (messageWindow) - (SETQ messageWindow (CREATEW (CREATEREGION 0 0 200 60) - "Message Window" NIL T)) - (ATTACHWINDOW messageWindow editWindow (QUOTE BOTTOM) - (QUOTE JUSTIFY)) - (RETURN messageWindow)))) - -(FE.ReshapeFn - (LAMBDA (window oldImage oldRegion) (* DSB " 7-Jul-86 17:23") - - (* * Need to set the TEXTPROP FE.POSITION to Nil to force position update following reshape of main window) - - - (TEXTPROP (TEXTSTREAM window) - (QUOTE FE.POSITION) - NIL))) - -(FE.ShadeWindow - (LAMBDA (stream) (* DSB " 7-Jul-86 17:28") - - (* * Highlight the sixth and seventy-third columns of the editor window) - - - (PROG (charWidth height window (margin 8) - (textObj (TEXTOBJ stream))) - (SETQ window (CAR (fetch (TEXTOBJ \WINDOW) of textObj))) - (SETQ charWidth (CHARWIDTH (CHCON1 "X") - (TEXTPROP textObj (QUOTE FONT)))) - (SETQ height (WINDOWPROP window (QUOTE HEIGHT))) - (BITBLT NIL NIL NIL window (IPLUS margin (ITIMES 5 charWidth)) - 0 1 height (QUOTE TEXTURE) - (QUOTE REPLACE) - GRAYSHADE) - (BITBLT NIL NIL NIL window (SUB1 (IPLUS margin (ITIMES 6 charWidth))) - 0 1 height (QUOTE TEXTURE) - (QUOTE REPLACE) - GRAYSHADE) - (BITBLT NIL NIL NIL window (IPLUS margin (ITIMES 72 charWidth)) - 0 1 height (QUOTE TEXTURE) - (QUOTE REPLACE) - GRAYSHADE)))) -) - - - -(* LOCALMENU FUNCTIONS) - -(DEFINEQ - -(FE.CreateLocalMenu - (LAMBDA NIL (* DSB " 7-Nov-86 09:42") - - (* * Return the local menu that pops up when the left or middle buttons are pressed when the mouse pointer is in  - the title bar area of the Fortran editor window.) - - - (create MENU - ITEMS _(QUOTE (Quit Hardcopy (Put (FUNCTION FE.MyPut) - "Write edit buffer to specified file") - (Get (FUNCTION FE.MyGet) - - "Replace contents of edit buffer with contents of specified file") - (Include (QUOTE Include) - - "Add contents of specified file to edit buffer at present location") - (Find (QUOTE Find) - - "Find first occurence of specified string beyond present location") - (Substitute (QUOTE Substitute) - - "Replace all occurances of specified string with new string in selected text") - (Host (FUNCTION FE.SetHost) - "Declare host server") - (Directory (FUNCTION FE.SetDirectory) - "Declare host directory") - (Compile (FUNCTION FE.Compile) - "Compile file on host") - (Link (FUNCTION FE.Link) - "Link file on host") - (C/L/R (FUNCTION FE.CompileLinkRun) - "Compile,link and run file on host") - (Run (FUNCTION FE.RunInteractive) - "Run file on host"))) - CENTERFLG _ T - MENUFONT _(FONTCREATE (QUOTE HELVETICA) - 10 - (QUOTE BOLD)) - WHENSELECTEDFN _(FUNCTION \TEDIT.MENU.WHENSELECTEDFN) - WHENHELDFN _(FUNCTION \TEDIT.MENU.WHENHELDFN)))) - -(FE.SetHost - (LAMBDA (textStream) (* DSB "22-Aug-86 13:07") - - (* * Ask user to declare a host server, using the present host server as a default answer.) - - - - (* * the host, hostname and default directory are all calculated and stored as TEXTPROPs) - - - - (* * Note that FE.GetServer returns the pointer to the server instance. When the message is sent to host, host is  - evaled.) - - - - (* * Note also that hostname must be an upper-case atom when it is passed to FE.ValidHostname and FE.GetServer) - - - (PROG (messageWindow host hostname (oldHostname (TEXTPROP textStream (QUOTE MS.HOSTNAME)))) - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - (COND - ((FE.ValidHostname (SETQ hostname (U-CASE (MKATOM (TEDIT.GETINPUT textStream - "Hostname :" - oldHostname) - )))) - (TEXTPROP textStream (QUOTE MS.HOSTNAME) - hostname) - (SETQ host (FE.GetServer hostname)) - (TEXTPROP textStream (QUOTE MS.HOST) - host) - (TEXTPROP textStream (QUOTE MS.DIRECTORY) - (_ host UserDirectory)) - (TEDIT.PROMPTPRINT textStream (CONCAT "Hostname is " hostname) - T)) - (T (TEDIT.PROMPTPRINT textStream (CONCAT hostname - " is not valid...Hostname unchanged") - T))) - (RETURN NIL)))) - -(FE.SetDirectory - (LAMBDA (textStream) (* DSB "22-Aug-86 13:09") - - (* * ask user to declare a default directory, using the previously defined directory as a default. - The default is initially set to the user's root directory when the host is declared.) - - - (PROG (messageWindow newDirectory (oldDirectory (TEXTPROP textStream (QUOTE MS.DIRECTORY))) - (host (TEXTPROP textStream (QUOTE MS.HOST)))) - - (* * first clear the message window) - - - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - - (* * then make sure a host has been declared) - - - (COND - ((NOT host) - (RETURN (TEDIT.PROMPTPRINT textStream - "No host has yet been declared. Name your host first." - T)))) - - (* * then reset directory if changed) - - - (SETQ newDirectory (MKATOM (TEDIT.GETINPUT textStream "Directory: " oldDirectory))) - (COND - ((EQUAL newDirectory oldDirectory) - (TEDIT.PROMPTPRINT textStream (CONCAT newDirectory - " is the same as the previous value...Directory unchanged") - T)) - (T (TEXTPROP textStream (QUOTE MS.DIRECTORY) - newDirectory) - (TEDIT.PROMPTPRINT textStream (CONCAT "Directory is " newDirectory) - T)))))) - -(FE.MyGet - (LAMBDA (textStream) (* DSB "22-Aug-86 12:59") - (* My TEDIT Get Function) - - (* * after getting the file, it sets the FILENAME textprop to the new fullFilename. This textprop is only changed  - by a Get, whereas due to an error in TEDIT, the TXTFILE slot of textObj can change whenever an OPENFILE is made to  - the server) - - - - (* * Note that we only store the versionless filename, because it then gets updated properly on a Put.) - - - (PROG (messageWindow textObj fileStream fullFilename versionlessFilename) - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - (SETQ textObj (TEXTOBJ textStream)) - (TEDIT.GET textObj) - (SETQ fileStream (fetch TXTFILE of textObj)) - (SETQ fullFilename (FULLNAME fileStream)) - (SETQ versionlessFilename (FE.StripVersion fullFilename)) - (TEXTPROP textStream (QUOTE FILENAME) - versionlessFilename)))) - -(FE.MyPut - (LAMBDA (textStream) (* DSB " 7-Nov-86 11:03") - (* my TEDIT put function) - - (* * When the edit buffer is to be saved for the first time, the FILENAME TEXTPROP is NIL. Subsequently, it has a  - (versionless) value, which remains the same if put the the same filename or is altered if put to a different  - filename) - - - - (* * The new filename is stored without version number in the FILENAME field of TEXTPROP) - - - - (* * The reason for this stuff is that the name in (FULLNAME (fetch TXTFILE of textObj)) can be altered by an  - OPENFILE, when both files are on a non-leaf server. Thus, we have to keep track of the TEDIT filename ourselves.) - - - (PROG (messageWindow newFilename textObj fileStream fullFilename versionlessFilename) - - (* * first clear the message window) - - - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - - (* * get the filename to be put. If the user inputs a c.r., it returns the old filename; otherwise, it retains the  - user input.) - - - (SETQ oldFilename (TEXTPROP textStream (QUOTE FILENAME))) - (SETQ newFilename (MKATOM (U-CASE (TEDIT.GETINPUT textStream "(Put) Filename:" - oldFilename)))) - - (* * put the returned filename) - - - (TEDIT.PUT textStream newFilename NIL T) - - (* * a new FILENAME textprop is saved only when the new filename differs from the old filename) - - - (COND - ((EQUAL oldFilename newFilename) - (RETURN)) - (T (SETQ textObj (TEXTOBJ textStream)) - (SETQ fileStream (fetch TXTFILE of textObj)) - (SETQ fullFilename (FULLNAME fileStream)) - (SETQ versionlessFilename (FE.StripVersion fullFilename)) - (TEXTPROP textStream (QUOTE FILENAME) - versionlessFilename)))))) - -(FE.StripVersion - (LAMBDA (fullFilename) (* DSB "20-Aug-86 13:50") - (* returns a filename with the version stripped number - out) - (PROG (host directory name extension) - (SETQ host (UNPACKFILENAME fullFilename (QUOTE HOST))) - (SETQ directory (UNPACKFILENAME fullFilename (QUOTE DIRECTORY))) - (SETQ name (UNPACKFILENAME fullFilename (QUOTE NAME))) - (SETQ extension (UNPACKFILENAME fullFilename (QUOTE EXTENSION))) - (RETURN (PACKFILENAME (QUOTE HOST) - host - (QUOTE DIRECTORY) - directory - (QUOTE NAME) - name - (QUOTE EXTENSION) - extension))))) - -(FE.Compile - (LAMBDA (textStream) (* DSB "22-Aug-86 11:54") - - (* * Compile the file associated with this edit process.) - - - (PROG (fullFilename filename directory host result errorFile errorWindow editWindow - messageWindow (textObj (TEXTOBJ textStream))) - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - - (* * Make sure we have a text object) - - - (COND - ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) - (PRIN1 "No text to compile" messageWindow) - (RETURN NIL))) - - (* * See if the file is ready to use) - - - (COND - ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj))) - (PRIN1 "Text non-existant or unsaved: compile aborted" messageWindow) - (RETURN NIL))) - - (* * Check that a host has been specified) - - - (COND - ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST)))) - (PRIN1 "Can't compile. No Host has been declared" messageWindow) - (RETURN NIL))) - - (* * Do the compile) - - - (TEDIT.PROMPTPRINT textStream (CONCAT "Compiling " fullFilename " on " - (_ host Name) - "...") - T) - (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW))) - (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY))) - (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME))) - (MS.CloseErrorWindow editWindow) - (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) - directory - (QUOTE NAME) - filename))) - (CLEARW messageWindow) - (PRIN1 result messageWindow) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (TEDIT.PROMPTPRINT textStream "Compilation errors" T) - (SETQ errorWindow (MS.AttachErrorWindow editWindow "Compilation Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow editWindow)) - (T (TEDIT.PROMPTPRINT textStream "Successful compilation." T)))))) - -(FE.Link - (LAMBDA (textStream) (* DSB "22-Aug-86 12:01") - - (* * Link the file associated with this edit process.) - - - (PROG (fullFilename filename directory host result errorFile errorWindow editWindow - messageWindow (textObj (TEXTOBJ textStream))) - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - - (* * Make sure we have a text object) - - - (COND - ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) - (PRIN1 "No file to link" messageWindow) - (RETURN NIL))) - - (* * See if the file is ready to use) - - - (COND - ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj))) - (PRIN1 "File non-existant or unsaved: link aborted" messageWindow) - (RETURN NIL))) - - (* * Check that a host has been specified) - - - (COND - ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST)))) - (PRIN1 "Can't link. No Host has been declared" messageWindow) - (RETURN NIL))) - - (* * Do the link) - - - (TEDIT.PROMPTPRINT textStream (CONCAT "Linking " fullFilename " on " - (_ host Name) - "...") - T) - (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW))) - (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY))) - (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME))) - (MS.CloseErrorWindow editWindow) - (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) - directory - (QUOTE NAME) - filename))) - (CLEARW messageWindow) - (PRIN1 result messageWindow) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (TEDIT.PROMPTPRINT textStream "Linking error" T) - (SETQ errorWindow (MS.AttachErrorWindow editWindow "Link Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow editWindow)) - (T (TEDIT.PROMPTPRINT textStream "Successful link" T)))))) - -(FE.CompileLinkRun - (LAMBDA (textStream) (* DSB "22-Aug-86 11:54") - - (* * sequentially compiles, links, and runs the file associated with this edit process.) - - - (PROG (fullFilename filename directory host result errorFile errorWindow editWindow - messageWindow (textObj (TEXTOBJ textStream))) - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - - (* * Make sure we have a text object) - - - (COND - ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) - (PRIN1 "No text to compile" messageWindow) - (RETURN NIL))) - - (* * See if the file is ready to use) - - - (COND - ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj))) - (PRIN1 "Text non-existant or unsaved: compile aborted" messageWindow) - (RETURN NIL))) - - (* * Check that a host has been specified) - - - (COND - ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST)))) - (PRIN1 "Can't compile. No Host has been declared" messageWindow) - (RETURN NIL))) - - (* * Do the compile) - - - (TEDIT.PROMPTPRINT textStream (CONCAT "Compiling " fullFilename " on " - (_ host Name) - "...") - T) - (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW))) - (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY))) - (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME))) - (MS.CloseErrorWindow editWindow) - (SETQ result (_ host Compile (PACKFILENAME (QUOTE DIRECTORY) - directory - (QUOTE NAME) - filename))) - (CLEARW messageWindow) - (PRIN1 result messageWindow) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (TEDIT.PROMPTPRINT textStream "Compilation errors" T) - (SETQ errorWindow (MS.AttachErrorWindow editWindow "Compilation Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow editWindow) - (RETURN)) - (T (TEDIT.PROMPTPRINT textStream "Successful compilation." T))) - - (* * Do the link) - - - (TEDIT.PROMPTPRINT textStream (CONCAT "Linking " fullFilename " on " - (_ host Name) - "...") - T) - (MS.CloseErrorWindow editWindow) - (SETQ result (_ host Link (PACKFILENAME (QUOTE DIRECTORY) - directory - (QUOTE NAME) - filename))) - (CLEARW messageWindow) - (PRIN1 result messageWindow) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (TEDIT.PROMPTPRINT textStream "Linking error" T) - (SETQ errorWindow (MS.AttachErrorWindow editWindow "Link Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow editWindow) - (RETURN)) - (T (TEDIT.PROMPTPRINT textStream "Successful link" T))) - - (* * Run the job interactively) - - - (TEDIT.PROMPTPRINT textStream (CONCAT "Running interactive job " fullFilename " on " - (_ host Name) - "...") - T) - (MS.CloseErrorWindow editWindow) - (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) - directory - (QUOTE NAME) - filename))) - (CLEARW messageWindow) - (PRIN1 result messageWindow) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (TEDIT.PROMPTPRINT textStream "Run-time warning or error" T) - (SETQ errorWindow (MS.AttachErrorWindow editWindow "Run-time Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow editWindow)) - (T (TEDIT.PROMPTPRINT textStream "Done" T)))))) - -(FE.RunInteractive - (LAMBDA (textStream) (* DSB "22-Aug-86 12:49") - - (* * Run (interactively) the file associated with this edit process.) - - - (PROG (fullFilename filename directory host result errorFile errorWindow editWindow - messageWindow (textObj (TEXTOBJ textStream))) - (SETQ messageWindow (TEXTPROP textStream (QUOTE MESSAGEWINDOW))) - (CLEARW messageWindow) - - (* * Make sure we have a text object) - - - (COND - ((NOT (TYPENAMEP textObj (QUOTE TEXTOBJ))) - (PRIN1 "No file to run" messageWindow) - (RETURN NIL))) - - (* * See if the file is ready to use) - - - (COND - ((NOT (SETQ fullFilename (FE.GetSourceFileName textObj))) - (PRIN1 "File non-existant or unsaved: run aborted" messageWindow) - (RETURN NIL))) - - (* * Check that a host has been specified) - - - (COND - ((NOT (SETQ host (TEXTPROP textObj (QUOTE MS.HOST)))) - (PRIN1 "Can't run. No Host has been declared" messageWindow) - (RETURN NIL))) - - (* * Run it) - - - (TEDIT.PROMPTPRINT textStream (CONCAT "Running interactive job " fullFilename " on " - (_ host Name) - "...") - T) - (SETQ editWindow (TEXTPROP textStream (QUOTE EDITWINDOW))) - (SETQ directory (TEXTPROP textObj (QUOTE MS.DIRECTORY))) - (SETQ filename (UNPACKFILENAME fullFilename (QUOTE NAME))) - (MS.CloseErrorWindow editWindow) - (SETQ result (_ host RunJob (PACKFILENAME (QUOTE DIRECTORY) - directory - (QUOTE NAME) - filename))) - (CLEARW messageWindow) - (PRIN1 result messageWindow) - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (TEDIT.PROMPTPRINT textStream "Run-time warning or error" T) - (SETQ errorWindow (MS.AttachErrorWindow editWindow "Run-time Errors")) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow editWindow)) - (T (TEDIT.PROMPTPRINT textStream "Done" T)))))) -) - - - -(* SERVER METACLASS FUNCTIONS) - -(DEFINEQ - -(FE.ValidHostname - (LAMBDA (hostname) (* DSB "20-Aug-86 08:40") - (* returns the hostname if it is on the list of valid  - hosts) - - (* * Note that hostname must be passed from FE.SetHost as an upper-case atom) - - - (PROG (server validHostname) - (SETQ server (FE.GetServer hostname)) - (COND - (server (SETQ validHostname (_ server Name)) - (RETURN validHostname)) - (T NIL))))) - -(FE.GetServer - (LAMBDA (hostname) (* DSB "20-Aug-86 08:42") - (* given a hostname, returns the pointer to the  - server) - - (* * note that the hostname must be an upper-case atom) - - - (find server in (_ ($ Server) - AllInstances!) - suchthat (EQUAL hostname (_ server Name))))) -) - - - -(* ICON STUFF) - -(DEFINEQ - -(FE.ShrinkIconCreate - (LAMBDA (W ICON ICONW) (* DSB " 6-Oct-86 13:52") - (* Create the icon that represents this window.) - (PROG ((icon (WINDOWPROP W (QUOTE ICON))) - (iconTitle (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE))) - (shrinkfn (WINDOWPROP W (QUOTE SHRINKFN)))) - (COND - ((NOT (WINDOWPROP W (QUOTE TEXTOBJ))) (* This isn't really a TEdit window any more. - Don't do anything) - NIL) - ((WINDOWPROP W (QUOTE TEDITMENU)) (* This is a text menu, and shrinks without trace.) - NIL) - ((OR (IGREATERP (FLENGTH shrinkfn) - 3) - (AND (NOT (FMEMB (QUOTE SHRINKATTACHEDWINDOWS) - shrinkfn)) - (IGREATERP (FLENGTH shrinkfn) - 2))) (* There are other functions that expect to handle  - this. Don't bother.) - NIL) - ((OR (AND iconTitle (EQUAL iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W)))) - (AND (NOT iconTitle) - icon)) (* we built this and the title is the same, or he has  - already put an icon on this. - Do nothing) - NIL) - (icon (* There's an existing icon window; - change the title in it) - (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE) - (SETQ iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W)))) - (ICONTITLE iconTitle NIL NIL icon)) - (T (* install a new icon) - (WINDOWPROP W (QUOTE TEDIT.ICON.TITLE) - (SETQ iconTitle (TEXTSTREAM.TITLE (TEXTSTREAM W)))) - (WINDOWPROP W (QUOTE ICON) - (TITLEDICONW FE.titledIconTemplate iconTitle FE.iconFont NIL T - (QUOTE TOP)))))) - (WINDOWPROP W (QUOTE ICON)))) -) - -(RPAQ FE.Icon (READBITMAP)) -(120 61 -"@@@COOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@@@GOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@@@N@CHCHAL@L@O@GCION@C@CHAHAO@@" -"@@AN@C@AH@L@L@F@CCION@C@AHAHAO@@" -"@@CNGOCIILOCLNFGCAIONGOCINGNGO@@" -"@@GN@GCIILOCLNFGC@ION@GCINGNGO@@" -"@@ON@GCIH@OCL@F@C@AON@GCINGNGO@@" -"@AONGOCIHAOCL@N@CBAONGOCINGNGO@@" -"@CONGOCIIAOCLHNGCCAONGOCINGNGO@@" -"@GONGO@AIHOCLLFGCCION@C@AHANGO@@" -"@OONGOHCILGCLNBGCCION@C@CHANGO@@" -"AOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"CN@@@@@@@@@@@@@@@@@@@B@@@@@@@A@@" -"GN@@@@@@@@@@@@@@@@@B@@@@@@@@@A@@" -"OJ@@@@@@@@@@@@@@@@@B@@@@@@@@@A@@" -"OJ@@@@@@@@@@@@@@@@@@H@@@@@@@@A@@" -"NJ@@@@@@@@@@@@@@@@@@H@@@@@@@@A@@" -"NJ@H@@@@@@@B@@@@@@@H@@H@@@@@@A@@" -"JJ@H@@@@@@@B@@@@@@@H@@H@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"KJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@H@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@H@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@H@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@H@@@@@B@H@@@@@@@@@@@@A@@" -"JN@@@@@@@@@@@@B@H@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJB@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"NJB@@@@B@B@H@B@@@B@@@@@@@@@@@A@@" -"JJ@@@@@B@B@H@B@@@B@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@BH@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@BH@@@@@H@@@@B@@@@B@@@@@@@@A@@" -"JJ@@@@@@@@H@@@@B@@@@B@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@B@@@@@@A@@" -"JJH@@@@@@@@@@@@@@@@@@@B@@@@@@A@@" -"JJH@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@B@@@@@@@@@@@@@@@@@@@@@@A@@" -"JJ@@@@B@@@@@@@@@@@@@@H@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@H@@@@@@@A@@" -"JJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"KJ@@@@@@@@@@@@@@@@@@@@@@@@@@@A@@" -"JKOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"JH@@@@@D@@@@@@@@A@@@@@@@@@H@@D@@" -"JOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@" -"J@@@@@@@@@@D@@@@@@D@@@@D@@@@A@@@" -"KOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@" -"H@@@A@@@@@@@@@@@H@@@@@@@@@@BD@@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@") - -(RPAQ FE.IconMask (READBITMAP)) -(120 61 -"@@@COOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@@@GOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@@@OOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@@AOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@@COOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@@GOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@@OOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@AOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@COOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@GOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"@OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"AOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"COOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"GOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@" -"OOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@") - -(RPAQ? FE.defaultFont (FONTCLASS (QUOTE FORTRANEDITFONT) - (QUOTE (1 (GACHA 12) - (GACHA 10) - (GACHA 10))))) - -(RPAQ? FE.iconFont (FONTCREATE (QUOTE HELVETICA) - 8 - (QUOTE BOLD))) - -(RPAQ? FE.iconTitleRegion (create REGION LEFT _ 8 BOTTOM _ 8 WIDTH _ 110 HEIGHT _ 40)) - -(RPAQ? FE.titledIconTemplate (create TITLEDICON ICON _ FE.Icon MASK _ FE.IconMask TITLEREG _ - FE.iconTitleRegion)) - - - -(* VARS) - - -(ADDTOVAR BackgroundMenuCommands (Fortran% Edit (QUOTE (FE.TopLevel)) - "Start a Fortran Edit")) - -(RPAQQ BackgroundMenu NIL) -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS FE.defaultFont FE.iconFont FE.titledIconTemplate TEDIT.READTABLE) -) - (* * SERVERS -- Defines the Loops MathServer objects) - -(DEFCLASSES Cray FortranServer MathServer Server VMSServer) -[DEFCLASS Cray - (MetaClass Class doc (* If you want something to be done quickly, use this  - class) - Edited: (* DSB "30-May-86 14:55")) - (Supers MathServer)] - -[DEFCLASS FortranServer - (MetaClass Class Edited: (* DSB "13-May-86 16:09")) - (Supers Server)] - -[DEFCLASS MathServer - (MetaClass Class Edited: (* DSB "20-May-86 17:21")) - (Supers Server) - (ClassVariables (jobManagerProcess NIL doc - - (* the current process on which the job manager is working. All processes alert the job manager by calling the  - AlertManager method and giving this variable as an argument) - -))] - -[DEFCLASS Server - (MetaClass AbstractClass Edited: (* DSB "10-Nov-86 08:20")) - (Supers IndexedObject Object) - (InstanceVariables (host NIL doc (* network name of host ; eg., GSLVAX)) - (name NIL doc (* vernacular name of host; - eg., GSLVAX)) - (description NIL doc (* short description of server)) - (serverDirectory NIL doc (* directory for server command files)) - (queues NIL doc (* list of names of batch queues)) - (sourceExtension NIL doc (* default extension, such as FOR, for source files) - ) - (commandFileExtension NIL doc (* default extension, such as COM, for command files) - ))] - -[DEFCLASS VMSServer - (MetaClass Class doc (* this is a DEC VMS machine) - Edited: (* DSB "10-Nov-86 08:22")) - (Supers MathServer FortranServer) - (InstanceVariables (sourceExtension FOR doc (* VMS fortran extension)) - (commandFileExtension COM doc (* VMS command file default extension)) - (comFileName (SUBMITJOB submitJob.com ABORTJOB abortJob.com RUNJOB runJob.com - STATUS status.com LINK link.com COMPLINK complink.com - COMPILE compile.com GETTIME getTime.com) - doc (* VMS com files) - ) - (resultFileName (SUBMITJOB submitJob.res ABORTJOB abortJob.res RUNJOB - runJob.res STATUS status.res COMPILE compile.res - LINK link.res COMPLINK complink.res GETTIME - getTime.res) - doc (* VMS result files) - ))] - -[METH FortranServer Compile (filename) - (* compiles file, which must be on the host)] - - -[METH FortranServer Compiled? (host defaultDirectory filename) - (* Checks if an object file exists on the host. If so, returns T)] - - -[METH FortranServer Link (filename linkedFilesList) - (* links object files on the host into an executable file)] - - -[METH FortranServer Linked? (host defaultDirectory filename) - (* Checks if an executable file exists on the host. If so, returns T)] - - -[METH MathServer AlertManager NIL - (* This method is called by all job processes. It starts up the JobManager process if not - awakened, and passes the jobManagerProcess variable.)] - - -[METH Server AbortJob (jobNumber queue) - (* aborts specific batch job on stated queue) - (category MainOps)] - - -[METH Server CommandFileExtension NIL - (* returns the extension recognized by the system as a command file)] - - -[METH Server Description NIL - (* returns description of the server)] - - -[METH Server Error? (result) - (* checks if CAR of result list is "ERROR") - (category Results)] - - -[METH Server ErrorFile (result) - (* returns the full name of the error file, specified by the third element in the result list) - (category Results)] - - -[METH Server ErrorString (result) - (* returns the error string: the second element in result list) - (category Results)] - - -[METH Server ExecuteCommandFile (commandFile parameterList) - (* method to run a command file. The command string is assembled by the local method - CommandString)] - - -[METH Server ExtractFilename (result) - (* Extract error file name from result)] - - -[METH Server GetQueues NIL - (* returns the list of queues for the server) - (category Name)] - - -[METH Server GetTime NIL - (* gets the time from the server) - (category MainOps)] - - -[METH Server Host NIL - (* returns local server instance variable host) - (category Name)] - - -[METH Server MakeError (string fileName) - (* makes an ERROR ... list) - (category Results)] - - -[METH Server MakeFullName (fileName directory) - (* Constructs full name of file and host) - (category Name)] - - -[METH Server MakePartialName (fileName directory) - (* Constructs name of file with directory, but without host)] - - -[METH Server Name NIL - (* returns vernacular server name) - (category Name)] - - -[METH Server PutErrorInWindow (errorFile errorWindow mainWindow) - (* puts text of errorFile in a window)] - - -[METH Server PutTextInWindow (filename position) - (* Opens a scrollable TEDIT window for the file)] - - -[METH Server Result (result) - (* returns the second element in the result list when there is no error. This is typically the - jobID.) - (category Results)] - - -[METH Server RunFile (file parameterList resultFile noErrorFlg) - (* general method to run a command file and get result and errors) - (category MainOps)] - - -[METH Server RunJob (filename parameterList) - (* runs com file, "filename" , with additional parameters "parameterList" , all of which must - be on the host, as an interactive-type job) - (category MainOps)] - - -[METH Server ServerDirectory NIL - (* returns the name of the server directory for command files) - (category Name)] - - -[METH Server SourceExtension NIL - (* returns default extension for source files)] - - -[METH Server Status (jobNumber) - (* get machine status of batch jobs) - (category MainOps)] - - -[METH Server SubmitJob (filename queue parameterList) - (* submits file, which must be on the host, as a batch job) - (category MainOps)] - - -[METH Server UserDirectory NIL - (* Gets user name on appropriate host) - (category Name)] - - -[METH VMSServer MakeCommandString (commandFile parameterList) - (* assembles command string from given name of commandFile and parameterList)] - - -(DEFINEQ - -(FortranServer.Compile - (Method ((FortranServer Compile) - self filename) (* DSB " 5-Aug-86 10:44") - (* compiles file, which must be on the host) - (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) - (QUOTE COMPILE)) - (_ self ServerDirectory)) - filename - (_ self MakeFullName (LISTGET (@ resultFileName) - (QUOTE COMPILE))) - T))) - -(FortranServer.Compiled? - (Method ((FortranServer Compiled?) - self host defaultDirectory filename) (* DSB "12-Aug-86 09:46") - (* Checks if an object file exists on the host. - If so, returns T) - (INFILEP (PACKFILENAME (QUOTE HOST) - (_ host Name) - (QUOTE DIRECTORY) - defaultDirectory - (QUOTE NAME) - filename - (QUOTE EXTENSION) - (QUOTE OBJ))))) - -(FortranServer.Link - (Method ((FortranServer Link) - self filename linkedFilesList) (* DSB " 8-Aug-86 09:33") - (* links object files on the host into an executable  - file) - - (* * linkedFilesList is either NIL or a list composed of a single string. The parameterList sent to RunFile is thus - a list composed of the filename and optional string of linked files.) - - - (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) - (QUOTE LINK)) - (_ self ServerDirectory)) - (CONS filename linkedFilesList) - (_ self MakeFullName (LISTGET (@ resultFileName) - (QUOTE LINK))) - T))) - -(FortranServer.Linked? - (Method ((FortranServer Linked?) - self host defaultDirectory filename) (* DSB "12-Aug-86 10:10") - (* Checks if an executable file exists on the host. - If so, returns T) - (INFILEP (PACKFILENAME (QUOTE HOST) - (_ host Name) - (QUOTE DIRECTORY) - defaultDirectory - (QUOTE NAME) - filename - (QUOTE EXTENSION) - (QUOTE EXE))))) - -(MathServer.AlertManager - (Method ((MathServer AlertManager) - self) (* DSB "22-May-86 16:54") - (* This method is called by all job processes. - It starts up the JobManager process if not awakened,  - and passes the jobManagerProcess variable.) - - (* * Start MS.JobManager if it isn't going) - - - (COND - ((NOT (PROCESSP (@ ::jobManagerProcess))) - (_@ - ::jobManagerProcess - (ADD.PROCESS (QUOTE (MS.JobManager)) - (NAME (QUOTE JobManager) - RESTARTABLE - (QUOTE HARDRESET))))) - (T NIL)))) - -(Server.AbortJob - (Method ((Server AbortJob) - self jobNumber queue) (* DSB "12-Aug-86 18:07") - (* aborts specific batch job on stated queue) - (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) - (QUOTE ABORTJOB)) - (_ self ServerDirectory)) - (LIST jobNumber queue) - (_ self MakeFullName (LISTGET (@ resultFileName) - (QUOTE ABORTJOB)))))) - -(Server.CommandFileExtension - (Method ((Server CommandFileExtension) - self) (* DSB "10-Nov-86 08:19") - (* returns the extension recognized by the system as a - command file) - (@ commandFileExtension))) - -(Server.Description - (Method ((Server Description) - self) (* DSB "19-Aug-86 14:29") - (* returns description of the server) - (@ description))) - -(Server.Error? - (Method ((Server Error?) - self result) (* DSB "21-May-86 11:44") - (* checks if CAR of result list is "ERROR") - (EQ (QUOTE ERROR) - (CAR result)))) - -(Server.ErrorFile - (Method ((Server ErrorFile) - self result) (* DSB "21-May-86 11:50") - (* returns the full name of the error file, specified  - by the third element in the result list) - (INFILEP (_ self MakeFullName (CADDR result))))) - -(Server.ErrorString - (Method ((Server ErrorString) - self result) (* DSB "21-May-86 11:46") - (* returns the error string: the second element in  - result list) - (CADR result))) - -(Server.ExecuteCommandFile - (Method ((Server ExecuteCommandFile) - self commandFile parameterList) (* DSB "10-Nov-86 10:59") - (* method to run a command file. - The command string is assembled by the local method  - CommandString) - (PROGRAMCHAT (_ self Host) - (_ self MakeCommandString commandFile parameterList) - NIL))) - -(Server.ExtractFilename - (Method ((Server ExtractFilename) - self result) (* DSB " 6-Aug-86 11:28") - (* Extract error file name from result) - (CAR (REVERSE result)))) - -(Server.GetQueues - (Method ((Server GetQueues) - self) (* DSB " 9-Jun-86 08:41") - (* returns the list of queues for the server) - (@ queues))) - -(Server.GetTime - (Method ((Server GetTime) - self) (* DSB "13-Jun-86 13:17") - (* gets the time from the server) - (* RunFile returns a list whose CAR is OK) - (_ self Result (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) - (QUOTE GETTIME)) - (_ self ServerDirectory)) - NIL - (_ self MakeFullName (LISTGET (@ resultFileName) - (QUOTE GETTIME))) - NIL)))) - -(Server.Host - (Method ((Server Host) - self) (* DSB "23-May-86 13:52") - (* returns local server instance variable host) - (CANONICAL.HOSTNAME (@ host)))) - -(Server.MakeError - (Method ((Server MakeError) - self string fileName) (* DSB "21-May-86 15:49") - (* makes an ERROR ... list) - (LIST (QUOTE ERROR) - string fileName))) - -(Server.MakeFullName - (Method ((Server MakeFullName) - self fileName directory) (* DSB "22-May-86 14:54") - (* Constructs full name of file and host) - - (* * if directory is not specified, it uses the user's login name on the host; i.e., the user's directory) - - - (COND - ((NOT directory) - (PACKFILENAME (QUOTE HOST) - (_ self Host) - (QUOTE DIRECTORY) - (_ self UserDirectory) - (QUOTE BODY) - fileName)) - (T - - (* * otherwise, it uses the specified directory name) - - - (PACKFILENAME (QUOTE HOST) - (_ self Host) - (QUOTE DIRECTORY) - directory - (QUOTE BODY) - fileName))))) - -(Server.MakePartialName - (Method ((Server MakePartialName) - self fileName directory) (* DSB "13-Jun-86 13:07") - (* Constructs name of file with directory, but without - host) - - (* * if directory is not specified, it uses the user's login name on the host; i.e., the user's root directory) - - - (COND - ((NOT directory) - (PACKFILENAME (QUOTE DIRECTORY) - (_ self UserDirectory) - (QUOTE BODY) - fileName)) - (T - - (* * otherwise, it uses the specified directory name) - - - (PACKFILENAME (QUOTE DIRECTORY) - directory - (QUOTE BODY) - fileName))))) - -(Server.Name - (Method ((Server Name) - self) (* DSB " 9-Jun-86 08:34") - (* returns vernacular server name) - (@ name))) - -(Server.PutErrorInWindow - (Method ((Server PutErrorInWindow) - self errorFile errorWindow mainWindow) (* DSB "15-Aug-86 17:42") - (* puts text of errorFile in a window) - - (* * put the errorFile in the errorWindow and set errorWindow props) - - - (OPENTEXTSTREAM errorFile errorWindow NIL NIL (QUOTE (PROMPTWINDOW (WINDOWPROP - mainWindow - (QUOTE - PROMPTWINDOW))))) - (WINDOWPROP errorWindow (QUOTE ERRORFILE) - errorFile) - (WINDOWADDPROP errorWindow (QUOTE CLOSEFN) - (QUOTE MS.CleanupErrorFile)))) - -(Server.PutTextInWindow - (Method ((Server PutTextInWindow) - self filename position) (* DSB "21-Jul-86 14:23") - (* Opens a scrollable TEDIT window for the file) - (TEDIT filename NIL NIL (QUOTE (READONLY T))))) - -(Server.Result - (Method ((Server Result) - self result) (* DSB "21-May-86 17:52") - (* returns the second element in the result list when  - there is no error. This is typically the jobID.) - (CADR result))) - -(Server.RunFile - (Method ((Server RunFile) - self file parameterList resultFile noErrorFlg) (* DSB " 9-Nov-86 13:49") - (* general method to run a command file and get result - and errors) - - (* * "file" is the name of the command file given to PROGRAMCHAT to be run on the host, and it must be in the  - proper host format (eg, submitjob) whereas "resultFile" is the name of the result file returned on  - the host, but it must be in the proper LISP naming format (eg, {GSLVAX10}submitjob.res)) - - - (LET (f result fullResultFile newFile) - - (* * runs a command file) - - - (_ self ExecuteCommandFile file parameterList) - - (* * look for result file) - - - (COND - ((SETQ fullResultFile (INFILEP (_ self MakeFullName resultFile))) - (SETQ f (OPENFILE fullResultFile (QUOTE INPUT))) - (SETQ result (READ f)) - (CLOSEF f) (* (DELFILE f)) - ) - (T (SETQ result (_ self MakeError "no result" NIL)))) - - (* * handle the errors) - - - - (* * default case (noErrorFlg=NIL) is not to return on errors. In this case, generate a break with an error  - message.) - - - - (* * Otherwise, do not break (if noErrorFlg=T). Instead, copy the error file to a file on core, and return its  - filename (e.g., {core}compile.err)) - - - - (* * after this runs, start up Job Manager, using (_ self AlertManager)) - - - (COND - ((NOT noErrorFlg) - (COND - ((_ self Error? result) - (DELFILE (_ self ErrorFile result)) - (ERROR (CONCAT (_ self Name) - ": " - (_ self ErrorString result)))) - (T (SETQ result (_ self Result result))))) - (T (* return complete result to user) - (COND - ((_ self Error? result) - (COND - ((SETQ f (_ self ErrorFile result)) - (SETQ newFile (COPYFILE f (PACKFILENAME (QUOTE HOST) - (QUOTE CORE) - (QUOTE BODY) - (_ self ExtractFilename - result)))) - (* (DELFILE f)) - (SETQ result (_ self MakeError (_ self ErrorString result) - newFile))) - (T result))) - (T result)))) - - (* * starts up JobManager, etc. Not yet implemented) - - (* (_ self AlertManager)) - result))) - -(Server.RunJob - (Method ((Server RunJob) - self filename parameterList) (* DSB "11-Aug-86 11:06") - (* runs com file, "filename", with additional  - parameters "parameterList", all of which must be on  - the host, as an interactive-type job) - - (* * parameterList is in RunJob either NIL or a list of parameters composed of a single string. - The parameterList sent to RunFile is thus a list composed of the filename and optional string of associated  - parameters.) - - - (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) - (QUOTE RUNJOB)) - (_ self ServerDirectory)) - (CONS filename parameterList) - (_ self MakeFullName (LISTGET (@ resultFileName) - (QUOTE RUNJOB))) - T))) - -(Server.ServerDirectory - (Method ((Server ServerDirectory) - self) (* DSB "22-May-86 15:37") - (* returns the name of the server directory for  - command files) - (@ serverDirectory))) - -(Server.SourceExtension - (Method ((Server SourceExtension) - self) (* DSB "21-Aug-86 16:46") - (* returns default extension for source files) - (@ sourceExtension))) - -(Server.Status - (Method ((Server Status) - self jobNumber) (* DSB "12-Aug-86 13:51") - (* get machine status of batch jobs) - - (* if a jobNumber is specified it returns either the CPU time elapsed (if running) or the error message if it  - bombed, or NIL if neither.) - - - - (* if no jobNumber is specified, returns a list, each element of which is a prop list of the form  - ((JOB jobNumber) (CPU timeElapsed))) - - - (LET (errorFile f result) - - (* * if a jobNumber is specified, return its status) - - - (COND - (jobNumber (OR (CAR (_ self RunFile (_ self MakePartialName - (LISTGET (@ comFileName) - (QUOTE STATUS)) - (_ self ServerDirectory)) - jobNumber - (_ self MakeFullName (LISTGET (@ resultFileName) - (QUOTE STATUS))) - NIL)) - (COND - ((SETQ errorFile (INFILEP (_ self MakeFullName - (CONCAT jobNumber ".res")))) - (SETQ f (OPENFILE errorFile (QUOTE INPUT))) - (SETQ result (READ f)) - (CLOSEF f) (* (DELFILE f)) - result) - (T NIL)))) - (T - - (* * else, return the status of all active jobs) - - - (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) - (QUOTE STATUS)) - (_ self ServerDirectory)) - jobNumber - (LISTGET (@ resultFileName) - (QUOTE STATUS)) - NIL)))))) - -(Server.SubmitJob - (Method ((Server SubmitJob) - self filename queue parameterList) (* DSB " 8-Aug-86 11:47") - (* submits file, which must be on the host, as a batch - job) - - (* * parameterList in SubmitJob is either NIL or a list of parameters composed of a single string. - The parameterList sent to RunFile is thus a list ocmposed of the filename, queue, and optional string of associated - parameters.) - - - (_ self RunFile (_ self MakePartialName (LISTGET (@ comFileName) - (QUOTE SUBMITJOB)) - (_ self ServerDirectory)) - (CONS filename (CONS queue parameterList)) - (_ self MakeFullName (LISTGET (@ resultFileName) - (QUOTE SUBMITJOB))) - NIL))) - -(Server.UserDirectory - (Method ((Server UserDirectory) - self) (* DSB "13-Jun-86 11:34") - (* Gets user name on appropriate host) - (* Forces login if not logged in) - (OR (MKATOM (CAAR (GETHASH (CANONICAL.HOSTNAME (_ self Host)) - LOGINPASSWORDS))) - (LOGIN (_ self Host))))) - -(VMSServer.MakeCommandString - (Method ((VMSServer MakeCommandString) - self commandFile parameterList) (* DSB "22-May-86 16:05") - (* assembles command string from given name of  - commandFile and parameterList) - (* Note that the commandFile and the parameterList  - must be quoted when this function is called) - (CONCAT "@" commandFile (for p in (MKLIST parameterList) bind (s _ "") - do (SETQ s (CONCAT s " " p)) finally (RETURN s))))) -) -(DEFINEQ - -(MS.MakeInstances - (LAMBDA NIL (* DSB " 9-Oct-86 11:18") - (* Initialization routine: makes browser and instances - of servers) - - (* * make class browser for Server) - - - (LET (newBrowser) - (SETQ newBrowser (_ ($ ClassBrowser) - New)) - (_ newBrowser AddRoot ($ Server))) - - (* * make $GSLVAX instance of VMSServer) - - - (_ ($ VMSServer) - New - (QUOTE GSLVAX)) - (_@ - ($ GSLVAX) - host - (QUOTE GSLVAX)) - (_@ - ($ GSLVAX) - name - (QUOTE GSLVAX)) - (_@ - ($ GSLVAX) - description "The GSL 11/780 VMS Server") - (_@ - ($ GSLVAX) - serverDirectory - (QUOTE )) - (_@ - ($ GSLVAX) - queues - (QUOTE (Fast Medium Slow))) - - (* * make $SITKA instance of VMSServer) - - (* the host value, SITKA, refers to the pup address  - 204#156#) - (_ ($ VMSServer) - New - (QUOTE SITKA)) - (_ ($ SITKA) - PutValue - (QUOTE host) - (QUOTE SITKA)) - (_@ - ($ SITKA) - name - (QUOTE SITKA)) - (_@ - ($ SITKA) - description "The GSL microVAX VMS Server") - (_@ - ($ SITKA) - serverDirectory - (QUOTE )) - (_@ - ($ SITKA) - queues - (QUOTE (Fast Slow))) - (_@ - ($ SITKA) - comFileName - (QUOTE (SUBMITJOB submitJob.com ABORTJOB abortJob.com RUNJOB runJob.com STATUS status.com - COMPILE compile.com LINK link.com GETTIME getTime.com))) - (_@ - ($ SITKA) - resultFileName - (QUOTE (SUBMITJOB submitJob.res ABORTJOB abortJob.res RUNJOB runJob.res STATUS status.res - COMPILE compile.res LINK link.res GETTIME getTime.res))) - - (* * make $MADVAX instance of VMSServer) - - - (_ ($ VMSServer) - New - (QUOTE MADVAX)) - (_@ - ($ MADVAX) - host - (QUOTE MADVAX)) - (_@ - ($ MADVAX) - name - (QUOTE MADVAX)) - (_@ - ($ MADVAX) - description "The AIS 11/750 VMS Server") - (_@ - ($ MADVAX) - serverDirectory - (QUOTE )) - (_@ - ($ MADVAX) - queues - (QUOTE (Fast Medium Slow))) - - (* * make $CRAYZY instance of Cray VaporServer) - - - (_ ($ Cray) - New - (QUOTE CRAYZY)) - (_ ($ CRAYZY) - PutValue - (QUOTE host) - (QUOTE CRAYZY)) - (_@ - ($ CRAYZY) - name - (QUOTE CRAYZY)) - (_@ - ($ CRAYZY) - description "Not yet plugged in..."))) - -(StripPA - (LAMBDA (username) (* DSB "22-May-86 11:50") - (SUBATOM username 1 (LET ((POS (STRPOS "." username))) - (COND - ((FIXP POS) - (SUB1 POS)) - (T NIL)))))) -) -(MS.DestroyInstances) -(MS.MakeInstances) - (* * PROGRAMCHAT - Windowless CHAT for communication) - -(DEFINEQ - -(OPENCHATSTREAM - (LAMBDA (HOST) (* ejs: "23-Feb-85 19:22") - (PROG (OPENFUNCTION) - (COND - ((BOUNDP (QUOTE CHAT.PROTOCOLTYPES)) - (COND - ((for PROTOCOL in CHAT.PROTOCOLTYPES thereis (SETQ OPENFUNCTION - (APPLY* (CDR PROTOCOL) - HOST))) - (RETURN (APPLY* (CADR OPENFUNCTION) - (CAR OPENFUNCTION)))))) - ((BOUNDP (QUOTE CHAT.PROTOCOLS)) - (COND - ((for PROTOCOL in CHAT.PROTOCOLS thereis (SETQ OPENFUNCTION - (APPLY* PROTOCOL HOST))) - (RETURN (APPLY* (CADR OPENFUNCTION) - (CAR OPENFUNCTION)))))))))) - -(PROGRAMCHAT - (LAMBDA (HOST CMDSTREAM LOGSTREAM) (* DSB " 9-Nov-86 13:02") - (PROG ((STREAMPAIR (OPENCHATSTREAM HOST)) - INCHAT OUTCHAT) - (COND - (STREAMPAIR (SETQ INCHAT (CAR STREAMPAIR)) - (SETQ OUTCHAT (CDR STREAMPAIR)) - (SETFILEINFO OUTCHAT (QUOTE ENDOFSTREAMOP) - (FUNCTION CHAT.ENDOFSTREAMOP)) - (SETFILEINFO INCHAT (QUOTE ENDOFSTREAMOP) - (FUNCTION CHAT.ENDOFSTREAMOP)) - (ADD.PROCESS (BQUOTE (PROGRAMCHAT.OUTPUT (QUOTE , INCHAT) - (QUOTE , LOGSTREAM)))) - (BLOCK) - (PROGRAMCHAT.LOGIN HOST INCHAT OUTCHAT) - (COND - ((STRINGP CMDSTREAM) - (SETQ CMDSTREAM (OPENSTRINGSTREAM CMDSTREAM (QUOTE INPUT))))) - (COND - ((NULL LOGSTREAM) - (SETQ LOGSTREAM (OPENSTREAM (QUOTE {NULL}) - (QUOTE OUTPUT))))) - (while (AND (OPENP OUTCHAT (QUOTE OUTPUT)) - (NOT (EOFP CMDSTREAM))) - do (BOUT OUTCHAT (BIN CMDSTREAM)) - (BLOCK) - finally (COND - ((EOFP CMDSTREAM) - (CLOSEF CMDSTREAM) - (BOUT OUTCHAT (CHARCODE CR)) - (PROGRAMCHAT.LOGIN HOST INCHAT OUTCHAT (QUOTE LOGOUT)) - (FORCEOUTPUT OUTCHAT T) - (until (NOT (OPENP INCHAT (QUOTE INPUT))) - do (BLOCK) finally (CLOSEF OUTCHAT)))))))))) - -(PROGRAMCHAT.LOGIN - (LAMBDA (HOST INSTREAM OUTSTREAM OPTION) (* ejs: "24-Jan-85 18:52") - - (* * Login to HOST. If a job already exists on HOST, Attach to it unless OPTION overrides.) - - - (PROG ((LOGINFO (CDR (ASSOC (OR (GETOSTYPE HOST) - (QUOTE IFS)) - NETWORKLOGINFO))) - NAME/PASS COM) - (OR LOGINFO (RETURN)) - (SETQ NAME/PASS (\INTERNAL/GETPASSWORD HOST)) - (SETQ COM (COND - (OPTION) - ((ASSOC (QUOTE ATTACH) - LOGINFO) - (OR (CHAT.LOGINFO INSTREAM HOST (CAR NAME/PASS)) - (QUOTE LOGIN))) - (T (* Don't know how to do anything but login, so silly  - to try anything else) - (QUOTE LOGIN)))) - (COND - ((NULL (SETQ LOGINFO (ASSOC COM LOGINFO))) - (printout PROMPTWINDOW T "Login option " COM " not implemented for this type of host") - ) - (T (for X in (CDR LOGINFO) do (SELECTQ X - (CR (BOUT OUTSTREAM (CHARCODE - CR)) - (FORCEOUTPUT OUTSTREAM)) - (USERNAME (PRIN3 (CAR NAME/PASS) - OUTSTREAM)) - (PASSWORD (PRIN3 - (\DECRYPT.PWD - (CDR NAME/PASS)) - OUTSTREAM)) - (WAIT - (* Some systems do not permit typeahead) - (COND - ((NOT (CHAT.FLUSH&WAIT - INSTREAM)) - (* Couldn't sync, so wait longer.) - (DISMISS CHAT.WAIT.TIME))) - (DISMISS CHAT.WAIT.TIME)) - (PRIN3 X OUTSTREAM))) - (FORCEOUTPUT OUTSTREAM)))))) - -(PROGRAMCHAT.OUTPUT - (LAMBDA (INCHATSTREAM LOGSTREAM) (* ejs: "23-Feb-85 19:18") - (bind CH while (AND (NEQ CH -1) - (OPENP INCHATSTREAM (QUOTE INPUT))) - do (SETQ CH (BIN INCHATSTREAM)) - (COND - ((NEQ CH -1) - (COND - (LOGSTREAM (BOUT LOGSTREAM CH))))) - finally (COND - ((OPENP INCHATSTREAM) - (CLOSEF INCHATSTREAM)))))) -) - - - -(* VARS for our site) - - -(RPAQQ NETWORKLOGINFO ((TENEX (LOGIN "LOGIN " USERNAME " " PASSWORD " -") - (ATTACH "ATTACH " USERNAME " " PASSWORD " -") - (WHERE "WHERE " USERNAME CR "ATTACH " USERNAME " " PASSWORD CR) - (LOGOUT "LOGOUT" CR)) - (TOPS20 (LOGIN "LOGIN " USERNAME CR PASSWORD CR) - (ATTACH "ATTACH " USERNAME "" CR PASSWORD CR) - (WHERE "LOGIN " USERNAME CR PASSWORD CR) - (LOGOUT "LOGOUT" CR)) - (UNIX (LOGIN WAIT CR WAIT USERNAME CR WAIT PASSWORD CR WAIT WAIT WAIT WAIT CR) - (LOGOUT WAIT CR "logout" CR)) - (IFS (LOGIN "Login " USERNAME " " PASSWORD CR) - (ATTACH) - (LOGOUT "Quit" CR)) - (VMS (LOGIN USERNAME CR PASSWORD CR) - (LOGOUT "LOGOUT" CR)) - (NS (LOGIN "Logon" CR USERNAME CR PASSWORD CR) - (LOGOUT "LOGOFF" CR)))) -(pushnew NETWORKOSTYPES (QUOTE (GSLVAX . VMS)) - (QUOTE (SITKA . VMS)) - (QUOTE (MADVAX . VMS))) - (* * PROGRAMMER'S INTERFACE - use remote servers with LISP calls) - -(DEFINEQ - -(PRIN.RunRemote - (LAMBDA (hostname filename parameterList) (* DSB "25-Nov-86 09:41") - (* Main Programmer's Interface  - (PRIN) function) - (PROG (host file result) - - (* * check preliminaries) - - - (SETQ host (PRIN.ValidateHost hostname)) - (COND - ((NOT host) - (RETURN (PRIN.Error (CONCAT "Host " (U-CASE hostname) - " is not valid"))))) - (SETQ file (PRIN.ValidateFilename filename host hostname)) - (COND - ((NOT file) - (RETURN (PRIN.Error (CONCAT "Command file " filename " does not exist"))))) - - (* * run the job) - - - (SETQ result (_ host RunJob file parameterList)) - - (* * handle the results) - - - (COND - ((EQUAL (CAR result) - (QUOTE ERROR)) - (PRIN.Error "Run-time warning or error" host file result)) - (T (PROMPTPRINT (CONCAT "Call to remote host " (U-CASE hostname) - " succeeded without error")) - (RETURN T)))))) - -(PRIN.ValidateHost - (LAMBDA (hostname) (* DSB "10-Nov-86 08:06") - (* returns the host, or NIL if nonexistant) - (PROG (host) - (SETQ host (FE.GetServer (U-CASE hostname))) - (RETURN host)))) - -(PRIN.ValidateFilename - (LAMBDA (filename host hostname) (* DSB "10-Nov-86 08:40") - (* returns file if command file exists, or NIL  - otherwise) - (PROG (directory name extension wholename fileExists?) - (SETQ directory (UNPACKFILENAME filename (QUOTE DIRECTORY))) - (SETQ name (UNPACKFILENAME filename (QUOTE NAME))) - (SETQ extension (_ host CommandFileExtension)) - (SETQ wholename (PACKFILENAME (QUOTE HOST) - (U-CASE hostname) - (QUOTE DIRECTORY) - directory - (QUOTE NAME) - name - (QUOTE EXTENSION) - extension)) - (SETQ fileExists? (INFILEP wholename)) - (COND - ((NOT fileExists?) - (RETURN NIL)) - (T (RETURN (PACKFILENAME (QUOTE DIRECTORY) - directory - (QUOTE NAME) - name))))))) - -(PRIN.Error - (LAMBDA (errorString host file result) (* DSB "10-Nov-86 11:17") - (* opens an error window and prints the error string  - and any run-time error messages) - (PROG (hostname errorWindow errorFile) - (COND - ((AND host file) - (SETQ hostname (_ host Name)) - (SETQ errorWindow (CREATEW (QUOTE (300 300 420 200)) - (CONCAT "PRIN: " errorString " on host " hostname))) - (SETQ errorFile (_ host ExtractFilename result)) - (_ host PutErrorInWindow errorFile errorWindow)) - (T (SETQ errorWindow (CREATEW (QUOTE (300 300 300 80)) - "Programmer's Interface Error Window")) - (PRIN1 errorString errorWindow)))))) -) -(PUTPROPS MATHSERVER COPYRIGHT ("Xerox Corporation" 1986 1987)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (4197 14885 (MS.TopLevel 4207 . 5531) (MS.CreateFreeMenu 5533 . 8329) (MS.SelectHost -8331 . 9538) (MS.ExpandFilename 9540 . 10736) (MS.CloseErrorWindow 10738 . 11298) (MS.CleanupErrorFile - 11300 . 11832) (MS.AttachErrorWindow 11834 . 12844) (MS.MostRoom 12846 . 13508) (MS.GetMessageWindow -13510 . 13852) (MS.MakeIconWindow 13854 . 14099) (PrintMsg 14101 . 14883)) (14925 15698 ( -MS.MakeMenuOfKnownHosts 14935 . 15351) (MS.DestroyInstances 15353 . 15696)) (15733 38409 ( -MS.SubmitBatchJob 15743 . 18415) (MS.AbortBatchJob 18417 . 20283) (MS.Status 20285 . 21644) ( -MS.DisplayStatus 21646 . 22635) (MS.RunInteractiveJob 22637 . 25063) (MS.Compile 25065 . 27193) ( -MS.Link 27195 . 29585) (MS.CompileLink 29587 . 32889) (MS.CLR.Check 32891 . 33195) (MS.CLR.NoCheck -33197 . 33507) (MS.CompileLinkRun 33509 . 38407)) (38447 42814 (MS.StartNewFE 38457 . 38753) ( -MS.StartDefaultFE 38755 . 40730) (MS.FindFortranEdit 40732 . 41673) (MS.CheckForDirtyFile 41675 . -42812)) (42852 47051 (MS.BatchErrors? 42862 . 45339) (MS.BatchLog 45341 . 47049)) (50865 60017 ( -FE.TopLevel 50875 . 52556) (FE.AdjustProps 52558 . 53265) (FE.CaretPosition 53267 . 55145) ( -TEDIT.PARA&CHAR 55147 . 56522) (FE.CharFn 56524 . 56830) (FE.GetEditProps 56832 . 57951) ( -FE.GetSourceFileName 57953 . 59635) (FE.LoopFn 59637 . 60015)) (60047 64784 (FE.GetPositionWindow -60057 . 61139) (FE.GetEditWindow 61141 . 62925) (FE.GetMessageWindow 62927 . 63409) (FE.ReshapeFn -63411 . 63721) (FE.ShadeWindow 63723 . 64782)) (64817 84050 (FE.CreateLocalMenu 64827 . 66468) ( -FE.SetHost 66470 . 67980) (FE.SetDirectory 67982 . 69411) (FE.MyGet 69413 . 70543) (FE.MyPut 70545 . -72589) (FE.StripVersion 72591 . 73415) (FE.Compile 73417 . 75646) (FE.Link 75648 . 77825) ( -FE.CompileLinkRun 77827 . 81823) (FE.RunInteractive 81825 . 84048)) (84090 85128 (FE.ValidHostname -84100 . 84668) (FE.GetServer 84670 . 85126)) (85152 87199 (FE.ShrinkIconCreate 85162 . 87197)) (99037 -117564 (FortranServer.Compile 99047 . 99571) (FortranServer.Compiled? 99573 . 100108) ( -FortranServer.Link 100110 . 100890) (FortranServer.Linked? 100892 . 101427) (MathServer.AlertManager -101429 . 102140) (Server.AbortJob 102142 . 102665) (Server.CommandFileExtension 102667 . 103004) ( -Server.Description 103006 . 103269) (Server.Error? 103271 . 103560) (Server.ErrorFile 103562 . 103938) - (Server.ErrorString 103940 . 104248) (Server.ExecuteCommandFile 104250 . 104711) ( -Server.ExtractFilename 104713 . 105001) (Server.GetQueues 105003 . 105265) (Server.GetTime 105267 . -105888) (Server.Host 105890 . 106167) (Server.MakeError 106169 . 106451) (Server.MakeFullName 106453 - . 107300) (Server.MakePartialName 107302 . 108087) (Server.Name 108089 . 108328) ( -Server.PutErrorInWindow 108330 . 109007) (Server.PutTextInWindow 109009 . 109329) (Server.Result -109331 . 109668) (Server.RunFile 109670 . 112378) (Server.RunJob 112380 . 113285) ( -Server.ServerDirectory 113287 . 113604) (Server.SourceExtension 113606 . 113890) (Server.Status 113892 - . 115534) (Server.SubmitJob 115536 . 116388) (Server.UserDirectory 116390 . 116888) ( -VMSServer.MakeCommandString 116890 . 117562)) (117565 120654 (MS.MakeInstances 117575 . 120398) ( -StripPA 120400 . 120652)) (120756 125312 (OPENCHATSTREAM 120766 . 121492) (PROGRAMCHAT 121494 . 122998 -) (PROGRAMCHAT.LOGIN 123000 . 124845) (PROGRAMCHAT.OUTPUT 124847 . 125310)) (126250 129561 ( -PRIN.RunRemote 126260 . 127389) (PRIN.ValidateHost 127391 . 127722) (PRIN.ValidateFilename 127724 . -128739) (PRIN.Error 128741 . 129559))))) -STOP diff --git a/obsolete/lispusers/MATHSERVER.COMMANDFILES b/obsolete/lispusers/MATHSERVER.COMMANDFILES deleted file mode 100644 index 41e6e624..00000000 --- a/obsolete/lispusers/MATHSERVER.COMMANDFILES +++ /dev/null @@ -1,13 +0,0 @@ -ABORTJOB.COM $ ! abortJob.com $ ! this file is used to abort a batch job $ ! p1 is the jobNumber; p2 is the queue $ ! The "show batch" command is used to determine if the job exists. If $ ! it does not, the message NIL is returned; otherwise, the job is $ ! aborted. $ ! All messages are returned to the user's root directory. $ ! If there is a serious error, ... $ ! if there is an error in the running of this com file, the detailed $ ! error message gets sent to abortJob.err in the user's root directory. $ !SET VERIFY $ delete sys$login:abortJob.err.* $ delete sys$login:abortJob.res.* $ SET NOVERIFY $ define sys$output abortJob.tmp $ show queue 'P2' $ deassign sys$output $ !SET VERIFY $ open/write result sys$login:abortJob.res $ $ loop: $ open/read file abortJob.tmp $ read/end_of_file=done file line $ jobNumber = f$integer(f$extract(32,4,line)) $ if jobNumber .eq. P1 then goto found $ goto loop $ $ done: $ write result "( OK NIL)" ! job not found $ goto finish $ $ found: $ define sys$error sys$login:abortJob.err $ on error then goto error $ stop/entry='P1' 'P2' $ deassign sys$error $ write result "( OK ( Job ",P1," on queue ",P2,- " has been aborted))" $ $ finish: $ close result $ close file $ delete abortJob.tmp.* $ exit $ error: $ @[gslws.server]error sys$login:abortJob.res '$STATUS' $ deassign sys$error $ close result $ close file $ delete abortJob.tmp.* ----------------------------------- COMPILE.COM $ ! COMPILE.COM 8/7/86 $ ! this file is used to compile a job interactively. $ ! job is the name of the user's fortran source file $ ! the file exists in the user's local directory, which may be a $ ! subdirectory of the root directory. $ ! the object file is made in the user's local directory. $ ! if there is no error in compilation, the name and date of the $ ! object file are returned in sys$login:compile.res. $ ! if there is an error in compilation, the abbreviated error message $ ! is returned in sys$login:compile.res, and the detailed $ ! error message is written to sys$login:compile.err. $ $ $ !SET VERIFY $ job = f$parse("''P1'",,,"name") $ userDirectory = f$parse("''P1'",,,"directory") $ length=f$length(job) $ ! show symbol job $ ! show symbol userDirectory $ ! show sym length $ delete sys$login:compile.err.* $ delete sys$login:compile.res.* $ delete 'P1'.obj.* $ define sys$error sys$login:compile.err $ ! define sys$error sys$login:'job'.err $ on error then goto error $ $ fortran/object='userDirectory''job' 'P1' $ deassign sys$error $ SET NOVERIFY $ define sys$output sys$login:objFile.tmp $ dir/date 'P1'.obj $ deassign sys$output $ !SET VERIFY $ open/write resultFile sys$login:compile.res $ open/read file sys$login:objFile.tmp $ $ loop: $ read/end_of_file=done file line $ ! show sym line $ name=f$extract(0,length,line) $ ! show sym name $ if name .eqs. job then goto found $ goto loop $ $ done: $ write resultFile "( OK NIL)" ! object file not found $ goto finish $ $ found: $ write resultFile "( OK (",line,"))" $ $ finish: $ close resultFile $ close file $ delete objFile.tmp.* $ exit $ $ error: $ @[gslws.server]error sys$login:compile.res '$STATUS' $ deassign sys$error ----------------------- ERROR.COM $ ! lists error status message in specified file $ ! call by: @error resultFile errorStatus $ $ open/write result 'P1' $ errorFile = f$logical("sys$error") $ ! show sym errorFile $ shortName=f$parse(errorFile,,,"name") $ ! show sym shortName $ write result "(ERROR ""''f$message(P2)'"" ''shortName'.ERR)" $ close result ---------------------------- LINK.COM $ ! LINK.COM 8/8/86 $ ! This file is used to link a series of object files to form an $ ! executable file. $ ! The parameter P1 is the object code filename of the main file. $ ! The parameter P2 is a string composed of all object files to $ ! be linked with P1. There must be a comma between these files $ ! within P2. $ ! Job is the extracted name of the user's main object code file. $ ! This file exists in the user's local directory, which may be a $ ! subdirectory of the root directory. $ ! The executable file is made in the user's local directory. $ ! If there is no error in linking, the name and date of the $ ! executable file are returned in sys$login:link.res. $ ! If there is no error in linking but no .exe file is made, a $ ! message to that effect is returned in sys$login:link.res. $ ! If there is a link warning during linking, an error message is returned $ ! in sys$login:link.res, and the detailed link warning messages are $ ! written to sys$login:link.err. $ ! If there is an error in linking, such as no existing object file, $ ! the abbreviated error message is returned, from the ERROR.COM file, $ ! in sys$login:link.res, and the detailed error message is written $ ! to sys$login:link.err. $ !SET VERIFY $ job = f$parse("''P1'",,,"name") $ userDirectory = f$parse("''P1'",,,"directory") $ length=f$length(job) $ ! show symbol job $ ! show symbol userDirectory $ ! show symbol length $ delete sys$login:link.err.* $ delete sys$login:link.res.* $ delete 'P1'.exe.* $ define sys$error sys$login:link.err $ ! define sys$error sys$login:'job'.err $ on error then goto error $ ! $ ! Note: link warnings can be very serious, such as the absence of object $ ! code modules, in which case a useless .exe file is made. Because $ ! errors (as opposed to warnings) get trapped through the error routine, $ ! these serious link warnings must be handled specially. $ ! $ ! show symbol P2 $ if P2 .eqs. "" then goto simple $ link/exe='userDirectory''job' 'P1','P2' $ goto continue1 $ ! $ simple: $ link/exe='userDirectory''job' 'P1' $ ! $ continue1: $ deassign sys$error $ open/write resultFile sys$login:link.res $ ! $ ! If we've gotten this far, it means no errors occurred. $ ! First, check if link warnings occurred, by determining if a $ ! LINK.ERR file was written. If so, continue through linkerror1. $ ! $ SET NOVERIFY $ define sys$output sys$login:linkFile.tmp $ dir/date/siz sys$login:link.err $ deassign sys$output $ !SET VERIFY $ open/read file sys$login:linkFile.tmp $ ! $ loop1: $ read/end_of_file=continue2 file line $ show sym line $ name=f$extract(0,4,line) $ show sym name $ if name .eqs. "LINK" then goto linkerror1 $ goto loop1 $ ! $ continue2: $ close file $ ! $ ! Second, check if an executable file was made. (Executable files are $ ! made in spite of link warnings. The following check flags a $ ! situation where neither a link warning nor an executable file is made.) $ ! $ SET NOVERIFY $ define sys$output sys$login:exeFile.tmp $ dir/date 'P1'.exe $ deassign sys$output $ !SET VERIFY $ open/read file sys$login:exeFile.tmp $ ! $ loop2: $ read/end_of_file=linkerror2 file line $ show sym line $ name=f$extract(0,length,line) $ show sym name $ if name .eqs. job then goto found $ goto loop2 $ ! $ linkerror1: $ message="error during linking" $ write resultFile "(ERROR ""''message'"" LINK.ERR)" ! link warning $ goto finish1 $ ! $ linkerror2: $ message="executable file not made" $ write resultFile "( OK (",message,"))" ! exe file not made $ goto finish2 $ ! $ found: $ write resultFile "( OK (",line,"))" $ goto finish2 $ ! $ finish1: $ close resultFile $ delete sys$login:linkFile.tmp.* $ exit $ ! $ finish2: $ close resultFile $ close file $ delete sys$login:exeFile.tmp.* $ delete sys$login:linkFile.tmp.* $ exit $ ! $ error: $ @[gslws.server]error sys$login:link.res '$STATUS' $ deassign sys$error ---------------------------------------------- RUNJOB.COM $ ! runjob.com 8/11/86 $ ! this file is used to run an interactive job $ ! job is the name of the user's com file $ ! P2 is the list of appended parameters (optional) $ ! If there is no error in running the job, an OK message is $ ! written out to sys$login:runjob.res. $ ! If there are warnings during the running of the job, an ERROR message $ ! is returned in sys$login:runjob.res, and the detailed warning $ ! messages are returned in sys$login:runjob.err $ ! If there is an error in the running of the job, the abbreviated $ ! error message is returned, from the ERROR.COM file, in $ ! sys$login:runjob.res, and the detailed error message is written $ ! to sys$login:runjob.err. $ !SET VERIFY $ job = f$parse("''P1'",,,"name") $ delete sys$login:runJob.err.* $ delete sys$login:runJob.res.* $ define sys$error sys$login:runJob.err $ on error then goto error $ @'P1' 'P2' $ deassign sys$error $ open/write resultFile sys$login:runJob.res $ ! $ ! If a warning occurs, it is written out to runJob.err $ ! Such warnings are handled specially, through the $ ! runwarning entry. $ ! $ SET NOVERIFY $ define sys$output sys$login:runFile.tmp $ dir/date/siz sys$login:runJob.err $ deassign sys$output $ !SET VERIFY $ open/read file sys$login:runFile.tmp $ ! $ loop: $ read/end_of_file=continue file line $ show sym line $ name=f$extract(0,6,line) $ show sym name $ if name .eqs. "RUNJOB" then goto runwarning $ goto loop $ ! $ continue: $ write resultFile "( OK (",job," ",P1," ))" $ goto finish $ ! $ runwarning: $ message="warning(s) occurred" $ write resultFile "(ERROR ""''message'"" RUNJOB.ERR)" $ ! $ finish: $ close file $ close resultFile $ delete sys$login:runFile.tmp.* $ exit $ ! $ error: $ @[gslws.server]error sys$login:runJob.res '$STATUS' $ deassign sys$error ------------------------------------------- STATUS.COM $ ! get status of batch jobs $ ! If jobNumber is specified, return only status of that job $ ! If jobNumber is not specified, return all jobs $ ! called by: @status jobNumber $ $ delete status.res.* $ $ define sys$output status.tmp $ show system/batch $ deassign sys$output $ !SET VERIFY $ $ open/read file status.tmp $ open/write result status.res $ write result "( OK (" $ if P1 .eq. "" then goto writeall $ $ loop: $ read/end_of_file=done file line $ job = f$integer(f$extract(15,4,line)) $ if job .eq. P1 then goto found $ goto loop $ $ done: $ write result "NIL" ! no data for specified job $ goto finish $ $ found: $ time = f$extract(49,11,line) $ write result "( (JOB ''P1') (CPU ''time') )" $ goto finish $ $ writeall: $ read/end_of_file=finish file line $ jobType = f$extract(9,5,line) $ if jobType .nes. "BATCH" then goto writeall $ job = f$integer(f$extract(15,4,line)) $ time = f$extract(49,11,line) $ write result "( (JOB ''job') (CPU ''time') )" $ goto writeall $ $ finish: $ write result ") )" $ close result $ close file $ delete status.tmp; $ exit ---------------------------------------- SUBCOM.COM $ ! subcom.com $ ! this is the file actually submitted by submitjob.com $ ! Parameter P1 is the name of the user's COM file to be run $ ! Parameters P2,P3, etc are passed from P3,P4, etc. in SubmitJob.com $ ! jobname is in the form BATCH_xxx $ ! job is the number (xxx) $ ! if there is an error in the running of the batch job, the detailed $ ! error message gets sent to 'job'.err. $ ! The abbreviated error message gets sent to 'job'.res $ ! SET VERIFY $ jobname = f$process() $ job = f$extract(6,f$length(jobname)-6,jobname) $ ! open/write outfile junk. $ ! write outfile jobname," ",job $ ! close outfile $ define sys$error 'job'.err $ on error then goto error $ @'P1' 'P2' 'P3' 'P4' 'P5' 'P6' $ exit $ error: $ @[gslws.server]error 'job'.res '$STATUS' ------------------------------------------ SUBMITJOB.COM $ ! submitjob.com 8/11/86 $ ! submit a job on specified queue $ ! call by: @submitjob file queue parameterString $ ! P1 is the file name of the job to be submitted $ ! P2 is the queue (eg., fast, medium) $ ! P3, P4, P5, etc. are subsidiary parameters, such as file $ ! names (eg., file1.dat, file2.sav). $ ! these files are returned in the user's root directory: $ ! P1.log for log file $ ! submitjob.res for result (job # or error message) $ ! submitjob.err for detailed errors (from sys$error) $ ! submitjob.tmp for temporary output $ ! these files are returned in the user's running (sub)directory: $ ! 'jobnumber'.res for error message to be returned $ ! 'jobnumber'.err for detailed error message $ !SET VERIFY $ job=f$parse("''P1'",,,"name") $ delete sys$login:'job'.log.* $ delete sys$login:submitjob.err.* $ delete sys$login:submitjob.res.* $ delete sys$login:submitjob.tmp.* $ errorFile = "submitjob.err" $ tempFile = "submitjob.tmp" $ resultFile = "submitjob.res" $ define sys$error 'errorFile' $ on error then goto error $ ! submit the batch job $ SET NOVERIFY $ if P3.eqs."" then goto zeropar $ if P4.eqs."" then goto onepar $ if P5.eqs."" then goto twopar $ if P6.eqs."" then goto threepar $ if P7.eqs."" then goto fourpar $ if P8.eqs."" then goto fivepar $ goto abort $ zeropar: $ define sys$output 'tempFile' $ submit/noprint/name='job'/parameters=('P1')- /queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ onepar: $ define sys$output 'tempFile' $ submit/noprint/name='job'/parameters=('P1','P3')- /queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ twopar: $ define sys$output 'tempFile' $ submit/noprint/name='job'/parameters=('P1','P3','P4')- /queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ threepar: $ define sys$output 'tempFile' $ submit/noprint/name='job'/parameters=('P1','P3','P4','P5')- /queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ fourpar: $ define sys$output 'tempFile' $ submit/name='job'/parameters=('P1','P3','P4','P5','P6')- /noprint/queue='P2' [gslws.server]subcom.com $ deassign sys$output $ goto finish $ fivepar: $ define sys$output 'tempFile' $ submit/name='job'/parameters=('P1','P3','P4','P5','P6','P7')- /noprint/queue='P2' [gslws.server]subcom.com $ deassign sys$output $ finish: $ !SET VERIFY $ ! get job number of submitted job from string in submit.tmp $ open/read infile 'tempFile' $ read infile line $ ! line now equals " Job xxxx entered on queue ----" $ startPosition = f$locate("entry",line)+5 $ endPosition = f$locate(")",line) $ numDigits = endPosition - startPosition $ jobNumber = f$extract(startPosition,numDigits,line) $ close infile $ ! delete 'tempFile';* $ open/write outfile 'resultFile' $ write outfile "( OK (",jobNumber, " ", P1," ))" $ close outfile $ ! no (ERROR ...) message, so deassign the error file $ deassign sys$error $ exit $ abort: $ open/write outfile 'errorFile' $ write outfile "Too many job parameters (more than five)" $ close outfile $ deassign sys$error $ exit $ ! get error message $ error: $ @user1:[gslws.server]error 'resultFile' '$STATUS' $ deassign sys$output $ deassign sys$error $ ! delete 'tempFile';* $ exit -----------------------+@(GACHA  ˜ 67B);B9G=9#1!!*),0/-(&*? & - -8 -1+%"."? BCADCE*?>:@@LH%FJG#1')LIN>"+ -& ,;BF+"( ',   ICN*' ( $ !E%? & "  !" -5/ 0,6>+JD4D=F#  (-:8*$'&.  / 7 - ! -7, >3!)"(! 1 / $ .(0 - ) 9>G&G,;1#" -,+$38-B/; =>.C<2 ###'&&('' 01 -41 -91 >1 ;9 @9 ->6+#*6"47 'A  4:Œ®zº \ No newline at end of file diff --git a/obsolete/lispusers/MATHSERVER.LCOM b/obsolete/lispusers/MATHSERVER.LCOM deleted file mode 100644 index 8ff5177b..00000000 Binary files a/obsolete/lispusers/MATHSERVER.LCOM and /dev/null differ diff --git a/obsolete/lispusers/MATHSERVERPLOT.LCOM b/obsolete/lispusers/MATHSERVERPLOT.LCOM deleted file mode 100644 index 0e01602d..00000000 Binary files a/obsolete/lispusers/MATHSERVERPLOT.LCOM and /dev/null differ diff --git a/obsolete/lispusers/MATHTONS b/obsolete/lispusers/MATHTONS deleted file mode 100644 index ea832a0b..00000000 --- a/obsolete/lispusers/MATHTONS +++ /dev/null @@ -1,28 +0,0 @@ -(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") -(FILECREATED "13-Feb-87 11:01:14" {ERIS}LYRIC>MATHTONS.;1 1284 - - previous date%: "12-Dec-86 14:37:39" {PHYLUM}KOTO>MATHTONS.;2) - - -(* " -Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT MATHTONSCOMS) - -(RPAQQ MATHTONSCOMS ((UGLYVARS \MATHTONSARRAY) - (ADDVARS (ASCIITONSTRANSLATIONS (MATH \MATHTONSARRAY CLASSIC))))) -(READVARS \MATHTONSARRAY) -({Y256 SMALLPOSP 0 0 61307 61234 61235 0 163 61301 61302 0 0 0 182 0 0 0 61286 0 0 0 61306 0 0 61295 -{R9 0} 32 61232 61287 8551 162 184 61366 61299 194 61308 199 177 61260 61309 8552 61285 61287 8738 -8740 8574 61282 61283 61284 61292 8570 199 167 0 8549 8546 8550 2 61248 61365 61258 61356 61369 61364 -61233 61275 61279 61273 61274 61278 61272 61629 61259 61281 61297 61265 61358 61305 61296 61271 61367 -61298 180 61626 61368 0 0 0 175 174 0 61351 61267 211 61370 61303 61266 61263 61288 61360 61361 61362 -61363 61256 61290 61287 61238 61240 210 61246 61244 61247 61245 61250 61251 61270 61239 188 189 190 -61264 {R129 0} }) - -(ADDTOVAR ASCIITONSTRANSLATIONS (MATH \MATHTONSARRAY CLASSIC)) -(PUTPROPS MATHTONS COPYRIGHT ("Xerox Corporation" 1986 1987)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/lispusers/MATHTONS.TEDIT b/obsolete/lispusers/MATHTONS.TEDIT deleted file mode 100644 index 69ddefb6..00000000 Binary files a/obsolete/lispusers/MATHTONS.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/MATRIXOPS b/obsolete/lispusers/MATRIXOPS deleted file mode 100644 index 96ae7255..00000000 --- a/obsolete/lispusers/MATRIXOPS +++ /dev/null @@ -1,1005 +0,0 @@ -(FILECREATED " 4-Jun-86 18:27:59" {QV}LISP>MATRIXOPS.;12 48308 - - changes to: (VARS MATRIXOPSCOMS) - (FNS QRSOLV MTIMES TRANSPOSE MTRANSPOSE MINVERT MSOLVE MOLS MREGRESS) - - previous date: "29-May-86 12:39:55" {QV}LISP>MATRIXOPS.;10) - - -(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT MATRIXOPSCOMS) - -(RPAQQ MATRIXOPSCOMS ((FNS CHOLESKYFACTOR MTRANSPOSE MINVERT LSOLV LUFACTOR LUINVERSE LUSOLV MTIMES - QRFACTOR QROLS QRQTY QRQY QRSOLV MREGRESS RSOLV MSOLVE SVDFACTOR SVDTEST - \FLOATAREFMACRO \FLOATASETMACRO) - (VARS STACK) - (MACROS \FLOATAREF \FLOATASET) - (FILES BLAS))) -(DEFINEQ - -(CHOLESKYFACTOR - [LAMBDA (MATRIX FACTORMATRIX) (* jop: "28-May-86 12:38") - - (* * Lifted from LINPACK algorithm SCHDC) - - (BLAS.CHECKARRAY MATRIX) - (LET ((P (ARRAY-DIMENSION MATRIX 0))) - - (* * Arg Checks) - - (if [NOT (AND (EQL 2 (ARRAY-RANK MATRIX)) - (EQL P (ARRAY-DIMENSION MATRIX 1] - then (HELP "Matrix not sqaure" MATRIX)) - (if (NULL FACTORMATRIX) - then (SETQ FACTORMATRIX (MAKE-ARRAY (ARRAY-DIMENSIONS MATRIX) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY FACTORMATRIX) - (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX) - (ARRAY-DIMENSIONS MATRIX))) - then (HELP "Illegal FACTORMATRIX" FACTORMATRIX))) - (* Copy MATRIX to FACTORMATRIX) - (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1) - - (* * Compute the cholesky decomposition of FACTORMATRIX) - - [bind (WORK _ (MAKE-ARRAY P (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - TEMP for K from 0 to (SUB1 P) - do (if (LEQ (\FLOATAREF FACTORMATRIX K K) - 0.0) - then (HELP "Zero pivot element")) - (\FLOATASET (SQRT (\FLOATAREF FACTORMATRIX K K)) - WORK K) - (\FLOATASET (\FLOATAREF WORK K) - FACTORMATRIX K K) - (if (NOT (EQL K (SUB1 P))) - then (for J from (ADD1 K) to (SUB1 P) - do (\FLOATASET (FQUOTIENT (\FLOATAREF FACTORMATRIX K J) - (\FLOATAREF WORK K)) - FACTORMATRIX K J) - (\FLOATASET (\FLOATAREF FACTORMATRIX K J) - WORK J) - (SETQ TEMP (FMINUS (\FLOATAREF FACTORMATRIX K J))) - (BLAS.AXPY TEMP WORK (ADD1 K) - 1 FACTORMATRIX (IPLUS J (ITIMES P (ADD1 K))) - P - (IDIFFERENCE J K] - FACTORMATRIX]) - -(MTRANSPOSE - [LAMBDA (SOURCEMATRIX DESTMATRIX) (* jop: " 4-Jun-86 14:07") - - (* * Transpose the M x N matrix SOURCEMATRIX. DESTMATRIX should be N x M. Returns DESTMATRIX) - - - (BLAS.CHECKARRAY SOURCEMATRIX) - (PROG ((M (ARRAY-DIMENSION SOURCEMATRIX 0)) - (N (ARRAY-DIMENSION SOURCEMATRIX 1))) - (if (NULL DESTMATRIX) - then (SETQ DESTMATRIX (MAKE-ARRAY (LIST N M) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY DESTMATRIX) - (if (NOT (EQUAL (ARRAY-DIMENSIONS DESTMATRIX) - (LIST N M))) - then (HELP "DESTMATRIX of incorrect size" DESTMATRIX))) - (if (ILESSP M N) - then (bind (SOURCEBASE _(ARRAYBASE SOURCEMATRIX)) - (DESTBASE _(ARRAYBASE DESTMATRIX)) for I from 0 - to (SUB1 M) do (\FLOATARRAYBLT SOURCEBASE (ITIMES N I) - 1 DESTBASE I M N)) - else (bind (SOURCEBASE _(ARRAYBASE SOURCEMATRIX)) - (DESTBASE _(ARRAYBASE DESTMATRIX)) for J from 0 - to (SUB1 N) do (\FLOATARRAYBLT SOURCEBASE J N DESTBASE - (ITIMES J M) - 1 M))) - (RETURN DESTMATRIX]) - -(MINVERT - [LAMBDA (MATRIX SOLUTION) (* jop: "26-May-86 18:35") - - (* * Solves to system A x = b. BVECTOR should to the RHS of the system. Returns SOLUTION) - - - (LET [(PIVOTVECTOR (MAKE-ARRAY (ARRAY-DIMENSION MATRIX 0] - (LUINVERSE (LUFACTOR MATRIX PIVOTVECTOR) - PIVOTVECTOR SOLUTION]) - -(LSOLV - [LAMBDA (LMATRIX CVECTOR BVECTOR) (* jop: "27-May-86 16:25") - - (* * Calcluate the solution vector BVECTOR for the system of linear equations - R*B=C, where LMATRIX is lower triangular M X N with non-zero diagonal elements. - BVECTOR and CVECTOR must be of size N. Always returns BVECTOR) - - (BLAS.CHECKARRAY LMATRIX) - (BLAS.CHECKARRAY CVECTOR) - (PROG ((M (ARRAY-DIMENSION LMATRIX 0)) - (N (ARRAY-DIMENSION LMATRIX 1))) - - (* * Arg Checks) - - (if (ILESSP M N) - then (HELP "Order of system less than" N)) - (if (NOT (EQL (ARRAY-TOTAL-SIZE CVECTOR) - N)) - then (HELP "CVECTOR not of size" N)) - (if (NULL BVECTOR) - then (SETQ BVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY BVECTOR) - (if (NOT (EQL (ARRAY-TOTAL-SIZE BVECTOR) - N)) - then (HELP "BVECTOR not of size" N))) (* Check for zero diagonal elements) - (if (for I from 0 to (SUB1 N) thereis (UFEQP 0.0 (\FLOATAREF LMATRIX I I))) - then (HELP "LMATRIX has a zero diagonal element")) - - (* * Solution by forward substitution) - (* Copy CVECTOR to BVECTOR) - (BLAS.ARRAYBLT CVECTOR 0 1 BVECTOR 0 1 N) (* Compute the first value) - (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR 0) - (\FLOATAREF LMATRIX 0 0)) - BVECTOR 0) - (for J from 1 to (SUB1 N) do (BLAS.AXPY (FMINUS (\FLOATAREF BVECTOR (SUB1 J))) - LMATRIX - (IPLUS (SUB1 J) - (ITIMES J N)) - N BVECTOR J 1 (IDIFFERENCE N J)) - (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR J) - (\FLOATAREF LMATRIX J J)) - BVECTOR J)) - (RETURN BVECTOR]) - -(LUFACTOR - [LAMBDA (MATRIX PIVOTVECTOR FACTORMATRIX) (* jop: "27-May-86 20:21") - - (* * Computes the LU decomposition of the N x N matrix MATRIX by Gauss - elimination with row pivoting. FACTORMATRIX will be overwritten with the packed - result. PIVOTVECTOR will be a vector of smallposp's, holding the pivot - permutation, and must be supplied. Returns NIL in the normal case, else returns - the row index) - - (* * Lifted from LINPACK algorithm SGESL) - - (BLAS.CHECKARRAY MATRIX) - (if (NOT (AND (type? ARRAY PIVOTVECTOR) - (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR) - T))) - then (HELP "Must be a pointer array" PIVOTVECTOR)) - (LET ((N (ARRAY-DIMENSION MATRIX 0))) - - (* * Arg Checks) - - (if [AND (EQL 2 (ARRAY-RANK MATRIX)) - (NOT (EQL N (ARRAY-DIMENSION MATRIX 1] - then (HELP "MATRIX not square" MATRIX)) - (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR)) - (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR] - then (HELP "PIVOTVECTOR not of size N" PIVOTVECTOR)) - (if (NULL FACTORMATRIX) - then (SETQ FACTORMATRIX (MAKE-ARRAY (LIST N N) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY FACTORMATRIX) - (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX) - (ARRAY-DIMENSIONS MATRIX))) - then (HELP "Illegal FACTORMATRIX" FACTORMATRIX))) - (* Copy MATRIX to FACTORMATRIX) - (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1) - - (* * Compute the LU decomposition of FACTORMATRIX) - - [bind PIVOTINDEX TEMP for K from 0 to (IDIFFERENCE N 2) - do (* find pivot index) - (SETQ PIVOTINDEX (IPLUS (BLAS.MAX FACTORMATRIX (IPLUS K (ITIMES N K)) - N - (IDIFFERENCE N K)) - K)) - (PASET PIVOTINDEX PIVOTVECTOR K) - (if (NOT (FEQP (\FLOATAREF FACTORMATRIX PIVOTINDEX K) - 0.0)) - then (if (NOT (EQL PIVOTINDEX K)) - then (* Interchange) - (SETQ TEMP (\FLOATAREF FACTORMATRIX PIVOTINDEX K)) - (\FLOATASET (\FLOATAREF FACTORMATRIX K K) - FACTORMATRIX PIVOTINDEX K) - (\FLOATASET TEMP FACTORMATRIX K K)) - (* compute Multpliers) - (BLAS.SCAL (FMINUS (FQUOTIENT 1.0 (\FLOATAREF FACTORMATRIX K K))) - FACTORMATRIX - (IPLUS K (ITIMES N (ADD1 K))) - N - (SUB1 (IDIFFERENCE N K))) (* Row eliminate with column indexing) - (bind (KPLUS1 _ (ADD1 K)) for J from (ADD1 K) to (SUB1 N) - do (SETQ TEMP (\FLOATAREF FACTORMATRIX PIVOTINDEX J)) - (if (NOT (EQL PIVOTINDEX K)) - then (* Interchange) - (\FLOATASET (\FLOATAREF FACTORMATRIX K J) - FACTORMATRIX PIVOTINDEX J) - (\FLOATASET TEMP FACTORMATRIX K J)) - (BLAS.AXPY TEMP FACTORMATRIX (IPLUS K (ITIMES N KPLUS1)) - N FACTORMATRIX (IPLUS J (ITIMES N KPLUS1)) - N - (IDIFFERENCE N KPLUS1] (* No row elimination on last column) - (PASET (SUB1 N) - PIVOTVECTOR - (SUB1 N)) - FACTORMATRIX]) - -(LUINVERSE - [LAMBDA (LUMATRIX PIVOTVECTOR SOLUTION) (* jop: "26-May-86 18:17") - - (* * Forms MATRIX inverse where LUMATRIX and PIVOTVECTOR are the outputs of - LUFACTOR.) - - (* * lifted from LINPACK SGEDI) - - (BLAS.CHECKARRAY LUMATRIX) - (if (NOT (AND (type? ARRAY PIVOTVECTOR) - (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR) - T))) - then (HELP "Must be an array of pointers" PIVOTVECTOR)) - (PROG ((N (ARRAY-DIMENSION LUMATRIX 0))) - - (* * Arg Checks) - - (if [AND (EQL 2 (ARRAY-RANK LUMATRIX)) - (NOT (EQL N (ARRAY-DIMENSION LUMATRIX 1] - then (HELP "MATRIX not square" LUMATRIX)) - (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR)) - (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR] - then (HELP "PIVOTVECTOR not a vector of size N" PIVOTVECTOR)) - (if (NULL SOLUTION) - then (SETQ SOLUTION (MAKE-ARRAY (LIST N N) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY SOLUTION) - (if [NOT (AND (EQL 2 (ARRAY-RANK SOLUTION)) - (EQUAL (ARRAY-DIMENSIONS LUMATRIX) - (ARRAY-DIMENSIONS SOLUTION] - then (HELP "SOLUTION not an N x N array" SOLUTION))) - (* copy LUMATRIX to SOLUTION) - (BLAS.ARRAYBLT LUMATRIX 0 1 SOLUTION 0 1) - - (* * first compute INVERSE (U)) - - [bind TEMP for K from 0 to (SUB1 N) - do (\FLOATASET (FQUOTIENT 1.0 (\FLOATAREF SOLUTION K K)) - SOLUTION K K) - (SETQ TEMP (FMINUS (\FLOATAREF SOLUTION K K))) - (BLAS.SCAL TEMP SOLUTION K N K) - (bind TEMP for J from (ADD1 K) to (SUB1 N) - do (SETQ TEMP (\FLOATAREF SOLUTION K J)) - (\FLOATASET 0.0 SOLUTION K J) - (BLAS.AXPY TEMP SOLUTION K N SOLUTION J N (ADD1 K] - - (* * Form INVERSE (U) *INVERSE (L)) - - (bind (TEMPARRAY _ (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - L for K from (IDIFFERENCE N 2) to 0 by -1 - do (for I from (ADD1 K) to (SUB1 N) do (\FLOATASET (\FLOATAREF SOLUTION I K) - TEMPARRAY I) - (\FLOATASET 0.0 SOLUTION I K)) - (bind TEMP for J from (ADD1 K) to (SUB1 N) - do (SETQ TEMP (\FLOATAREF TEMPARRAY J)) - (BLAS.AXPY TEMP SOLUTION J N SOLUTION K N N)) - (SETQ L (PAREF PIVOTVECTOR K)) - (if (NEQ L K) - then (BLAS.SWAP SOLUTION K N SOLUTION L N N))) - (RETURN SOLUTION]) - -(LUSOLV - [LAMBDA (LUMATRIX PIVOTVECTOR CVECTOR SOLUTION) (* jop: "27-May-86 20:39") - - (* * Solves to system A x = b. LUMATRIX and PIVOTVECTOR should be the outputs - of LUFACTOR. CVECTOR should to the RHS of the system. - Returns SOLUTION) - - (* * lifted from LINPACK SGESL) - - (BLAS.CHECKARRAY LUMATRIX) - (if (NOT (AND (type? ARRAY PIVOTVECTOR) - (EQ (ARRAY-ELEMENT-TYPE PIVOTVECTOR) - T))) - then (HELP "Must be an array of pointers" PIVOTVECTOR)) - (BLAS.CHECKARRAY CVECTOR) - (PROG ((N (ARRAY-DIMENSION LUMATRIX 0))) - - (* * Arg Checks) - - (if [AND (EQL 2 (ARRAY-RANK LUMATRIX)) - (NOT (EQL N (ARRAY-DIMENSION LUMATRIX 1] - then (HELP "MATRIX not square" LUMATRIX)) - (if [NOT (AND (EQL 1 (ARRAY-RANK PIVOTVECTOR)) - (EQL N (ARRAY-TOTAL-SIZE PIVOTVECTOR] - then (HELP "PIVOTVECTOR not a vector of size N" PIVOTVECTOR)) - (if [NOT (AND (EQL 1 (ARRAY-RANK CVECTOR)) - (EQL N (ARRAY-TOTAL-SIZE CVECTOR] - then (HELP "CVECTOR not a vector of size N" CVECTOR)) - (if (NULL SOLUTION) - then (SETQ SOLUTION (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY SOLUTION) - (if [NOT (AND (EQL 1 (ARRAY-RANK SOLUTION)) - (EQL N (ARRAY-TOTAL-SIZE SOLUTION] - then (HELP "SOLUTION not avector of size N" SOLUTION))) - (* Copy CVECTOR to SOLUTION) - (BLAS.ARRAYBLT CVECTOR 0 1 SOLUTION 0 1 N) - - (* * First solve L*y = b) - - [bind PIVOTINDEX TEMP for K from 0 to (IDIFFERENCE N 2) - do (SETQ PIVOTINDEX (PAREF PIVOTVECTOR K)) - (SETQ TEMP (\FLOATAREF SOLUTION PIVOTINDEX)) - (if (NOT (EQL PIVOTINDEX K)) - then (* interchange) - (\FLOATASET (\FLOATAREF SOLUTION K) - SOLUTION PIVOTINDEX) - (\FLOATASET TEMP SOLUTION K)) - (BLAS.AXPY TEMP LUMATRIX (IPLUS K (ITIMES N (ADD1 K))) - N SOLUTION (ADD1 K) - 1 - (IDIFFERENCE N (ADD1 K] - - (* * Then solve U*x = y) - - (bind TEMP for K from (SUB1 N) to 0 by -1 - do (SETQ TEMP (FMINUS (\FLOATASET (FQUOTIENT (\FLOATAREF SOLUTION K) - (\FLOATAREF LUMATRIX K K)) - SOLUTION K))) - (BLAS.AXPY TEMP LUMATRIX K N SOLUTION 0 1 K)) - (RETURN SOLUTION]) - -(MTIMES - [LAMBDA (A B PRODUCT) (* jop: " 4-Jun-86 13:08") - - (* * Matrix multiply. A may be an N vector or a (M x N) matrix and B may be a N vector or a N x P matrix. - PRODUCT defualts to a M x P array. RETURNS PRODUCT) - - - (BLAS.CHECKARRAY A) - (BLAS.CHECKARRAY B) - (LET ((RANKA (ARRAY-RANK A)) - (RANKB (ARRAY-RANK B)) - M N P RESULTDIMS) - (if (NOT (OR (EQ RANKA 1) - (EQ RANKA 2))) - then (HELP "A not a one-d or two-d array" A)) - (if (NOT (OR (EQ RANKB 1) - (EQ RANKB 2))) - then (HELP "B not a one-d or two-d array" B)) - (SETQ M (if (EQ RANKA 1) - then 1 - else (ARRAY-DIMENSION A 0))) - (SETQ N (if (EQ RANKA 1) - then (ARRAY-DIMENSION A 0) - else (ARRAY-DIMENSION A 1))) - (SETQ P (if (EQ RANKB 1) - then 1 - else (ARRAY-DIMENSION B 1))) - [SETQ RESULTDIMS (if (EQ M 1) - then (if (EQ P 1) - then NIL - else (LIST P)) - else (if (EQ P 1) - then (LIST M) - else (LIST M P] - - (* * Check args) - - - (if (NOT (EQ (ARRAY-DIMENSION B 0) - N)) - then (HELP "Leading dimension of B not N" B)) - (if (NULL PRODUCT) - then (SETQ PRODUCT (MAKE-ARRAY RESULTDIMS (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - elseif (NOT (EQUAL (ARRAY-DIMENSIONS PRODUCT) - RESULTDIMS)) - then (HELP "C of incorrect size" PRODUCT)) - - (* * Do the multiply) - - - [bind (ABASE _(ARRAYBASE A)) - (BBASE _(ARRAYBASE B)) - (CBASE _(ARRAYBASE PRODUCT)) for I from 0 to (SUB1 M) - do (for J from 0 to (SUB1 P) as COFFSET from (MUL2 (ITIMES P I)) - by 2 do (bind (FTEMP _ 0.0) declare (TYPE FLOATP FTEMP) for K - from 0 to (SUB1 N) as AOFFSET - from (MUL2 (ITIMES N I)) by 2 as BOFFSET - from (MUL2 J) by (MUL2 P) - do [SETQ FTEMP (FPLUS FTEMP (FTIMES (\GETBASEFLOATP - ABASE AOFFSET) - (\GETBASEFLOATP - BBASE BOFFSET] - finally (\PUTBASEFLOATP CBASE COFFSET FTEMP] - PRODUCT]) - -(QRFACTOR - [LAMBDA (MATRIX QRAUX FACTORMATRIX) (* jop: "27-May-86 16:27") - - (* * Computes the LU decomposition of the N x N matrix MATRIX by Gauss - elimination with row pivoting. FACTORMATRIX will be overwritten with the packed - result. QRAUX will be a vector of smallposp's, holding the pivot permutation, - and must be supplied. Returns NIL in the normal case, else returns the row - index) - - (* * Lifted from LINPACK algorithm SGESL) - - (BLAS.CHECKARRAY MATRIX) - (BLAS.CHECKARRAY QRAUX) - (LET ((N (ARRAY-DIMENSION MATRIX 0)) - (P (ARRAY-DIMENSION MATRIX 1))) - - (* * Arg Checks) - - (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX)) - (EQL P (ARRAY-TOTAL-SIZE QRAUX] - then (HELP "QRAUX not of size P" QRAUX)) - (if (NULL FACTORMATRIX) - then (SETQ FACTORMATRIX (MAKE-ARRAY (ARRAY-DIMENSIONS MATRIX) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY FACTORMATRIX) - (if (NOT (EQUAL (ARRAY-DIMENSIONS FACTORMATRIX) - (ARRAY-DIMENSIONS MATRIX))) - then (HELP "Illegal FACTORMATRIX" FACTORMATRIX))) - (* Copy MATRIX to FACTORMATRIX) - (BLAS.ARRAYBLT MATRIX 0 1 FACTORMATRIX 0 1) - - (* * Compute the QR decomposition of FACTORMATRIX) - - (for I from 0 to (SUB1 P) do (\FLOATASET 0.0 QRAUX I)) - (bind NRMXL for L from 0 to (SUB1 (IMIN N P)) unless (EQL L (SUB1 N)) - do (* Compute the Householder - transformation for column L) - (SETQ NRMXL (BLAS.NRM2 FACTORMATRIX (IPLUS L (ITIMES P L)) - P - (IDIFFERENCE N L))) - (if (FGREATERP NRMXL 0.0) - then (if (FLESSP (\FLOATAREF FACTORMATRIX L L) - 0.0) - then (SETQ NRMXL (FMINUS NRMXL))) - (BLAS.SCAL (FQUOTIENT 1.0 NRMXL) - FACTORMATRIX - (IPLUS L (ITIMES P L)) - P - (IDIFFERENCE N L)) - (\FLOATASET (FPLUS 1.0 (\FLOATAREF FACTORMATRIX L L)) - FACTORMATRIX L L) (* apply the transform to the - remaining columns) - (bind TEMP for J from (ADD1 L) to (SUB1 P) - do [SETQ TEMP (FMINUS (FQUOTIENT (BLAS.DOTPROD FACTORMATRIX - (IPLUS L (ITIMES P L)) - P FACTORMATRIX - (IPLUS J (ITIMES P L)) - P - (IDIFFERENCE N L)) - (\FLOATAREF FACTORMATRIX L L] - (BLAS.AXPY TEMP FACTORMATRIX (IPLUS L (ITIMES P L)) - P FACTORMATRIX (IPLUS J (ITIMES P L)) - P - (IDIFFERENCE N L))) - (\FLOATASET (\FLOATAREF FACTORMATRIX L L) - QRAUX L) - (\FLOATASET (FMINUS NRMXL) - FACTORMATRIX L L))) - FACTORMATRIX]) - -(QROLS - [LAMBDA (QRMATRIX QRAUX Y QTY B RSD YHAT) (* jop: "27-May-86 17:21") - - (* * Lifted from LINPACK algorithm SQRSL) - - (BLAS.CHECKARRAY QRMATRIX) - (BLAS.CHECKARRAY QRAUX) - (BLAS.CHECKARRAY Y) - (LET ((N (ARRAY-DIMENSION QRMATRIX 0)) - (P (ARRAY-DIMENSION QRMATRIX 1))) - - (* * Arg Checks) - - (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX)) - (EQL P (ARRAY-TOTAL-SIZE QRAUX] - then (HELP "QRAUX not of size P" QRAUX)) - (if [NOT (AND (EQL 1 (ARRAY-RANK Y)) - (EQL N (ARRAY-TOTAL-SIZE Y] - then (HELP "Y not of size N" Y)) - (if (NULL QTY) - then (SETQ QTY (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY QTY) - (if (NOT (EQL N (ARRAY-TOTAL-SIZE QTY))) - then (HELP "QTY not of size N" QTY))) - (if (NULL B) - then (SETQ B (MAKE-ARRAY P (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY B) - (if (NOT (EQL P (ARRAY-TOTAL-SIZE B))) - then (HELP "B not of size P" B))) - (if RSD - then (BLAS.CHECKARRAY RSD) - (if (NOT (EQL N (ARRAY-TOTAL-SIZE RSD))) - then (HELP "RSD not of size N" RSD))) - (if YHAT - then (BLAS.CHECKARRAY YHAT) - (if (NOT (EQL N (ARRAY-TOTAL-SIZE YHAT))) - then (HELP "XB not of size N" YHAT))) (* Compute TRANS (Q) * Y) - (QRQTY QRMATRIX QRAUX Y QTY) - - (* * Compute B) - (* Set up computation of B) - (BLAS.ARRAYBLT QTY 0 1 B 0 1 P) - (for J from (SUB1 P) to 0 by -1 - do (if (UFEQP (\FLOATAREF QRMATRIX J J) - 0.0) - then (HELP "Singular Matrix" QRMATRIX)) - (\FLOATASET (FQUOTIENT (\FLOATAREF B J) - (\FLOATAREF QRMATRIX J J)) - B J) - (if (NOT (EQL J 0)) - then (BLAS.AXPY (FMINUS (\FLOATAREF B J)) - QRMATRIX J P B 0 1 J))) - - (* * Compute RSD) - - [if RSD - then (* Set up computation of RSD) - (if (ILESSP P N) - then (BLAS.ARRAYBLT QTY P 1 RSD P 1)) - (BLAS.ARRAYFILL 0.0 RSD 0 1 P) - (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1 - do (if (NOT (UFEQP (\FLOATAREF QRAUX J) - 0.0)) - then (SETQ TEMP (\FLOATAREF QRMATRIX J J)) - (\FLOATASET (\FLOATAREF QRAUX J) - QRMATRIX J J) - (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX - (IPLUS J (ITIMES P J)) - P RSD J 1 (IDIFFERENCE N J)) - (\FLOATAREF QRMATRIX J J))) - QRMATRIX - (IPLUS J (ITIMES P J)) - P RSD J 1 (IDIFFERENCE N J)) - (\FLOATASET TEMP QRMATRIX J J))) - - (* * Compute YHAT) - - (if YHAT - then (* Set up computation of YHAT) - (BLAS.ARRAYBLT QTY 0 1 YHAT 0 1 P) - (BLAS.ARRAYFILL 0.0 YHAT P 1) - (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1 - do (if (NOT (UFEQP (\FLOATAREF QRAUX J) - 0.0)) - then (SETQ TEMP (\FLOATAREF QRMATRIX J J)) - (\FLOATASET (\FLOATAREF QRAUX J) - QRMATRIX J J) - (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX - (IPLUS J (ITIMES P J)) - P YHAT J 1 (IDIFFERENCE - N J)) - (\FLOATAREF QRMATRIX J J))) - QRMATRIX - (IPLUS J (ITIMES P J)) - P YHAT J 1 (IDIFFERENCE N J)) - (\FLOATASET TEMP QRMATRIX J J] - B]) - -(QRQTY - [LAMBDA (QRMATRIX QRAUX Y PRODUCT) (* jop: "27-May-86 16:28") - - (* * COMPUTE (TRANS Q) * Y given a QR factorization described by QRMATRIX and - QRAUX where Y is an N vector) - - (* * Lifted from LINPACK algorithm SQRSL) - - (BLAS.CHECKARRAY QRMATRIX) - (BLAS.CHECKARRAY QRAUX) - (BLAS.CHECKARRAY Y) - (LET ((N (ARRAY-DIMENSION QRMATRIX 0)) - (P (ARRAY-DIMENSION QRMATRIX 1))) - - (* * Arg Checks) - - (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX)) - (EQL P (ARRAY-TOTAL-SIZE QRAUX] - then (HELP "QRAUX not of size P" QRAUX)) - (if [NOT (AND (EQL 1 (ARRAY-RANK Y)) - (EQL N (ARRAY-TOTAL-SIZE Y] - then (HELP "Y not of size N" Y)) - (if (NULL PRODUCT) - then (SETQ PRODUCT (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY PRODUCT) - (if (NOT (EQL N (ARRAY-TOTAL-SIZE PRODUCT))) - then (HELP "PRODUCT not of size N" PRODUCT))) - (BLAS.ARRAYBLT Y 0 1 PRODUCT 0 1 N) - (bind TEMP for J from 0 to (IMIN P (SUB1 N)) - do (if (NOT (UFEQP (\FLOATAREF QRAUX J) - 0.0)) - then (SETQ TEMP (\FLOATAREF QRMATRIX J J)) - (\FLOATASET (\FLOATAREF QRAUX J) - QRMATRIX J J) - (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX (IPLUS J - (ITIMES P J)) - P PRODUCT J 1 (IDIFFERENCE N J)) - (\FLOATAREF QRMATRIX J J))) - QRMATRIX - (IPLUS J (ITIMES P J)) - P PRODUCT J 1 (IDIFFERENCE N J)) - (\FLOATASET TEMP QRMATRIX J J))) - PRODUCT]) - -(QRQY - [LAMBDA (QRMATRIX QRAUX Y PRODUCT) (* jop: "27-May-86 16:30") - - (* * COMPUTE QX given a QR factorization described by QRMATRIX and QRAUX where - Y is an N vector) - - (* * Lifted from LINPACK algorithm SQRSL) - - (BLAS.CHECKARRAY QRMATRIX) - (BLAS.CHECKARRAY QRAUX) - (BLAS.CHECKARRAY Y) - (LET ((N (ARRAY-DIMENSION QRMATRIX 0)) - (P (ARRAY-DIMENSION QRMATRIX 1))) - - (* * Arg Checks) - - (if [NOT (AND (EQL 1 (ARRAY-RANK QRAUX)) - (EQL P (ARRAY-TOTAL-SIZE QRAUX] - then (HELP "QRAUX not of size P" QRAUX)) - (if [NOT (AND (EQL 1 (ARRAY-RANK Y)) - (EQL N (ARRAY-TOTAL-SIZE Y] - then (HELP "Y not of size N" Y)) - (if (NULL PRODUCT) - then (SETQ PRODUCT (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY PRODUCT) - (if (NOT (EQL N (ARRAY-TOTAL-SIZE PRODUCT))) - then (HELP "PRODUCT not of size N" PRODUCT))) - (BLAS.ARRAYBLT Y 0 1 PRODUCT 0 1 N) - (bind TEMP for J from (SUB1 (IMIN P (SUB1 N))) to 0 by -1 - do (if (NOT (UFEQP (\FLOATAREF QRAUX J) - 0.0)) - then (SETQ TEMP (\FLOATAREF QRMATRIX J J)) - (\FLOATASET (\FLOATAREF QRAUX J) - QRMATRIX J J) - (BLAS.AXPY (FMINUS (FQUOTIENT (BLAS.DOTPROD QRMATRIX (IPLUS J - (ITIMES P J)) - P PRODUCT J 1 (IDIFFERENCE N J)) - (\FLOATAREF QRMATRIX J J))) - QRMATRIX - (IPLUS J (ITIMES P J)) - P PRODUCT J 1 (IDIFFERENCE N J)) - (\FLOATASET TEMP QRMATRIX J J))) - PRODUCT]) - -(QRSOLV - [LAMBDA (QRMATRIX QRAUX BVECTOR SOLUTION) (* jop: "27-May-86 20:38") - - (* * Solves to system A x = b. BVECTOR should to the RHS of the system. Returns SOLUTION) - - - (RSOLV QRMATRIX (QRQTY QRMATRIX QRAUX BVECTOR SOLUTION) - SOLUTION]) - -(MREGRESS - [LAMBDA (Y X B RSD YHAT) (* jop: " 4-Jun-86 14:12") - - (* * MREGRESS calculates the least squares (multiple) regression of Y on X. An N vector Y.) - - - (LET* ((QRAUX (MAKE-ARRAY (ARRAY-DIMENSION X 1) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - (QRMATRIX (QRFACTOR X QRAUX))) - (QROLS QRMATRIX QRAUX Y NIL B RSD YHAT]) - -(RSOLV - [LAMBDA (RMATRIX CVECTOR BVECTOR) (* jop: "28-May-86 20:31") - - (* * Calcluate the solution vector BVECTOR for the system of linear equations - R*B=C, where RMATRIX is upper triangular M X N with non-zero diagonal elements. - BVECTOR and CVECTOR must be of size N. Always returns BVECTOR) - - (BLAS.CHECKARRAY RMATRIX) - (BLAS.CHECKARRAY CVECTOR) - (PROG ((M (ARRAY-DIMENSION RMATRIX 0)) - (N (ARRAY-DIMENSION RMATRIX 1))) - - (* * Arg Checks) - - (if (ILESSP M N) - then (HELP "Order of system less than" N)) - (if (NOT (EQL (ARRAY-TOTAL-SIZE CVECTOR) - N)) - then (HELP "CVECTOR not of size" N)) - (if (NULL BVECTOR) - then (SETQ BVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY BVECTOR) - (if (NOT (EQL (ARRAY-TOTAL-SIZE BVECTOR) - N)) - then (HELP "BVECTOR not of size" N))) (* Check for zero diagonal elements) - (if (for I from 0 to (SUB1 N) thereis (UFEQP 0.0 (\FLOATAREF RMATRIX I I))) - then (HELP "RMATRIX has a zero diagonal element")) - - (* * Solution by backsubstitution.) - - (BLAS.ARRAYBLT CVECTOR 0 1 BVECTOR 0 1 N) - (LET ((INDEXLIMIT (SUB1 N))) (* Compute the last value) - (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR INDEXLIMIT) - (\FLOATAREF RMATRIX INDEXLIMIT INDEXLIMIT)) - BVECTOR INDEXLIMIT) - (bind J JLESS1 for JJ from 1 to INDEXLIMIT - do (SETQ J (IDIFFERENCE N JJ)) - (SETQ JLESS1 (SUB1 J)) - (BLAS.AXPY (FMINUS (\FLOATAREF BVECTOR J)) - RMATRIX J N BVECTOR 0 1 J) - (\FLOATASET (FQUOTIENT (\FLOATAREF BVECTOR JLESS1) - (\FLOATAREF RMATRIX JLESS1 JLESS1)) - BVECTOR JLESS1))) - (RETURN BVECTOR]) - -(MSOLVE - [LAMBDA (MATRIX CVECTOR SOLUTION) (* jop: "27-May-86 20:40") - - (* * Solves to system A x = b. CVECTOR should to the RHS of the system. Returns SOLUTION) - - - (LET [(PIVOTVECTOR (MAKE-ARRAY (ARRAY-DIMENSION MATRIX 0] - (LUSOLV (LUFACTOR MATRIX PIVOTVECTOR) - PIVOTVECTOR CVECTOR SOLUTION]) - -(SVDFACTOR - [LAMBDA (XMATRIX SVECTOR UMATRIX VMATRIX) (* jop: "29-May-86 11:29") - - (* * Singular-value decomposition by means of orthogonalization by plane - rotations. Taken from Nash and Shlien: "Partial svd algorithms." On entry X - contains the M by N matrix to be decomposed, SVECTOR must be a vector of length - N and VMATRIX must be a square N by N matrix. - On return UMATRIX has been overwritten by the left singular vectors, SVECTOR - contains the singular values, and VMATRIX contains the right singular vectors.) - - (BLAS.CHECKARRAY XMATRIX) - (LET ((M (ARRAY-DIMENSION UMATRIX 0)) - (N (ARRAY-DIMENSION UMATRIX 1))) - - (* * Args checks) - - (if (NOT (EQL 2 (ARRAY-RANK XMATRIX))) - then (HELP "XMATRIX not a matrix" XMATRIX)) - (if (NULL SVECTOR) - then (SETQ SVECTOR (MAKE-ARRAY N (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY SVECTOR) - (if [NOT (AND (EQL 1 (ARRAY-RANK SVECTOR)) - (EQL N (ARRAY-TOTAL-SIZE SVECTOR] - then (HELP "Illegal SVECTOR" SVECTOR))) - (if (NULL UMATRIX) - then (SETQ UMATRIX (MAKE-ARRAY (LIST M N) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY UMATRIX) - (if (NOT (EQUAL (ARRAY-DIMENSIONS UMATRIX) - (ARRAY-DIMENSIONS XMATRIX))) - then (HELP "Illegal UMATRIX" UMATRIX))) - (if (NULL VMATRIX) - then (SETQ VMATRIX (MAKE-ARRAY (LIST N N) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - else (BLAS.CHECKARRAY VMATRIX) - (if (NOT (EQUAL (ARRAY-DIMENSIONS VMATRIX) - (LIST N N))) - then (HELP "Illegal VMATRIX" VMATRIX))) (* Copy XMATRIX to UMATRIX) - (BLAS.ARRAYBLT XMATRIX NIL NIL UMATRIX) (* Initialize VMATRIX to identity - matrix.) - (BLAS.ARRAYFILL 0.0 VMATRIX) - (for I from 0 to (SUB1 N) do (\FLOATASET 1.0 VMATRIX I I)) - - (* * Start the computation) - - (LET ((NT N)) - - (* * The main loop: repeatedly sweep over all pairs of columns in U, rotating - as needed, until no rotations in a complete sweep are effective. - Check the opportunity for rank reduction at the conclusion of each sweep.) - - [bind (EPS _ 1.0E-6) - (SLIMIT _ (IMAX (IQUOTIENT N 4) - 6)) - (SCOUNT _ 0) - RCOUNT eachtime (SETQ RCOUNT (IQUOTIENT (ITIMES NT (SUB1 NT)) - 2)) - (SETQ SCOUNT (ADD1 SCOUNT)) repeatwhile (IGREATERP RCOUNT 0) - do (if (IGREATERP SCOUNT SLIMIT) - then (HELP "Number of sweeps exceeds sweep limit." SCOUNT)) - [for J from 0 to (IDIFFERENCE NT 2) - do (bind P Q R C S V for K from (ADD1 J) to (SUB1 NT) - do (SETQ P (BLAS.DOTPROD UMATRIX J N UMATRIX K N M)) - (SETQ Q (BLAS.DOTPROD UMATRIX J N UMATRIX J N M)) - (SETQ R (BLAS.DOTPROD UMATRIX K N UMATRIX K N M)) - (\FLOATASET Q SVECTOR J) - (\FLOATASET R SVECTOR K) - (if (FLESSP Q R) - then (SETQ Q (FDIFFERENCE (FQUOTIENT Q R) - 1.0)) - (SETQ P (FQUOTIENT P R)) - [SETQ V (SQRT (SETQ V (FPLUS (FTIMES 4.0 P P) - (FTIMES Q Q] - [SETQ S (SQRT (FTIMES .5 (FDIFFERENCE 1.0 (FQUOTIENT Q V] - (if (FLESSP P 0.0) - then (SETQ S (FDIFFERENCE 0.0 S))) - (SETQ C (FQUOTIENT P (FTIMES V S))) - (BLAS.ROT C S UMATRIX J N UMATRIX K N M) - (BLAS.ROT C S VMATRIX J N VMATRIX K N N) - elseif (OR (LEQ (FTIMES Q R) - (FTIMES EPS EPS)) - (LEQ (FTIMES (FQUOTIENT P Q) - (FQUOTIENT P R)) - EPS)) - then (SETQ RCOUNT (SUB1 RCOUNT)) - else (SETQ R (FDIFFERENCE 1.0 (FQUOTIENT R Q))) - (SETQ P (FQUOTIENT P Q)) - [SETQ V (SQRT (SETQ V (FPLUS (FTIMES 4.0 P P) - (FTIMES R R] - [SETQ C (SQRT (FTIMES .5 (FPLUS 1.0 (FQUOTIENT R V] - (SETQ S (FQUOTIENT P (FTIMES V C))) - (* box before the COLROT calls) - (BLAS.ROT C S UMATRIX J N UMATRIX K N M) - (BLAS.ROT C S VMATRIX J N VMATRIX K N N] - (while (AND (IGEQ NT 3) - (LEQ (FQUOTIENT (\FLOATAREF SVECTOR (SUB1 NT)) - (FPLUS (\FLOATAREF SVECTOR 0) - EPS)) - EPS)) do (SETQ NT (SUB1 NT] - - (* * Finish the decomposition by returning all N singular values, and by - normalizing those columns of UMATRIX judged to be non-zero.) - - (bind Q for J from 0 to (SUB1 N) do (SETQ Q (SQRT (\FLOATAREF SVECTOR J))) - (\FLOATASET Q SVECTOR J) - (if (ILEQ J NT) - then (BLAS.SCAL (FQUOTIENT 1.0 Q) - UMATRIX J N M))) - SVECTOR]) - -(SVDTEST - [LAMBDA NIL (* jop: "30-Jan-86 17:37") - - (* * comment) - - - (LET ((UU (MAKE-ARRAY (QUOTE (24 19)) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - (SS (MAKE-ARRAY 19 (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - (VV (MAKE-ARRAY (QUOTE (19 19)) - (QUOTE :ELEMENT-TYPE) - (QUOTE FLOAT))) - (L 0)) - [for TT from 1.0 to 3.0 do (for PP from 1.0 to 2.0 - do (for CC from 1.0 to 4.0 - do (ASET TT UU L 0) - (ASET PP UU L 1) - (ASET CC UU L 2) - (ASET (FTIMES TT PP) - UU L 3) - (ASET (FTIMES TT CC) - UU L 4) - (ASET (FTIMES PP CC) - UU L 5) - (ASET (FTIMES PP PP) - UU L 6) - (ASET (FTIMES CC CC) - UU L 7) - (ASET (FTIMES TT TT) - UU L 8) - (ASET (FTIMES TT PP PP) - UU L 9) - (ASET (FTIMES TT CC CC) - UU L 10) - (ASET (FTIMES PP TT TT) - UU L 11) - (ASET (FTIMES PP CC CC) - UU L 12) - (ASET (FTIMES CC TT TT) - UU L 13) - (ASET (FTIMES CC PP PP) - UU L 14) - (ASET (FTIMES TT TT TT) - UU L 15) - (ASET (FTIMES PP PP PP) - UU L 16) - (ASET (FTIMES CC CC CC) - UU L 17) - (ASET (FTIMES TT PP CC) - UU L 18) - (SETQ L (ADD1 L] - (TIMEALL (SVDNASH UU SS VV]) - -(\FLOATAREFMACRO - [LAMBDA (ARGS) (* jop: "26-May-86 16:02") - - (* * macro expander for \FLOATAREF) - - (if (IGREATERP (LENGTH ARGS) - 3) - then (HELP "\FLOATAREF takes no more than three args" ARGS)) - (PROG ((BARRAY (CAR ARGS)) - (BINDICES (CDR ARGS)) - INDEXFORM) - [if (EQLENGTH BINDICES 1) - then (SETQ INDEXFORM (CAR BINDICES)) - else (SETQ INDEXFORM (BQUOTE (IPLUS , (CADR BINDICES) - (ITIMES , (CAR BINDICES) - (ARRAY-DIMENSION , BARRAY 1] - (RETURN (BQUOTE (\GETBASEFLOATP (ARRAYBASE , BARRAY) - (LLSH , INDEXFORM 1]) - -(\FLOATASETMACRO - [LAMBDA (ARGS) (* jop: "26-May-86 16:03") - - (* * macro expander for \FLOATASET) - - (if (IGREATERP (LENGTH ARGS) - 4) - then (HELP "\FLOATASET takes no more than four args" ARGS)) - (PROG ((BNEWVALUE (CAR ARGS)) - (BARRAY (CADR ARGS)) - (BINDICES (CDDR ARGS)) - INDEXFORM) - [if (EQLENGTH BINDICES 1) - then (SETQ INDEXFORM (CAR BINDICES)) - else (SETQ INDEXFORM (BQUOTE (IPLUS , (CADR BINDICES) - (ITIMES , (CAR BINDICES) - (ARRAY-DIMENSION , BARRAY 1] - (RETURN (BQUOTE (\PUTBASEFLOATP (ARRAYBASE , BARRAY) - (LLSH , INDEXFORM 1) - , BNEWVALUE]) -) - -(RPAQQ STACK ((80 27 89) - (80 27 88) - (75 25 90) - (62 24 87) - (62 22 87) - (62 23 87) - (62 24 93) - (62 24 93) - (58 23 87) - (58 18 80) - (58 18 89) - (58 17 88) - (58 18 82) - (58 19 93) - (50 18 89) - (50 18 86) - (50 19 72) - (50 19 79) - (50 20 80) - (56 20 82) - (70 20 91))) -(DECLARE: EVAL@COMPILE -(PUTPROPS \FLOATAREF MACRO (ARGS (* *) - (\FLOATAREFMACRO ARGS))) -(PUTPROPS \FLOATASET MACRO (ARGS (* *) - (\FLOATASETMACRO ARGS))) -) -(FILESLOAD BLAS) -(PUTPROPS MATRIXOPS COPYRIGHT ("Xerox Corporation" 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (665 47755 (CHOLESKYFACTOR 675 . 3149) (MTRANSPOSE 3151 . 4438) (MINVERT 4440 . 4810) ( -LSOLV 4812 . 7212) (LUFACTOR 7214 . 11565) (LUINVERSE 11567 . 14760) (LUSOLV 14762 . 17799) (MTIMES -17801 . 20328) (QRFACTOR 20330 . 24388) (QROLS 24390 . 29552) (QRQTY 29554 . 31713) (QRQY 31715 . -33879) (QRSOLV 33881 . 34176) (MREGRESS 34178 . 34600) (RSOLV 34602 . 36899) (MSOLVE 36901 . 37272) ( -SVDFACTOR 37274 . 44236) (SVDTEST 44238 . 46004) (\FLOATAREFMACRO 46006 . 46838) (\FLOATASETMACRO -46840 . 47753))))) -STOP diff --git a/obsolete/lispusers/MESATOLISP b/obsolete/lispusers/MESATOLISP deleted file mode 100644 index ae2f7d4b..00000000 --- a/obsolete/lispusers/MESATOLISP +++ /dev/null @@ -1,5810 +0,0 @@ -(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) -(FILECREATED "10-Apr-87 18:07:52" {ERIS}LYRIC>MESATOLISP.;4 285413 - - changes to%: (VARS MESATOLISPCOMS) - (FNS SCAN.START SCAN.TOKEN PARSE.CEDAR PARSE.BIN PARSE.FILE) - - previous date%: " 9-Apr-87 12:25:12" {ERIS}LYRIC>MESATOLISP.;3) - - -(* " -Copyright (c) 1985, 1987 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT MESATOLISPCOMS) - -(RPAQQ MESATOLISPCOMS - [ - (* ;; "MESATOLISP -- By Kelly Roach. Lyricized by L. Masinter") - - (COMS - -(* ;;; "SCAN: reading mesa/cedar files") - - [INITVARS (SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE - 'CL:CHARACTER :ADJUSTABLE T :FILL-POINTER 0)) - (SCAN.CHAR NIL) - (SCAN.QDOT NIL) - (SCAN.BOTH.RESERVED '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS - ALL AND ANY APPLY ARRAY BASE BEGIN BROADCAST CODE - COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT - DESCRIPTOR DIRECTORY DO ELSE ENABLE END ENDCASE ENDLOOP - ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK - FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL - ISTYPE JOIN LAST LENGTH LOCKS LONG LOOP LOOPHOLE MACHINE - MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY - NULL OF OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT - PRED PRIVATE PROC PROCEDURE PROCESS PROGRAM PUBLIC - READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME - RETRY RETURN RETURNS SELECT SEQUENCE SHARES SIGNAL SIZE - START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH - TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE - %[ %] ^ _ { %| } ~)) - (SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED - UNCHECKED UNSAFE)) - (SCAN.MESA.RESERVED '(RESIDENT] - (FNS SCAN.INIT SCAN.START SCAN.TEST SCAN.TESTFILE SCAN.OPENSTREAM SCAN.TOKEN - SCAN.NUMBER SCAN.ACCEPT SCAN.APPENDDECIMAL SCAN.APPENDOCTAL SCAN.APPENDHEX - SCAN.APPENDTOSCALE SCAN.VALIDFRACTION SCAN.DECIMAL SCAN.OCTAL SCAN.OCTALCHAR - SCAN.HEX SCAN.FLOATING SCAN.ESCAPE) - (P (SCAN.INIT))) - (COMS (* ; "PARSE *") - [INITVARS (PARSE.FILELST NIL) - (PARSE.STREAM NIL) - (PARSE.FILECOMS NIL) - (PARSE.LANGUAGE NIL) - (PARSE.DIRLST NIL) - (PARSE.CLASS NIL) - (PARSE.ATOM NIL) - (PARSE.CLASS2 NIL) - (PARSE.ATOM2 NIL) - (PARSE.CASEHEAD.FIRST '(WITH SELECT)) - (PARSE.DEFHEAD.FIRST '(DEFINITIONS)) - (PARSE.DEPENDENT.FIRST '(MACHINE)) - (PARSE.DOTEST.FIRST '(UNTIL WHILE)) - (PARSE.FORCLAUSE.FIRST '(FOR THROUGH)) - (PARSE.HEAP.FIRST '(UNCOUNTED)) - (PARSE.INTERVAL.FIRST '(%( %[)) - (PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~)) - (PARSE.ORDERED.FIRST '(ORDERED)) - (PARSE.ORDERLIST.FOLLOW '(! ; END %] })) - (PARSE.PACKED.FIRST '(PACKED)) - (PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC)) - (PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT)) - (PARSE.QUALIFIER.FIRST '(%. %[ ^)) - (PARSE.RANGE.FOLLOW '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS - FINISHED FROM NULL OR REPEAT SELECT THEN TRASH UNTIL - WHILE %] })) - (PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START - TRANSFER)) - (PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL)) - (PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START)) - (PARSE.TYPECONS.FIRST '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE - MONITORED ORDERED PACKED POINTER PORT PROC PORCEDURE - PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {)) - (PARSE.TYPEOP.FIRST '(FIRST LAST NILL)) - (PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE)) - (PARSE.CATCHLIST.FOLLOW '(END %] })) - (PARSE.CONTROLID.FOLLOW '(DECREASING IN _)) - (PARSE.DECLIST.FOLLOW '(; END })) - (PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] })) - (PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED })) - (PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES)) - (PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] })) - (PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] })) - (PARSE.SCOPE.FOLLOW '(END EXITS })) - (PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT })) - (PARSE.TYPEEXP.FOLLOW '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF - SHARES %] _ })) - (PARSE.PREDEFINED.TYPES '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION - INT INTEGER MDSZone MONITORLOCK NAT REAL STRING - StringBody UNSPECIFIED WORD)) - (PARSE.RELOPS (LIST '= '%# '< '<= '> '>=)) - (PARSE.ADDOPS (LIST '+ '-)) - (PARSE.MULTOPS (LIST '* '/ 'MOD)) - (PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK)) - (PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH)) - (PARSE.TYPEOPS '(FIRST LAST NILL)) - (PARSE.NOTS '(~ NOT] - (RECORDS PARSERSTATE MINTERVAL MRANGE MRELATIVE MPAINTED MENUMERATED MRECORD MVAR - MARRAY MDESCRIPTOR MFRAME MREF MLIST PAIRITEM DEFAULT TYPELIST TYPEITEM MPOINTER - CASEHEAD BINDITEM KEYITEM FIELDLIST PAIRLIST ORDERLIST KEYLIST EXPLIST) - (FNS PARSE.MESA PARSE.CEDAR PARSE.FILE PARSE.GET.STATE PARSE.SET.STATE PARSE.BIN - PARSE.VARID PARSE.SMURF PARSE.THISIS.MESA PARSE.THISIS.CEDAR PARSE.MODULE - PARSE.INCLUDEITEM PARSE.INCLUDECHECK PARSE.SEADIRT PARSE.PROGHEAD PARSE.RESIDENT - PARSE.SAFE PARSE.DEFHEAD PARSE.TILDE PARSE.DEFINITIONS PARSE.DEFBODY PARSE.LOCKS - PARSE.LAMBDA PARSE.MODULEITEM PARSE.DECLARATION PARSE.PUBLIC PARSE.ENTRY - PARSE.IDLIST PARSE.IDENTLIST PARSE.POSITION PARSE.OPTBITS PARSE.INTERVAL - PARSE.TYPEEXP.HERE PARSE.TYPEEXP PARSE.RANGE PARSE.TYPEAPPL PARSE.TYPEAPPL.CONT - PARSE.TYPEID PARSE.TYPEID.CONT PARSE.TYPECONS PARSE.TYPECONS1 PARSE.TYPECONS.CONT - PARSE.TYPECONS.RANGE PARSE.TYPECONS.RELATIVE PARSE.TYPECONS.PAINTED - PARSE.TYPECONS2 PARSE.TYPECONS.INTERVAL PARSE.TYPECONS.DEPENDENT - PARSE.TYPECONS.ENUMERATED PARSE.TYPECONS.RECORD PARSE.TYPECONS.ORDERED - PARSE.TYPECONS.VAR PARSE.TYPECONS.PACKED PARSE.TYPECONS.DESCRIPTOR - PARSE.TYPECONS.SAFE PARSE.TYPECONS.HEAP PARSE.TYPECONS.LONG PARSE.TYPECONS.FRAME - PARSE.TYPECONS.REF PARSE.TYPECONS.LIST PARSE.IDENT PARSE.ELEMENT PARSE.MONITORED - PARSE.DEPENDENT PARSE.RECLIST PARSE.VARIANTPAIR PARSE.PAIRITEM PARSE.DEFAULTOPT - PARSE.VARIANTPART PARSE.VCASEHEAD PARSE.TAGTYPE PARSE.VARIANTITEM PARSE.TYPELIST - PARSE.TYPEITEM PARSE.POINTERTYPE PARSE.TRANSFERMODE PARSE.INITIALIZATION - PARSE.INITVALUE PARSE.CHECKED PARSE.CODELIST PARSE.STATEMENT PARSE.STATEMENT1 - PARSE.STATEMENT2 PARSE.STATEMENT.CASEHEAD PARSE.STATEMENT.FORCLAUSE - PARSE.STATEMENT.RETURN PARSE.STATEMENT.TRANSFER PARSE.STATEMENT.LBRACKET - PARSE.STATEMENT.IF PARSE.BLOCK PARSE.SCOPE PARSE.BINDITEM PARSE.EXITS - PARSE.CASESTMTITEM PARSE.CASEEXPITEM PARSE.EXITITEM PARSE.CASETEST PARSE.CONTROLID - PARSE.FORCLAUSE PARSE.DIRECTION PARSE.DOTEST PARSE.DOEXIT PARSE.ENABLES - PARSE.CATCHLIST PARSE.CATCHCASE PARSE.OPTARGS PARSE.TRANSFER PARSE.KEYITEM - PARSE.OPTEXP PARSE.EXP PARSE.EXP1 PARSE.EXP2 PARSE.EXP.TRANSFEROP PARSE.EXP.IF - PARSE.EXP.CASEHEAD PARSE.EXP.LHS PARSE.EXP.LBRACKET PARSE.EXP.ERROR - PARSE.EXP.DISJUNCT PARSE.DISJUNCT PARSE.CONJUNCT PARSE.NEGATION PARSE.RELATION - PARSE.SUM PARSE.PRODUCT PARSE.OPTRELATION PARSE.RELATIONTAIL PARSE.RELOP - PARSE.ADDOP PARSE.MULTOP PARSE.FACTOR PARSE.PRIMARY PARSE.ATOM PARSE.PRIMARY.NIL - PARSE.PRIMARY.LBRACKET PARSE.PRIMARY.PREFIXOP PARSE.PRIMARY.VAL PARSE.PRIMARY.ALL - PARSE.PRIMARY.NEW PARSE.PRIMARY.TYPEOP PARSE.PRIMARY.SIZE PARSE.PRIMARY.ISTYPE - PARSE.PRIMARY.AT PARSE.PRIMARY.DESCRIPTOR PARSE.PRIMARY.CONS PARSE.PRIMARY.LIST - PARSE.PRIMARY.LHS PARSE.PRIMARY.LHS.NEW PARSE.PRIMARY.LHS.CONS - PARSE.PRIMARY.LHS.LIST PARSE.QUALIFIER PARSE.LHS PARSE.QUALIFIER.HERE - PARSE.OPTCATCH PARSE.TRANSFEROP PARSE.PREFIXOP PARSE.TYPEOP PARSE.DESCLIST - PARSE.DIRECTORY PARSE.IMPORTS PARSE.POINTERPREFIX PARSE.EXPORTS PARSE.FIELDLIST - PARSE.USING PARSE.CATCHHEAD PARSE.DECLIST PARSE.PAIRLIST PARSE.VARIANTLIST - PARSE.ORDERLIST PARSE.LHSLIST PARSE.INCLUDELIST PARSE.MODULELIST PARSE.ELEMENTLIST - PARSE.BINDLIST PARSE.STATEMENTLIST PARSE.CASESTMTLIST PARSE.CASELABEL - PARSE.EXITLIST PARSE.KEYLIST PARSE.CASEEXPLIST PARSE.EXPLIST PARSE.OPEN - PARSE.CLASS PARSE.CASEHEAD PARSE.READONLY PARSE.ORDERED PARSE.BASE PARSE.PACKED - PARSE.HEAP PARSE.INLINE PARSE.ARGUMENTS PARSE.INTERFACE PARSE.SHARES PARSE.DEFAULT - PARSE.OPTSIZE PARSE.BOUNDS PARSE.LENGTH PARSE.INDEXTYPE PARSE.ELSEPART - PARSE.OTHERPART PARSE.FREE PARSE.CATCHANY PARSE.NOT PARSE.NEW PARSE.OPTTYPE - PARSE.ARGLIST PARSE.RETURNLIST)) - (COMS - - (* ;; "BUILD ") - - [INITVARS (BUILD.NEXT.SCOPE NIL) - (BUILD.CURRENT.SCOPE NIL) - (BUILD.SCOPE.STACK NIL) - (BUILD.PREFIX NIL) - (BUILD.FILECOMS NIL) - (BUILD.BOOLEAN.FNS '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP - MINUSP EVENP ODDP FGREATERP FLESSP FEQP GREATERP LESSP - GEQ LEQ)) - (BUILD.CARDINAL.FNS '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD - IPLUS IQUOTIENT IREMAINDER ITIMES LOGAND LOGNOT LOGOR - LOGXOR NTHCHARCODE SUB1)) - (BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER - TIMES)) - (BUILD.REAL.FNS '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT - FMAX FMIN FMINUS FMOD FPLUS FQUOTIENT FREMAINDER FTIMES - LOG SIN SQRT TAN)) - (BUILD.QUALIFY.WORDS '(FREE NEW SIZE)) - [BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP) - (CONS '%# 'IEQP) - (CONS '< 'ILESSP) - (CONS '<= 'ILEQ) - (CONS '> 'IGREATERP) - (CONS '>= 'IGEQ) - (CONS '+ 'IPLUS) - (CONS '- 'IDIFFERENCE) - (CONS '* 'ITIMES) - (CONS '/ 'IQUOTIENT) - (CONS '0- 'IMINUS) - (CONS 'MAX 'IMAX) - (CONS 'MIN 'IMIN) - (CONS 'MOD 'IMOD] - [BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP) - (CONS '%# 'EQP) - (CONS '< 'LESSP) - (CONS '<= 'GREATERP) - (CONS '> 'GREATERP) - (CONS '>= 'LESSP) - (CONS '+ 'PLUS) - (CONS '- 'DIFFERENCE) - (CONS '* 'TIMES) - (CONS '/ 'QUOTIENT) - (CONS '0- 'MINUS) - (CONS 'MAX 'MAX) - (CONS 'MIN 'MIN) - (CONS 'MOD 'IMOD] - [BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP) - (CONS '%# 'FEQP) - (CONS '< 'FLESSP) - (CONS '<= 'FGREATERP) - (CONS '> 'FGREATERP) - (CONS '>= 'FLESSP) - (CONS '+ 'FPLUS) - (CONS '- 'FDIFFERENCE) - (CONS '* 'FTIMES) - (CONS '/ 'FQUOTIENT) - (CONS '0- 'FMINUS) - (CONS 'MAX 'FMAX) - (CONS 'MIN 'FMIN) - (CONS 'MOD 'IMOD] - (BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD] - (RECORDS SCOPE) - (FNS BUILD.INIT BUILD.PUSH.SCOPE BUILD.POP.SCOPE BUILD.GC.SCOPE BUILD.STORE.EXPORTS - BUILD.STORE.IDENTLIST BUILD.STORE.INTERFACES BUILD.STORE.INTERFACE - BUILD.STORE.OPEN BUILD.STORE.USING BUILD.INITIALIZATION BUILD.INITIALIZE.VARS - BUILD.INITIALIZE.VAR BUILD.INITIALIZE.FN BUILD.INITIALIZE.RECORD BUILD.RECORD - BUILD.TYPE BUILD.STORE.ARGLIST BUILD.STORE.RETURNLIST BUILD.STORE.PAIRLIST - BUILD.STORE.PAIRITEM BUILD.STORE.VARLIST BUILD.ID BUILD.FIELDID BUILD.PROCID - BUILD.RECORDID BUILD.TYPEID BUILD.VARID BUILD.LOCALVARID BUILD.GLOBALVARID - BUILD.ULTIMATE.TYPE BUILD.REFINE.TYPE BUILD.IMMEDIATE.TYPE BUILD.LOOKUP.TYPE - BUILD.LOOKUP BUILD.TYPEATOM BUILD.QUALIFY BUILD.QUALIFY.PREFIXOP - BUILD.QUALIFY.TYPEOP BUILD.QUALIFY.EXPLIST BUILD.QUALIFY.ID BUILD.ARITH.EXP1 - BUILD.ARITH.EXP2 BUILD.ARITH.EXP* BUILD.ARITH.ADD1SUB1 BUILD.COERCE.ARITHOP - BUILD.STRONGEST.TYPE.AMONG BUILD.STRONGEST.TYPE BUILD.COERCE BUILD.COERCE.MARRAY - BUILD.COERCE.MLIST BUILD.COERCE.EXPLIST BUILD.ALIGN BUILD.ALIGN.VALUE - BUILD.ADD.TO.FILECOMS BUILD.ADD1 BUILD.CALL BUILD.CHARCODE BUILD.COND - BUILD.COPY.OF BUILD.FETCH BUILD.FORCLAUSE.BY BUILD.FORCLAUSE.IN - BUILD.FORCLAUSE.THROUGH BUILD.IN BUILD.ISTYPE BUILD.LAMBDA BUILD.NEW BUILD.OR - BUILD.PROG BUILD.PROGN BUILD.REPLACE BUILD.RETURN BUILD.SELECTQ BUILD.SELECTQ.FN - BUILD.SELECTQ.CCLAUSE BUILD.SELECTQ.TEST BUILD.SELECTQ.SCLAUSE BUILD.SELECTQ.KEY - BUILD.SELECTTRUEFROM BUILD.SELECTTRUEFROM.CLAUSE BUILD.SETQ BUILD.SETQ.ARRAY - BUILD.SETQ.ORDERLIST BUILD.SUB1 BUILD.TAIL) - (P (BUILD.INIT]) - - - -(* ;; "MESATOLISP -- By Kelly Roach. Lyricized by L. Masinter") - - - - -(* ;;; "SCAN: reading mesa/cedar files") - - -(RPAQ? SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE 'CL:CHARACTER :ADJUSTABLE T - :FILL-POINTER 0)) - -(RPAQ? SCAN.CHAR NIL) - -(RPAQ? SCAN.QDOT NIL) - -(RPAQ? SCAN.BOTH.RESERVED - '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS ALL AND ANY APPLY ARRAY BASE BEGIN - BROADCAST CODE COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT DESCRIPTOR DIRECTORY DO - ELSE ENABLE END ENDCASE ENDLOOP ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK - FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL ISTYPE JOIN LAST LENGTH LOCKS LONG - LOOP LOOPHOLE MACHINE MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY NULL OF - OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT PRED PRIVATE PROC PROCEDURE PROCESS - PROGRAM PUBLIC READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME RETRY RETURN RETURNS - SELECT SEQUENCE SHARES SIGNAL SIZE START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH - TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE %[ %] ^ _ { %| } ~)) - -(RPAQ? SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED UNCHECKED UNSAFE)) - -(RPAQ? SCAN.MESA.RESERVED '(RESIDENT)) -(DEFINEQ - -(SCAN.INIT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:05") - (PROG NIL - (for ATOM in SCAN.BOTH.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'BOTH)) - (for ATOM in SCAN.CEDAR.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'CEDAR)) - (for ATOM in SCAN.MESA.RESERVED do (PUTPROP ATOM 'SCAN.RESERVED 'MESA]) - -(SCAN.START - [LAMBDA NIL (* ; "Edited 10-Apr-87 11:39 by Masinter") - (CL:SETF (CL:FILL-POINTER SCAN.STRING) - 0]) - -(SCAN.TEST - [LAMBDA (STRING) (* ; "Edited 6-Apr-87 15:05 by Masinter") - - (* How would scanner parse a file containing this STRING? *) - - (PROG (STREAM TOKEN) - (SETQ STREAM (OPENSTRINGSTREAM STRING)) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (SETQ SCAN.QDOT NIL) - (SETQ TOKEN (SCAN.TOKEN STREAM)) - (CLOSEF STREAM) - (RETURN TOKEN]) - -(SCAN.TESTFILE - [LAMBDA (FILE) (* kbr%: "25-Nov-85 12:05") - - (* How would scanner parse a file containing this STRING? *) - - (PROG (STREAM) - (SETQ STREAM (SCAN.OPENSTREAM FILE)) - [do (SETQ TOKEN (SCAN.TOKEN STREAM)) - (PRINT TOKEN T) - (COND - ((EQ (CAR TOKEN) - 'EOF) - (RETURN] - (CLOSEF STREAM]) - -(SCAN.OPENSTREAM - [LAMBDA (FILE) (* ; "Edited 6-Apr-87 15:05 by Masinter") - (* Open FILE, return STREAM. - *) - (PROG (STREAM TOKEN) - (SETQ STREAM (OPENSTREAM FILE 'INPUT)) - (SETFILEPTR STREAM 0) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (SETQ SCAN.QDOT NIL) - (RETURN STREAM]) - -(SCAN.TOKEN - [LAMBDA (STREAM) (* ; "Edited 10-Apr-87 15:59 by Masinter") - - (* ;; "Return (CLASS VALUE) ") - - (PROG (SCAN CLASS VALUE VALID C ADVANCE PCHAR COMMENT DASHCRLF STATE NEST) - (CL:SETF (CL:FILL-POINTER SCAN.STRING) - 0) - [do (while (<= (CL:CHAR-INT SCAN.CHAR) - (CL:CHAR-INT '#\Space)) do (COND - ((EOFP STREAM) - (GO ENDFILE))) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))) - (CASE SCAN.CHAR - ((#\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) - (SCAN.START SCAN.CHAR) - [do (SCAN.ACCEPT STREAM) - (COND - ((NOT (OR (CL:ALPHA-CHAR-P SCAN.CHAR) - (CL:DIGIT-CHAR-P SCAN.CHAR))) - (RETURN] - (SETQ CLASS 'ID) - (SETQ VALUE (MKATOM SCAN.STRING)) - (SETQ VALID T) - (GO GOTNEXT)) - ((#\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) (* TBW stuff concerning HTIndex. - *) - (SCAN.START SCAN.CHAR) - [do (SCAN.ACCEPT STREAM) - (COND - ((NOT (OR (CL:ALPHA-CHAR-P SCAN.CHAR) - (CL:DIGIT-CHAR-P SCAN.CHAR))) - (RETURN] - (SETQ CLASS 'ID) - (SETQ VALUE (MKATOM SCAN.STRING)) - (SETQ VALID T) - (GO GOTNEXT)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (SCAN.START SCAN.CHAR) - (SETQ SCAN (SCAN.NUMBER STREAM NIL)) - (SETQ CLASS (CAR SCAN)) - (SETQ VALUE (CADR SCAN)) - (SETQ VALID (CADDR SCAN)) - (COND - ((NOT VALID) - (SCAN.ERROR))) - (GO GOTNEXT)) - ((#\_ #\¬) - (SETQ CLASS '_) - (SETQ VALUE CLASS) - (GO GETNEXT)) - ((#\^ #\­) - (SETQ CLASS '^) - (SETQ VALUE CLASS) - (GO GETNEXT)) - ((#\, #\; #\: #\# #\+ #\* #\/ #\@ #\! #\( #\) #\[ #\] #\{ #\}) - [SETQ CLASS (MKATOM (CHARACTER (CL:CHAR-INT SCAN.CHAR] - (SETQ VALUE CLASS) - (GO GETNEXT)) - [(#\') - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (SETQ SCAN (SCAN.ESCAPE STREAM)) - (SETQ VALUE (CAR SCAN)) - (SETQ VALID (CADR SCAN)) - (SETQ ADVANCE (CADDR SCAN)) - (COND - ((NOT VALID) - (SCAN.ERROR))) - (SETQ CLASS 'CHAR) - (COND - (ADVANCE (GO GETNEXT)) - (T (GO GOTNEXT] - [(#\") - (CL:SETF (CL:FILL-POINTER SCAN.STRING) - 0) - (SETQ ADVANCE T) - [do [COND - (ADVANCE (SETQ SCAN.CHAR (CL:READ-CHAR STREAM] - [CASE SCAN.CHAR ((#\") - (SETQ SCAN.CHAR (\BIN STREAM)) - (COND - ((NOT (IEQP SCAN.CHAR (CHARCODE %"))) - (RETURN] - (SETQ SCAN (SCAN.ESCAPE STREAM)) - (CL:VECTOR-PUSH-EXTEND (CL:INT-CHAR (CAR SCAN)) - SCAN.STRING) - (SETQ VALID (CADR SCAN)) - (SETQ ADVANCE (CADDR SCAN)) - (COND - ((NOT VALID) - (SCAN.ERROR] - (SETQ VALUE (CL:COPY-SEQ SCAN.STRING)) - (COND - ((OR (EQL SCAN.CHAR '#\l) - (EQL SCAN.CHAR '#\L)) - (SETQ CLASS 'STRING) - (GO GETNEXT)) - (T (SETQ CLASS 'STRING) - (COND - ((EQL (CL:CHAR-UPCASE SCAN.CHAR) - '#\G) - (GO GETNEXT)) - (T (GO GOTNEXT] - ((#\-) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (COND - ((NOT (EQL SCAN.CHAR '#\-)) - (SETQ CLASS '-) - (SETQ VALUE '-) - (GO GOTNEXT))) - (SETQ SCAN.CHAR '#\Null) - (do (SETQ PCHAR SCAN.CHAR) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (CASE SCAN.CHAR [#\- (COND - ((EQL PCHAR '#\-) - (SETQ COMMENT 'DASH) - (RETURN] - (#\Newline (SETQ COMMENT 'CRLF) - (RETURN)) - NIL)) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (COND - ((AND (EQ COMMENT 'DASH) - (EQL SCAN.CHAR '#\Newline)) - (SETQ DASHCRLF T))) (* TBW stuff about formatting *) - ) - [(#\.) - (COND - (SCAN.QDOT (SETQ SCAN.QDOT NIL) - (SETQ CLASS '|..|) - (SETQ VALUE '|..|) - (GO GETNEXT))) - (COND - ((EOFP STREAM) - (SETQ CLASS '%.) - (SETQ VALUE '%.) - (GO GOTNEXT))) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (CASE SCAN.CHAR (#\. (SETQ CLASS '|..|) - (SETQ VALUE '|..|) - (GO GETNEXT)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (SCAN.START '#\.) - (SETQ SCAN (SCAN.NUMBER STREAM T)) - (SETQ CLASS (CAR SCAN)) - (SETQ VALUE (CADR SCAN)) - (SETQ VALID (CADDR SCAN)) - (COND - ((NOT VALID) - (SCAN.ERROR))) - (GO GOTNEXT)) - (T (SETQ CLASS '%.) - (SETQ VALUE '%.) - (GO GOTNEXT] - [(#\=) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (COND - ((EQL SCAN.CHAR '#\>) - (SETQ CLASS '=>) - (SETQ VALUE '=>) - (GO GETNEXT)) - (T (SETQ CLASS '=) - (SETQ VALUE '=) - (GO GOTNEXT] - [(#\<) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (CASE SCAN.CHAR (#\= (SETQ CLASS '<=) - (SETQ VALUE '<=) - (GO GETNEXT)) - (#\< (SETQ STATE 'PLAIN) - (SETQ NEST 1) - [do (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (CASE SCAN.CHAR (#\> (SELECTQ STATE - ((PLAIN LEFTBROCKET) - (SETQ STATE 'RIGHTBROCKET)) - (RIGHTBROCKET (SETQ STATE 'PLAIN) - (SETQ NEST (SUB1 NEST)) - (COND - ((ZEROP NEST) - (RETURN)))) - NIL)) - (#\< (SELECTQ STATE - ((PLAIN RIGHTBROCKET) - (SETQ STATE 'LEFTBROCKET)) - (RIGHTBROCKET (SETQ STATE 'PLAIN) - (SETQ NEST (ADD1 NEST)) - (COND - ((ZEROP NEST) - (RETURN)))) - NIL)) - (T (SETQ STATE 'PLAIN] - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (* TBW formatting stuff *) - ) - (T (SETQ CLASS '<) - (SETQ VALUE '<) - (GO GOTNEXT] - [(#\>) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (COND - ((EQL SCAN.CHAR '#\=) - (SETQ CLASS '>=) - (SETQ VALUE '>=) - (GO GETNEXT)) - (T (SETQ CLASS '>) - (SETQ VALUE '>) - (GO GOTNEXT] - (T [SETQ CLASS (MKATOM (CHARACTER (CL:CHAR-INT SCAN.CHAR] - (SETQ VALUE CLASS) - (GO GETNEXT] - GETNEXT - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - GOTNEXT - [COND - ((EQ CLASS 'ID) - [COND - ((EQ VALUE NIL) - - (* Hack NIL to NILL because I can't put properties on NIL. - *) - - (SETQ VALUE 'NILL] - (COND - ((GETPROP VALUE 'SCAN.RESERVED) - (SETQ CLASS VALUE] - (RETURN (LIST CLASS VALUE)) - ENDFILE - (SETQ CLASS 'EOF) - (SETQ VALUE 'EOF) - (RETURN (LIST CLASS VALUE]) - -(SCAN.NUMBER - [LAMBDA (STREAM FLOAT) (* ; "Edited 6-Apr-87 15:58 by Masinter") - (* Return (CLASS VALUE VALID) *) - (PROG (CLASS VALUE VALID HEXCOUNT HEXSIG V START SCAN) - (SETQ HEXCOUNT 0) - (SETQ HEXSIG 0) - (SETQ CLASS 'LNUM) - [do (CASE SCAN.CHAR ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (SCAN.ACCEPT STREAM)) - [(#\e #\E) - [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE e) - (CHARCODE a] - (SETQ HEXCOUNT (ADD1 HEXCOUNT)) - (SCAN.ACCEPT STREAM) - (COND - ([AND (IEQP HEXCOUNT 1) - (OR (EQL SCAN.CHAR '#\+) - (EQL SCAN.CHAR '#\-] - (SETQ FLOAT T) - (SCAN.ACCEPT STREAM] - ((#\a #\b #\c #\d #\e #\f) - [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CL:CHAR-INT SCAN.CHAR) - (CHARCODE a] - (SETQ HEXCOUNT (ADD1 HEXCOUNT)) - (SCAN.ACCEPT STREAM)) - ((#\A #\B #\C #\D #\E #\F) - [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE SCAN.CHAR (CHARCODE A] - (SETQ HEXCOUNT (ADD1 HEXCOUNT)) - (SCAN.ACCEPT STREAM)) - ((#\h #\H) - [SETQ HEXSIG (LOGOR HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE h) - (CHARCODE a] - (SETQ HEXCOUNT (ADD1 HEXCOUNT)) - (SCAN.ACCEPT STREAM)) - ((#\.) - (COND - ((OR (NOT (IEQP HEXCOUNT 0)) - FLOAT) - (RETURN))) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (COND - ((EQL SCAN.CHAR '#\.) - (SETQ SCAN.QDOT T) - (RETURN))) - (SETQ FLOAT T) - (CL:VECTOR-PUSH-EXTEND '#\. SCAN.STRING)) - (T (RETURN] - (CL:VECTOR-PUSH-EXTEND '#\Null SCAN.STRING) - [COND - (FLOAT (SETQ CLASS 'FLNUM) - (SETQ SCAN (SCAN.FLOATING SCAN.STRING)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN))) - ([NOT (ZEROP (LOGAND HEXSIG (LLSH 1 (IDIFFERENCE (CHARCODE h) - (CHARCODE a] - (SETQ SCAN (SCAN.HEX SCAN.STRING)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN))) - ((IEQP HEXCOUNT 0) - (SETQ SCAN (SCAN.DECIMAL SCAN.STRING)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN))) - ((IEQP HEXCOUNT 1) - (SELECTC HEXSIG - ((LLSH 1 (IDIFFERENCE (CHARCODE b) - (CHARCODE a))) - (SETQ SCAN (SCAN.OCTAL SCAN.STRING))) - ((LLSH 1 (IDIFFERENCE (CHARCODE c) - (CHARCODE a))) - (SETQ CLASS 'CHAR) - (SETQ SCAN (SCAN.OCTALCHAR SCAN.STRING))) - ((LLSH 1 (IDIFFERENCE (CHARCODE d) - (CHARCODE a))) - (SETQ SCAN (SCAN.DECIMAL SCAN.STRING))) - ((LLSH 1 (IDIFFERENCE (CHARCODE e) - (CHARCODE a))) - (SETQ CLASS 'FLNUM) - (SETQ SCAN (SCAN.FLOATING SCAN.STRING))) - (SETQ SCAN (SCAN.HEX SCAN.STRING))) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN))) - (T (SETQ SCAN (SCAN.HEX SCAN.STRING)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] (* TBW stuff *) - (RETURN (LIST CLASS V VALID]) - -(SCAN.ACCEPT - [LAMBDA (STREAM) (* ; "Edited 6-Apr-87 15:25 by Masinter") - (CL:VECTOR-PUSH-EXTEND SCAN.CHAR SCAN.STRING) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM]) - -(SCAN.APPENDDECIMAL - [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") - (* DIGIT is a character code. - Return (NEWV VALID) *) - (PROG (MAXV MAXD D VALID NEWV) - (SETQ MAXV 429496729) - (SETQ MAXD 5) - (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))) - [SETQ VALID (OR (ILESSP V MAXV) - (AND (IEQP V MAXV) - (ILEQ D MAXD] - (SETQ NEWV (IPLUS (ITIMES 10 V) - D)) - (RETURN (LIST NEWV VALID]) - -(SCAN.APPENDOCTAL - [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") - (* DIGIT is a character code. - Return (NEWV VALID) *) - (PROG (MAXV D VALID NEWV) - (SETQ MAXV 536870911) - (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))) - (SETQ VALID (ILEQ V MAXV)) - (SETQ NEWV (IPLUS (ITIMES 8 V) - D)) - (RETURN (LIST NEWV VALID]) - -(SCAN.APPENDHEX - [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") - (* DIGIT is a character code. - Return (NEWV VALID) *) - (PROG (MAXV D VALID NEWV) - (SETQ MAXV 268435455) - [COND - [(AND (IGEQ DIGIT (CHARCODE 0)) - (ILEQ DIGIT (CHARCODE 9))) - (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0] - (T (SETQ D (IPLUS DIGIT (IMINUS (CHARCODE A)) - 10] - (SETQ VALID (ILEQ V MAXV)) - (SETQ NEWV (IPLUS (ITIMES 16 V) - D)) - (RETURN (LIST NEWV VALID]) - -(SCAN.APPENDTOSCALE - [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") - (* DIGIT is a character code. - Return (NEWV VALID) *) - (PROG (MAXV MAXD D VALID NEWV) - (SETQ MAXV 6553) - (SETQ MAXD 5) - (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))) - [SETQ VALID (OR (ILESSP V MAXV) - (AND (IEQP V MAXV) - (ILEQ D MAXD] - (SETQ NEWV (IPLUS (ITIMES 10 V) - D)) - (RETURN (LIST NEWV VALID]) - -(SCAN.VALIDFRACTION - [LAMBDA (V DIGIT) (* kbr%: "25-Nov-85 12:06") - (* DIGIT is a character code. - Return VALID. *) - (PROG (MAXV MAXD D VALID) - (SETQ MAXV 214748364) - (SETQ MAXD 7) - (SETQ D (IDIFFERENCE DIGIT (CHARCODE 0))) - [SETQ VALID (OR (ILESSP V MAXV) - (AND (IEQP V MAXV) - (ILEQ D MAXD] - (RETURN VALID]) - -(SCAN.DECIMAL - [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:48 by Masinter") - (* Return (VALUE VALID) *) - (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE) - (SETQ VALID T) - (SETQ BUFFERPTR 0) - (SETQ V 0) - (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (CHARCODE 0)) - (ILEQ C (CHARCODE 9))) do [COND - (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - [COND - ((OR (IEQP C (CHARCODE d)) - (IEQP C (CHARCODE D))) - (SETQ SCALE 0) - (SETQ BUFFERPTR (ADD1 BUFFERPTR)) - (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (CHARCODE 0)) - (ILEQ C (CHARCODE 9))) do [COND - (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C) - ) - (SETQ SCALE (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDDECIMAL V (CHARCODE 0))) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (COND - ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] - (SETQ VALID NIL))) - (SETQ VALUE V) - (RETURN (LIST VALUE VALID]) - -(SCAN.OCTAL - [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:55 by Masinter") - (* Return (VALUE VALID) *) - (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE) - (SETQ BUFFERPTR 0) - (SETQ VALID T) - (SETQ V 0) - (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (CHARCODE 0)) - (ILEQ C (CHARCODE 7))) do [COND - (VALID (SETQ SCAN (SCAN.APPENDOCTAL V C)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - [COND - ((OR (IEQP C (CHARCODE b)) - (IEQP C (CHARCODE B))) - (SETQ SCALE 0) - (SETQ BUFFERPTR (ADD1 BUFFERPTR)) - (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (CHARCODE 0)) - (ILEQ C (CHARCODE 7))) do [COND - (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C) - ) - (SETQ SCALE (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDOCTAL V (CHARCODE 0))) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (COND - ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] - (SETQ VALID NIL))) - (SETQ VALUE V) - (RETURN (LIST VALUE VALID]) - -(SCAN.OCTALCHAR - [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:57 by Masinter") - (* Return (VALUE VALID) *) - (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE) - (SETQ BUFFERPTR 0) - (SETQ VALID T) - (SETQ V 0) - (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (CHARCODE 0)) - (ILEQ C (CHARCODE 7))) do [COND - (VALID (SETQ SCAN (SCAN.APPENDOCTAL V C)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - [COND - ((OR (IEQP C (CHARCODE c)) - (IEQP C (CHARCODE C))) - (SETQ BUFFERPTR (ADD1 BUFFERPTR] - (COND - ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] - (SETQ VALID NIL))) - (COND - ((NOT (OR (IGEQ V 0) - (ILEQ V 255))) - (SETQ VALID NIL))) - (SETQ VALUE V) - (RETURN (LIST VALUE VALID]) - -(SCAN.HEX - [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:45 by Masinter") - (* Return (VALUE VALID) *) - (PROG (VALUE VALID BUFFERPTR C V SCAN SCALE) - (SETQ BUFFERPTR 0) - (SETQ VALID T) - (SETQ V 0) - (while [NOT (ZEROP (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] - do (COND - [[OR (AND (IGEQ C (CHARCODE 0)) - (ILEQ C (CHARCODE 9))) - (AND (IGEQ C (CHARCODE A)) - (ILEQ C (CHARCODE F] - (COND - (VALID (SETQ SCAN (SCAN.APPENDHEX V C)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] - [(AND (IGEQ C (CHARCODE a)) - (ILEQ C (CHARCODE f))) - (COND - (VALID [SETQ SCAN (SCAN.APPENDHEX V (IDIFFERENCE C (IDIFFERENCE (CHARCODE - a) - (CHARCODE A] - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (T (RETURN))) - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - [COND - ((OR (IEQP C (CHARCODE h)) - (IEQP C (CHARCODE H))) - (SETQ SCALE 0) - (SETQ BUFFERPTR (ADD1 BUFFERPTR)) - (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (CHARCODE 0)) - (ILEQ C (CHARCODE 9))) do [COND - (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C) - ) - (SETQ SCALE (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - (for I from 1 to SCALE do (SETQ SCAN (SCAN.APPENDHEX V (CHARCODE 0))) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (COND - ([NOT (ZEROP (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] - (SETQ VALID NIL))) - (SETQ VALUE V) - (RETURN (LIST VALUE VALID]) - -(SCAN.FLOATING - [LAMBDA (BUFFER) (* ; "Edited 6-Apr-87 15:46 by Masinter") - (* Return (VALUE VALID) *) - (PROG (VALUE VALID BUFFERPTR C V EXP SCAN SCALE OP) - (SETQ BUFFERPTR 0) - (SETQ VALID T) - (SETQ V 0) - (SETQ EXP 0) - (while (AND [<= (CHARCODE 0) - (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR] - (< C (CHARCODE 9))) do (SETQ VALID (AND VALID (SCAN.VALIDFRACTION V C))) - [COND - (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C)) - (SETQ V (CAR SCAN))) - (T (SETQ EXP (ADD1 EXP] - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - [COND - ((= C (CHARCODE %.)) - (SETQ BUFFERPTR (ADD1 BUFFERPTR)) - (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (COND - ([NOT (AND (IGEQ C (CHARCODE 0)) - (ILEQ C (CHARCODE 9] - (SETQ VALID NIL))) - (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (CHARCODE 0)) - (ILEQ C (CHARCODE 9))) do (SETQ VALID (AND VALID (SCAN.VALIDFRACTION V C))) - [COND - (VALID (SETQ SCAN (SCAN.APPENDDECIMAL V C)) - (SETQ V (CAR SCAN)) - (SETQ VALID (CADR SCAN)) - (SETQ EXP (SUB1 EXP] - (SETQ BUFFERPTR (ADD1 BUFFERPTR] - (SETQ VALID T) - [COND - ((OR (IEQP C (CHARCODE e)) - (IEQP C (CHARCODE E))) - (SETQ SCALE 0) - (SETQ OP 'PLUS) - (SETQ BUFFERPTR (ADD1 BUFFERPTR)) - (SELCHARQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)) - ("+" (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - ("-" (SETQ OP 'MINUS) - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - NIL) - (COND - ([NOT (AND (IGEQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)) - (CHARCODE 0)) - (ILEQ (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR)) - (CHARCODE 9] - (SETQ VALID NIL))) - (while (AND (IGEQ (SETQ C (CL:CHAR-INT (CL:ELT BUFFER BUFFERPTR))) - (CHARCODE 0)) - (ILEQ C (CHARCODE 9))) do [COND - (VALID (SETQ SCAN (SCAN.APPENDTOSCALE SCALE C) - ) - (SETQ SCALE (CAR SCAN)) - (SETQ VALID (CADR SCAN] - (SETQ BUFFERPTR (ADD1 BUFFERPTR))) - (SETQ EXP (COND - ((EQ OP 'PLUS) - (IPLUS EXP SCALE)) - (T (IDIFFERENCE EXP SCALE] - (COND - ((NOT (ZEROP (CL:ELT BUFFER BUFFERPTR))) - (SETQ VALID NIL))) - - (* TBW NOTE%: Look at MKNUMATOM & \FLOATINGSCALE to find right way to do this. - *) - - (SETQ VALUE (FTIMES V (EXPT 10.0 EXP))) - (RETURN (LIST VALUE VALID]) - -(SCAN.ESCAPE - [LAMBDA (STREAM) (* ; "Edited 6-Apr-87 15:28 by Masinter") - (PROG (C VALID ADVANCE V NC) - (SETQ VALID T) - (SETQ ADVANCE T) - (SETQ C SCAN.CHAR) - [COND - ((EQL C '#\\) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM)) - (SETQ C (CASE SCAN.CHAR ((#\n #\N #\r #\R) - (CHARCODE CR)) - ((#\l #\L) - (CHARCODE LF)) - ((#\t #\T) - (CHARCODE TAB)) - ((#\b #\B) - (CHARCODE BS)) - ((#\f #\F) - (CHARCODE FF)) - ((#\' #\" #\\) - (CL:CHAR-INT SCAN.CHAR)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) - (SETQ V 0) - (SETQ NC 0) - (do (COND - ([NOT (AND (IGEQ (CL:CHAR-INT SCAN.CHAR) - (CHARCODE 0)) - (ILEQ (CL:CHAR-INT SCAN.CHAR) - (CHARCODE 7] - (SETQ VALID NIL) - (SETQ ADVANCE NIL) - (RETURN))) - [SETQ V (IPLUS (ITIMES 8 V) - (IDIFFERENCE (CL:CHAR-INT SCAN.CHAR) - (CHARCODE 0] - (COND - ((IEQP (SETQ NC (ADD1 NC)) - 3) - (RETURN))) - (SETQ SCAN.CHAR (CL:READ-CHAR STREAM))) - (COND - ((IGREATERP V 255) - (SETQ VALID NIL) - (SETQ V 0))) - (SETQ C V)) - (T (SETQ VALID NIL) - (SETQ ADVANCE NIL] - (RETURN (LIST C VALID ADVANCE]) -) -(SCAN.INIT) - - - -(* ; "PARSE *") - - -(RPAQ? PARSE.FILELST NIL) - -(RPAQ? PARSE.STREAM NIL) - -(RPAQ? PARSE.FILECOMS NIL) - -(RPAQ? PARSE.LANGUAGE NIL) - -(RPAQ? PARSE.DIRLST NIL) - -(RPAQ? PARSE.CLASS NIL) - -(RPAQ? PARSE.ATOM NIL) - -(RPAQ? PARSE.CLASS2 NIL) - -(RPAQ? PARSE.ATOM2 NIL) - -(RPAQ? PARSE.CASEHEAD.FIRST '(WITH SELECT)) - -(RPAQ? PARSE.DEFHEAD.FIRST '(DEFINITIONS)) - -(RPAQ? PARSE.DEPENDENT.FIRST '(MACHINE)) - -(RPAQ? PARSE.DOTEST.FIRST '(UNTIL WHILE)) - -(RPAQ? PARSE.FORCLAUSE.FIRST '(FOR THROUGH)) - -(RPAQ? PARSE.HEAP.FIRST '(UNCOUNTED)) - -(RPAQ? PARSE.INTERVAL.FIRST '(%( %[)) - -(RPAQ? PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~)) - -(RPAQ? PARSE.ORDERED.FIRST '(ORDERED)) - -(RPAQ? PARSE.ORDERLIST.FOLLOW '(! ; END %] })) - -(RPAQ? PARSE.PACKED.FIRST '(PACKED)) - -(RPAQ? PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC)) - -(RPAQ? PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT)) - -(RPAQ? PARSE.QUALIFIER.FIRST '(%. %[ ^)) - -(RPAQ? PARSE.RANGE.FOLLOW - '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS FINISHED FROM NULL OR REPEAT - SELECT THEN TRASH UNTIL WHILE %] })) - -(RPAQ? PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START TRANSFER)) - -(RPAQ? PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL)) - -(RPAQ? PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START)) - -(RPAQ? PARSE.TYPECONS.FIRST - '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE MONITORED ORDERED PACKED POINTER PORT PROC - PORCEDURE PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {)) - -(RPAQ? PARSE.TYPEOP.FIRST '(FIRST LAST NILL)) - -(RPAQ? PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE)) - -(RPAQ? PARSE.CATCHLIST.FOLLOW '(END %] })) - -(RPAQ? PARSE.CONTROLID.FOLLOW '(DECREASING IN _)) - -(RPAQ? PARSE.DECLIST.FOLLOW '(; END })) - -(RPAQ? PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] })) - -(RPAQ? PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED })) - -(RPAQ? PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES)) - -(RPAQ? PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] })) - -(RPAQ? PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] })) - -(RPAQ? PARSE.SCOPE.FOLLOW '(END EXITS })) - -(RPAQ? PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT })) - -(RPAQ? PARSE.TYPEEXP.FOLLOW - '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF SHARES %] _ })) - -(RPAQ? PARSE.PREDEFINED.TYPES - '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION INT INTEGER MDSZone MONITORLOCK NAT REAL - STRING StringBody UNSPECIFIED WORD)) - -(RPAQ? PARSE.RELOPS (LIST '= '%# '< '<= '> '>=)) - -(RPAQ? PARSE.ADDOPS (LIST '+ '-)) - -(RPAQ? PARSE.MULTOPS (LIST '* '/ 'MOD)) - -(RPAQ? PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK)) - -(RPAQ? PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH)) - -(RPAQ? PARSE.TYPEOPS '(FIRST LAST NILL)) - -(RPAQ? PARSE.NOTS '(~ NOT)) -(DECLARE%: EVAL@COMPILE - -(TYPERECORD PARSERSTATE (STREAM FILEPTR CHAR QDOT CLASS ATOM CLASS2 ATOM2 PREFIX NEXTSCOPE - CURRENTSCOPE SCOPESTACK FILECOMS)) - -(TYPERECORD MINTERVAL (KIND . BOUNDS) - [ACCESSFNS ((LBOUND (CAR (fetch (MINTERVAL BOUNDS) of DATUM))) - (UBOUND (CADR (fetch (MINTERVAL BOUNDS) of DATUM]) - -(TYPERECORD MRANGE (TYPE INTERVAL)) - -(TYPERECORD MRELATIVE (TYPEID TYPE)) - -(TYPERECORD MPAINTED (TYPEID TYPE)) - -(TYPERECORD MENUMERATED ITEMS) - -(TYPERECORD MRECORD (RECORDID . FIELDLIST)) - -(TYPERECORD MVAR TYPE) - -(TYPERECORD MARRAY (INDEXTYPE TYPE)) - -(TYPERECORD MDESCRIPTOR TYPE) - -(TYPERECORD MFRAME ID) - -(TYPERECORD MREF TYPE) - -(TYPERECORD MLIST TYPE) - -(RECORD PAIRITEM (ID TYPEEXP DEFAULT)) - -(RECORD DEFAULT (EXP TRASH)) - -(TYPERECORD TYPELIST ITEMS) - -(RECORD TYPEITEM (TYPEEXP DEFAULT)) - -(TYPERECORD MPOINTER TYPE) - -(TYPERECORD CASEHEAD (ID EXP OPTEXP)) - -(TYPERECORD BINDITEM (ID EXP)) - -(RECORD KEYITEM (ID OPTEXP)) - -(RECORD FIELDLIST (TYPE . ITEMS) - [TYPE? (AND (LISTP DATUM) - (FMEMB (CAR DATUM) - '(PAIRLIST TYPELIST]) - -(TYPERECORD PAIRLIST ITEMS) - -(TYPERECORD ORDERLIST ITEMS) - -(TYPERECORD KEYLIST ITEMS) - -(RECORD EXPLIST (TYPE . ITEMS) - [TYPE? (AND (LISTP DATUM) - (FMEMB (CAR DATUM) - '(KEYLIST ORDERLIST]) -) -(DEFINEQ - -(PARSE.MESA - [LAMBDA (FILE DIRLST) (* kbr%: "25-Nov-85 12:46") - (PARSE.FILE FILE 'MESA DIRLST]) - -(PARSE.CEDAR - (CL:LAMBDA (&OPTIONAL FILE DIRLST) (* ; "Edited 10-Apr-87 16:00 by Masinter") - (PARSE.FILE FILE 'CEDAR DIRLST))) - -(PARSE.FILE - (CL:LAMBDA (&OPTIONAL FILE LANGUAGE DIRLST) (* ; "Edited 10-Apr-87 16:01 by Masinter") - (PROG NIL - (SETQ PARSE.DIRLST DIRLST) - (SETQ PARSE.LANGUAGE LANGUAGE) - (SETQ PARSE.STREAM (SCAN.OPENSTREAM FILE)) - (SETQ PARSE.ATOM NIL) - (SETQ PARSE.ATOM2 NIL) - (PARSE.BIN) - (PARSE.BIN) - (PARSE.MODULE) - (SETQ PARSE.FILECOMS (DREVERSE PARSE.FILECOMS)) - (CLOSEF PARSE.STREAM)))) - -(PARSE.GET.STATE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") - (* Get parser state to save before - interruption. *) - (create PARSERSTATE - STREAM _ PARSE.STREAM - FILEPTR _ (GETFILEPTR PARSE.STREAM) - CHAR _ SCAN.CHAR - QDOT _ SCAN.QDOT - CLASS _ PARSE.CLASS - ATOM _ PARSE.ATOM - CLASS2 _ PARSE.CLASS2 - ATOM2 _ PARSE.ATOM2 - PREFIX _ BUILD.PREFIX - NEXTSCOPE _ BUILD.NEXT.SCOPE - CURRENTSCOPE _ BUILD.CURRENT.SCOPE - SCOPESTACK _ BUILD.SCOPE.STACK - FILECOMS _ BUILD.FILECOMS]) - -(PARSE.SET.STATE - [LAMBDA (STATE) (* kbr%: "25-Nov-85 12:46") - (* Restore state after interruption. - *) - (PROG NIL - (SETQ PARSE.STREAM (fetch (PARSERSTATE STREAM) of STATE)) - (SETFILEPTR PARSE.STREAM (fetch (PARSERSTATE FILEPTR) of STATE)) - (SETQ SCAN.CHAR (fetch (PARSERSTATE CHAR) of STATE)) - (SETQ SCAN.QDOT (fetch (PARSERSTATE QDOT) of STATE)) - (SETQ PARSE.CLASS (fetch (PARSERSTATE CLASS) of STATE)) - (SETQ PARSE.ATOM (fetch (PARSERSTATE ATOM) of STATE)) - (SETQ PARSE.CLASS2 (fetch (PARSERSTATE CLASS2) of STATE)) - (SETQ PARSE.ATOM2 (fetch (PARSERSTATE ATOM2) of STATE)) - (SETQ BUILD.PREFIX (fetch (PARSERSTATE PREFIX) of STATE)) - (SETQ BUILD.NEXT.SCOPE (fetch (PARSERSTATE NEXTSCOPE) of STATE)) - (SETQ BUILD.CURRENT.SCOPE (fetch (PARSERSTATE CURRENTSCOPE) of STATE)) - (SETQ BUILD.SCOPE.STACK (fetch (PARSERSTATE SCOPESTACK) of STATE)) - (SETQ BUILD.FILECOMS (fetch (PARSERSTATE FILECOMS) of STATE]) - -(PARSE.BIN - (CL:LAMBDA (EXPECTCLASS) (* ; "Edited 10-Apr-87 16:00 by Masinter") - (PROG (OLDATOM TOKEN) - (COND - ([AND EXPECTCLASS (OR (AND (LITATOM EXPECTCLASS) - (NOT (EQ EXPECTCLASS PARSE.CLASS))) - (AND (LISTP EXPECTCLASS) - (NOT (FMEMB PARSE.CLASS EXPECTCLASS] - (SHOULDNT "PARSE.BIN"))) - (SETQ OLDATOM PARSE.ATOM) - (SETQ TOKEN (SCAN.TOKEN PARSE.STREAM)) - (SETQ PARSE.CLASS PARSE.CLASS2) - (SETQ PARSE.ATOM PARSE.ATOM2) - (SETQ PARSE.CLASS2 (CAR TOKEN)) - (SETQ PARSE.ATOM2 (CADR TOKEN)) - (RETURN OLDATOM)))) - -(PARSE.VARID - [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") - (BUILD.VARID NIL (PARSE.BIN 'ID]) - -(PARSE.SMURF - [LAMBDA (N) (* kbr%: "25-Nov-85 12:46") - (* Indicate where error occurred while - reading file *) - (COND - ((NULL N) - (SETQ N 100))) - (RESETLST (PROG (POSITION START FINISH) (* Broken file = previous input file *) - (SETQ POSITION (GETFILEPTR PARSE.STREAM)) - (RESETSAVE NIL (LIST 'SETFILEPTR PARSE.STREAM POSITION)) - (SETQ START (IMAX 0 (IDIFFERENCE (SUB1 POSITION) - N))) - (SETQ FINISH (IMIN (GETEOFPTR PARSE.STREAM) - (IPLUS (SUB1 POSITION) - N))) - (COPYBYTES PARSE.STREAM T START (SUB1 POSITION)) - (PRIN1 "[PARSE]" T) - (COPYBYTES PARSE.STREAM T (SUB1 POSITION) - FINISH) - (TERPRI T]) - -(PARSE.THISIS.MESA - [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") - (* Assert this is MESA *) - (COND - ((NOT (EQ PARSE.LANGUAGE 'MESA)) - (SHOULDNT]) - -(PARSE.THISIS.CEDAR - [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") - (* Assert this is CEDAR *) - (COND - ((NOT (EQ PARSE.LANGUAGE 'CEDAR)) - (SHOULDNT]) - -(PARSE.MODULE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") - (PROG (IDENTLIST) (* (module directory identlist cedar - proghead trusted checked block) - (module directory identlist cedar - defhead defbody) *) - (PARSE.DIRECTORY) - (SETQ IDENTLIST (PARSE.IDENTLIST)) - (BUILD.INIT (CAR IDENTLIST)) - (BUILD.STORE.INTERFACES IDENTLIST) - (PARSE.SEADIRT) - (COND - ((NOT (EQ PARSE.ATOM 'DEFINITIONS)) - (PARSE.PROGHEAD) - (PARSE.CHECKED) - (PARSE.BLOCK)) - (T (PARSE.DEFHEAD) - (PARSE.DEFBODY))) - (PUTPROP BUILD.PREFIX 'MESA.PARSED T) - (pushnew PARSE.FILELST BUILD.PREFIX]) - -(PARSE.INCLUDEITEM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") - (PROG (ID USING) (* (includeitem id %: FROM string - using) (includeitem id %: TYPE using) - (includeitem id using) - (includeitem id %: TYPE id using) *) - (SETQ ID (PARSE.BIN 'ID)) - (BUILD.STORE.INTERFACE ID) - (PARSE.INCLUDECHECK ID) - [COND - [(EQ PARSE.ATOM '%:) - (PARSE.BIN) - (COND - ((EQ PARSE.ATOM 'FROM) - (PARSE.BIN) - (PARSE.BIN 'STRING) - (SETQ USING (PARSE.USING))) - (T (PARSE.BIN 'TYPE) - (COND - ((EQ PARSE.ATOM 'ID) - (PARSE.BIN 'ID) - (SETQ USING (PARSE.USING))) - ((EQ PARSE.ATOM 'USING) - (SETQ USING (PARSE.USING] - (T (SETQ USING (PARSE.USING] - (BUILD.STORE.USING ID USING]) - -(PARSE.INCLUDECHECK - [LAMBDA (ID) (* kbr%: "25-Nov-85 12:46") - (PROG (STATE FILE) - (COND - ((GETPROP ID 'MESA.PARSED) (* Interface already loaded. - *) - (RETURN))) - (SELECTQ (ASKUSER NIL NIL (CONCAT "Should I parse " ID ".MESA?")) - (Y [SETQ FILE (OR (FINDFILE (PACK* ID '.MESA) - NIL PARSE.DIRLST) - (MKATOM (PROMPTFORWORD (CONCAT "Enter full filename for " ID ".MESA:" - ] - (COND - (FILE (SETQ STATE (PARSE.GET.STATE)) - (PARSE.FILE FILE PARSE.LANGUAGE PARSE.DIRLST) - (PARSE.SET.STATE STATE)))) - (N NIL) - (SHOULDNT]) - -(PARSE.SEADIRT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") - (* BOTH (cedar) *) - (* CEDAR (cedar CEDAR) *) - (COND - ((EQ PARSE.ATOM 'CEDAR) - (PARSE.THISIS.CEDAR) - (PARSE.BIN]) - -(PARSE.PROGHEAD - [LAMBDA NIL (* kbr%: "25-Nov-85 12:46") - (PROG NIL (* (proghead resident safe class - arguments locks interface tilde public) - *) - - (* In MESA, tilde must be =. This is handled by PARSE.TILDE. - *) - - (PARSE.RESIDENT) - (PARSE.SAFE) - (PARSE.CLASS) - (PARSE.ARGUMENTS) - (PARSE.LOCKS) - (PARSE.INTERFACE) - (PARSE.TILDE) - (PARSE.PUBLIC]) - -(PARSE.RESIDENT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* BOTH (resident) *) - (* MESA (resident RESIDENT) *) - (COND - ((EQ PARSE.ATOM 'RESIDENT) - (PARSE.THISIS.MESA) - (PARSE.BIN]) - -(PARSE.SAFE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* BOTH (safe) *) - (* CEDAR (safe UNSAFE) - (safe SAFE) *) - (COND - ((FMEMB PARSE.ATOM '(SAFE UNSAFE)) - (PARSE.THISIS.CEDAR) - (PARSE.BIN]) - -(PARSE.DEFHEAD - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG NIL (* (defhead definitions locks imports - shares tilde public) *) - (PARSE.DEFINITIONS) - (PARSE.LOCKS) - (PARSE.IMPORTS) - (PARSE.SHARES) - (PARSE.TILDE) - (PARSE.PUBLIC]) - -(PARSE.TILDE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* BOTH (tilde =) *) - (* CEDAR (tilde ~) *) - (COND - ((EQ PARSE.ATOM '=) - (PARSE.BIN)) - ((EQ PARSE.ATOM '~) - (PARSE.THISIS.CEDAR) - (PARSE.BIN)) - (T (SHOULDNT]) - -(PARSE.DEFINITIONS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (definitions DEFINITIONS) *) - (PARSE.BIN]) - -(PARSE.DEFBODY - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG NIL (* (defbody BEGIN open declist END) - (defbody BEGIN open declist ; - END) (defbody { open declist }) - (defbody { open declist ; - }) *) - (PARSE.BIN '(BEGIN {)) - (BUILD.PUSH.SCOPE) - (BUILD.STORE.OPEN (PARSE.OPEN)) - (PARSE.DECLIST) - (BUILD.POP.SCOPE) - (BUILD.GC.SCOPE) - (COND - ((EQ PARSE.ATOM ';) - (PARSE.BIN))) - (PARSE.BIN '(END }]) - -(PARSE.LOCKS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG NIL (* (locks LOCKS primary lambda) - (locks) *) - (COND - ((EQ PARSE.ATOM 'LOCKS) - (PARSE.BIN) - (PARSE.PRIMARY) - (PARSE.LAMBDA]) - -(PARSE.LAMBDA - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (IDENT TYPEEXP) (* (lambda USING ident typeexp) - (lambda) *) - (COND - ((EQ PARSE.ATOM 'USING) - (PARSE.BIN) - (SETQ IDENT (PARSE.IDENT)) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (BUILD.INITIALIZE.VAR IDENT TYPEEXP NIL BUILD.CURRENT.SCOPE]) - -(PARSE.MODULEITEM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ID1 ID2) (* (moduleitem id) (moduleitem id %: - id) *) - (SETQ ID1 (PARSE.BIN 'ID)) - [COND - ((EQ PARSE.ATOM '%:) - (PARSE.BIN) - (SETQ ID2 (PARSE.BIN 'ID)) - (PUTPROP ID1 'MESA.ABBREVIATES 'ID2] - (RETURN ID1]) - -(PARSE.DECLARATION - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (IDENTLIST TYPEEXP INITIALIZATION DEFAULT OPTSIZE ANSWER) - (* (declaration identlist public entry - readonly typeexp initialization) - (declaration identlist public TYPE - tilde public typeexp default) - (declaration identlist public TYPE - optsize) *) - - (* In MESA, tilde must be =. This is handled by PARSE.TILDE. - *) - - (SETQ IDENTLIST (PARSE.IDENTLIST)) - (BUILD.STORE.IDENTLIST IDENTLIST) - (PARSE.PUBLIC) - [COND - ((NOT (EQ PARSE.ATOM 'TYPE)) - (PARSE.ENTRY) - (PARSE.READONLY) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (SETQ INITIALIZATION (PARSE.INITIALIZATION)) - (SETQ ANSWER (BUILD.INITIALIZATION IDENTLIST TYPEEXP INITIALIZATION))) - (T (PARSE.BIN 'TYPE) - (COND - ([OR (EQ PARSE.ATOM '=) - (AND (EQ PARSE.LANGUAGE 'CEDAR) - (EQ PARSE.ATOM '~] - (PARSE.TILDE) - (PARSE.PUBLIC) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (SETQ DEFAULT (PARSE.DEFAULT)) - (BUILD.TYPE IDENTLIST TYPEEXP DEFAULT)) - (T (SETQ OPTSIZE (PARSE.OPTSIZE)) - - (* I think this means MESA/CEDAR is to treat declared id as a type, but no - declaration of id is given in this file. - *) - - ] - (BUILD.STORE.IDENTLIST NIL) - (RETURN ANSWER]) - -(PARSE.PUBLIC - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (public PUBLIC) (public PRIVATE) - (public) *) - (COND - ((MEMB PARSE.ATOM '(PUBLIC PRIVATE)) - (PARSE.BIN]) - -(PARSE.ENTRY - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (entry ENTRY) (entry INTERNAL) - (entry) *) - (COND - ((MEMB PARSE.ATOM '(ENTRY INTERNAL)) - (PARSE.BIN]) - -(PARSE.IDLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (idlist' id) (idlist' id %, idlist') - *) - (PROG (IDS ANSWER) - (push IDS (PARSE.BIN 'ID)) - [while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push IDS (PARSE.BIN 'ID] - (SETQ ANSWER (DREVERSE IDS)) - (RETURN ANSWER]) - -(PARSE.IDENTLIST - [LAMBDA (KIND) (* kbr%: "25-Nov-85 12:47") - (* (identlist' id %:) - (identlist' id position %:) - (identlist' id %, identlist') - (identlist' id position %, identlist') - *) - (PROG (IDS TYPEITEMS ANSWER) - LOOP - (COND - ((AND (EQ KIND 'FIELDLIST) - (PARSE.TYPEEXP.HERE)) - - (* Thought we we're parsing a pairlist, but now we learn we are in a typelist. - *) - - (SETQ TYPEITEMS (fetch (TYPELIST ITEMS) of (PARSE.TYPELIST))) - (GO TYPELIST))) - (push IDS (PARSE.BIN 'ID)) - (COND - ((EQ PARSE.ATOM '%() - (PARSE.POSITION))) - (COND - ((EQ PARSE.ATOM '%,) - (PARSE.BIN) - (GO LOOP)) - (T (GO EXIT))) - (GO LOOP) - EXIT - (COND - ((NOT (EQ PARSE.ATOM '%:)) - (GO TYPELIST))) - (PARSE.BIN '%:) - (SETQ ANSWER (DREVERSE IDS)) - (RETURN ANSWER) - TYPELIST - (SETQ ANSWER (create TYPELIST - ITEMS _ (NCONC (DREVERSE IDS) - TYPEITEMS))) - (RETURN ANSWER]) - -(PARSE.POSITION - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (EXP OPTBITS ANSWER) (* (position %( exp optbits %)) *) - (PARSE.BIN '%() - (SETQ EXP (PARSE.EXP)) - (SETQ OPTBITS (PARSE.OPTBITS)) - (PARSE.BIN '%)) - (SETQ ANSWER (LIST 'position EXP OPTBITS)) - (RETURN ANSWER]) - -(PARSE.OPTBITS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (optbits %: bounds) - (optbits) *) - (COND - ((EQ PARSE.ATOM '%:) - (PARSE.BIN '%:) - (PARSE.BOUNDS]) - -(PARSE.INTERVAL - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (KIND BOUNDS ANSWER) (* (interval %[ bounds %]) - (interval %[ bounds %)) - (interval %( bounds %]) - (interval %( bounds %)) *) - (SELECTQ PARSE.ATOM - (%[ (PARSE.BIN) - (SETQ BOUNDS (PARSE.BOUNDS)) - (SELECTQ PARSE.ATOM - (%] (SETQ KIND 'CC)) - (%) (SETQ KIND 'CO)) - (SHOULDNT)) - (PARSE.BIN)) - (%( (PARSE.BIN) - (SETQ BOUNDS (PARSE.BOUNDS)) - (SELECTQ PARSE.ATOM - (%] (SETQ KIND 'OC)) - (%) (SETQ KIND 'OO)) - (SHOULDNT)) - (PARSE.BIN)) - (SHOULDNT)) - (SETQ ANSWER (create MINTERVAL - KIND _ KIND - BOUNDS _ BOUNDS)) - (RETURN ANSWER]) - -(PARSE.TYPEEXP.HERE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - NIL]) - -(PARSE.TYPEEXP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ANSWER) (* (typeexp id) (typeexp typeid) - (typeexp typecons)) - [COND - [(EQ PARSE.CLASS 'ID) - (SETQ ANSWER (PARSE.BIN)) - [COND - ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW)) - (SETQ ANSWER (PARSE.TYPEID.CONT ANSWER))) - (T (SETQ ANSWER (BUILD.TYPEID NIL ANSWER] - (COND - ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW)) - (SETQ ANSWER (PARSE.TYPECONS.CONT ANSWER] - (T (SETQ ANSWER (PARSE.TYPECONS] - (RETURN ANSWER]) - -(PARSE.RANGE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TYPE INTERVAL ANSWER) (* (range id) (range id interval) - (range typeid interval) - (range interval) (range typeid) *) - [COND - ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST) - (SETQ TYPE 'CARDINAL) - (SETQ INTERVAL (PARSE.INTERVAL))) - ((FMEMB PARSE.ATOM2 PARSE.RANGE.FOLLOW) - - (* This case occurs if TYPE itself is a range type. - *) - - [SETQ TYPE (BUILD.TYPEID NIL (PARSE.BIN 'ID] - (RETURN TYPE)) - ((FMEMB PARSE.ATOM2 PARSE.INTERVAL.FIRST) - [SETQ TYPE (BUILD.TYPEID NIL (PARSE.BIN 'ID] - (SETQ INTERVAL (PARSE.INTERVAL))) - (T (SETQ TYPE (PARSE.TYPEID)) - (COND - ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST) - (SETQ INTERVAL (PARSE.INTERVAL] - (SETQ ANSWER (create MRANGE - TYPE _ TYPE - INTERVAL _ INTERVAL)) - (RETURN ANSWER]) - -(PARSE.TYPEAPPL - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG NIL (* (typeappl typeappl %. - id) (typeappl id length) - (typeappl typeid length) - (typeappl typeappl length) *) - (BREAK1 NIL T]) - -(PARSE.TYPEAPPL.CONT - [LAMBDA (TYPEAPPL) (* kbr%: "25-Nov-85 12:47") - (PROG (ID LENGTH ANSWER) - (SETQ ANSWER TYPEAPPL) - [while (FMEMB PARSE.ATOM '(%. %[)) do (COND - ((EQ PARSE.ATOM '%.) - (PARSE.BIN) - (SETQ ID (PARSE.BIN 'ID)) - (SETQ ANSWER (LIST ANSWER ID))) - (T (SETQ LENGTH (PARSE.LENGTH)) - (SETQ ANSWER (LIST ANSWER LENGTH] - (RETURN ANSWER]) - -(PARSE.TYPEID - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PARSE.TYPEID.CONT (PARSE.BIN 'ID]) - -(PARSE.TYPEID.CONT - [LAMBDA (ID) (* kbr%: "25-Nov-85 12:47") - (PROG (INTERFACE ANSWER) (* (typeid' id %. id) - (typeid' typeid' %. id) - (typeid id id) (typeid id typeid) - (typeid typeid') *) - (* Should be ID+{.ID}* *) - (while (EQ PARSE.CLASS 'ID) do (BREAK1 NIL T) - (SETQ ID (PARSE.BIN))) - [COND - ((EQ PARSE.ATOM '%.) - (SETQ INTERFACE ID) - (PARSE.BIN) - (SETQ ID (PARSE.BIN 'ID] - (SETQ ANSWER (BUILD.TYPEID INTERFACE ID)) - (RETURN ANSWER]) - -(PARSE.TYPECONS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (COND - ((EQ PARSE.CLASS 'ID) - (PARSE.TYPECONS1)) - (T (PARSE.TYPECONS2]) - -(PARSE.TYPECONS1 - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* TYPECONS begining with ID token. - *) - (PROG (TYPEID ANSWER) (* BOTH (typecons id interval) - (typecons typeid interval) - (typecons id RELATIVE typeexp) - (typecons typeid RELATIVE typeexp) - (typecons typeappl) *) - (* CEDAR (typecons id PAINTED typeexp) - (typecons typeid PAINTED typeexp) *) - (* Get id or typeid. - *) - (SETQ TYPEID (PARSE.BIN 'ID)) - [COND - ((NOT (FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW)) - (SETQ TYPEID (PARSE.TYPEID.CONT TYPEID))) - (T (SETQ TYPEID (BUILD.TYPEID NIL TYPEID] (* Finish typecons. *) - (SETQ ANSWER (PARSE.TYPECONS.CONT TYPEID)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.CONT - [LAMBDA (TYPEID) (* kbr%: "25-Nov-85 12:47") - (* ; - "TYPEID is an id or typeid. Finish typecons.") - (PROG (INTERVAL TYPEEXP EXP1 EXP2 KIND ANSWER) - - (* ;; "BOTH (typecons id interval) (typecons typeid interval) (typecons id RELATIVE typeexp) (typecons typeid RELATIVE typeexp) (typecons typeappl) ") - - (* ;; "CEDAR (typecons id PAINTED typeexp) (typecons typeid PAINTED typeexp) *") - - (COND - ((EQ PARSE.ATOM 'RELATIVE) - (SETQ ANSWER (PARSE.TYPECONS.RELATIVE))) - ((EQ PARSE.ATOM 'PAINTED) - (SETQ ANSWER (PARSE.TYPECONS.PAINTED))) - ((EQ PARSE.ATOM '%() - (PARSE.TYPECONS.RANGE TYPEID)) - [(EQ PARSE.ATOM '%[) (* ; - "This can be the start of a length or of an interval. Can't tell with bounded look ahead. ") - (PARSE.BIN '%[) - (SETQ EXP1 (PARSE.EXP)) - (COND - ((EQ PARSE.ATOM '|..|) (* ; "Interval. ") - (PARSE.BIN '|..|) - (SETQ EXP2 (PARSE.EXP)) - [COND - ((EQ PARSE.ATOM '%)) - (PARSE.BIN '%)) - (SETQ KIND 'CO)) - (T (PARSE.BIN '%]) - (SETQ KIND 'CC] - (SETQ INTERVAL (create MINTERVAL - KIND _ KIND - BOUNDS _ (LIST EXP1 EXP2))) - (SETQ ANSWER (create MRANGE - TYPE _ TYPEID - INTERVAL _ INTERVAL))) - (T (* ; "Length. *") - (PARSE.BIN '%]) - (SETQ ANSWER (LIST TYPEID EXP1)) - (SETQ ANSWER (PARSE.TYPEAPPL.CONT ANSWER] - (T (SHOULDNT))) - (RETURN ANSWER]) - -(PARSE.TYPECONS.RANGE - [LAMBDA (TYPEID) (* kbr%: "25-Nov-85 12:47") - (PROG (INTERVAL ANSWER) - (SETQ INTERVAL (PARSE.INTERVAL)) - (SETQ ANSWER (create MRANGE - TYPE _ TYPEID - INTERVAL _ INTERVAL)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.RELATIVE - [LAMBDA (TYPEID) (* kbr%: "25-Nov-85 12:47") - (PROG (TYPE ANSWER) - (PARSE.BIN 'RELATIVE) - (SETQ TYPE (PARSE.TYPEEXP)) - (SETQ ANSWER (create MRELATIVE - TYPEID _ TYPEID - TYPE _ TYPE)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.PAINTED - [LAMBDA (TYPEID) (* kbr%: "25-Nov-85 12:47") - (PROG (TYPE ANSWER) - (PARSE.THISIS.CEDAR) - (PARSE.BIN 'RELATIVE) - (SETQ TYPE (PARSE.TYPEEXP)) - (SETQ ANSWER (create MPAINTED - TYPEID _ TYPEID - TYPE _ TYPE)) - (RETURN ANSWER]) - -(PARSE.TYPECONS2 - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* TYPECONS begining with reserved - word. *) - (PROG (ANSWER) - - (* BOTH (typecons interval) (typecons dependent { elementlist }) - (typecons dependent monitored RECORD reclist) - (typecons ordered base pointertype) (typecons VAR typeexp) - (typecons packed ARRAY indextype OF typeexp) - (typecons DESCRIPTOR FOR readonly typeexp) - (typecons safe transfermode arguments) (typecons heap ZONE) - (typecons LONG typeexp) (typecons FRAME %[ id %]) *) - (* CEDAR (typecons REF readonly - typeexp) (typecons REF readonly ANY) - (typecons REF) (typecons LIST OF - readonly typeexp) *) - [SETQ ANSWER (COND - ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST) - (PARSE.TYPECONS.INTERVAL)) - (T (SELECTQ PARSE.ATOM - ((MACHINE MONITORED RECORD {) - (PARSE.TYPECONS.DEPENDENT)) - ((ORDERED BASE POINTER) - (PARSE.TYPECONS.ORDERED)) - (VAR (PARSE.TYPECONS.VAR)) - ((PACKED ARRAY) - (PARSE.TYPECONS.PACKED)) - (DESCRIPTOR (PARSE.TYPECONS.DESCRIPTOR)) - ((SAFE ERROR PORT PROC PROCEDURE PROCESS PROGRAM SIGNAL) - (PARSE.TYPECONS.SAFE)) - (UNCOUNTED (PARSE.TYPECONS.HEAP)) - (LONG (PARSE.TYPECONS.LONG)) - (FRAME (PARSE.TYPECONS.FRAME)) - (REF (PARSE.TYPECONS.REF)) - (LIST (PARSE.TYPECONS.LIST)) - (SHOULDNT] - (RETURN ANSWER]) - -(PARSE.TYPECONS.INTERVAL - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ANSWER) (* (typecons interval) *) - (SETQ ANSWER (create MRANGE - TYPE _ 'CARDINAL - INTERVAL _ (PARSE.INTERVAL))) - (RETURN ANSWER]) - -(PARSE.TYPECONS.DEPENDENT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ELEMENTLIST RECLIST ANSWER) (* (typecons dependent { elementlist }) - (typecons dependent monitored RECORD - reclist) *) - (PARSE.DEPENDENT) - [SETQ ANSWER (COND - ((EQ PARSE.ATOM '{) - (PARSE.TYPECONS.ENUMERATED)) - (T (PARSE.TYPECONS.RECORD] - (RETURN ANSWER]) - -(PARSE.TYPECONS.ENUMERATED - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ITEMS ANSWER) - (PARSE.BIN) - (SETQ ITEMS (PARSE.ELEMENTLIST)) - (PARSE.BIN '}) - (SETQ ANSWER (create MENUMERATED - ITEMS _ ITEMS)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.RECORD - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (FIELDLIST ANSWER) - (PARSE.MONITORED) - (PARSE.BIN 'RECORD) - (SETQ FIELDLIST (PARSE.RECLIST)) - (SETQ ANSWER (create MRECORD - FIELDLIST _ FIELDLIST)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.ORDERED - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ANSWER) (* (typecons ordered base pointertype) - *) - (PARSE.ORDERED) - (PARSE.BASE) - (SETQ ANSWER (PARSE.POINTERTYPE)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.VAR - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TYPE ANSWER) (* (typecons VAR typeexp) *) - (PARSE.BIN 'VAR) - (SETQ TYPE (PARSE.TYPEEXP)) - (SETQ ANSWER (create MVAR - TYPE _ TYPE)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.PACKED - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (PACKED INDEXTYPE TYPE ANSWER) (* (typecons packed ARRAY indextype OF - typeexp) *) - (SETQ PACKED (PARSE.PACKED)) - (PARSE.BIN 'ARRAY) - (SETQ INDEXTYPE (PARSE.INDEXTYPE)) - (PARSE.BIN 'OF) - (SETQ TYPE (PARSE.TYPEEXP)) - (SETQ ANSWER (create MARRAY - INDEXTYPE _ INDEXTYPE - TYPE _ TYPE)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.DESCRIPTOR - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TYPE ANSWER) (* (typecons DESCRIPTOR FOR readonly - typeexp) *) - (PARSE.BIN 'DESCRIPTOR) - (PARSE.BIN 'FOR) - (PARSE.READONLY) - (SETQ TYPE (PARSE.TYPEEXP)) - (SETQ ANSWER (create MDESCRIPTOR - TYPE _ TYPE)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.SAFE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TRANSFERMODE) (* (typecons safe transfermode - arguments) *) - (PARSE.SAFE) - (SETQ TRANSFERMODE (PARSE.TRANSFERMODE)) - (PARSE.ARGUMENTS) - (RETURN TRANSFERMODE]) - -(PARSE.TYPECONS.HEAP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG NIL (* (typecons heap ZONE) *) - (PARSE.HEAP) - (PARSE.BIN 'ZONE) - (RETURN 'ZONE]) - -(PARSE.TYPECONS.LONG - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ANSWER) (* (typecons LONG typeexp) *) - (PARSE.BIN 'LONG) - (SETQ ANSWER (PARSE.TYPEEXP)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.FRAME - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ID ANSWER) (* (typecons FRAME %[ id %]) *) - (PARSE.BIN 'FRAME) - (PARSE.BIN '%[) - [SETQ ID (BUILD.ID NIL (PARSE.BIN 'ID] - (PARSE.BIN '%]) - (SETQ ANSWER (create MFRAME - ID _ ID)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.REF - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TYPE ANSWER) (* CEDAR (typecons REF readonly - typeexp) (typecons REF readonly ANY) - (typecons REF) *) - (PARSE.THISIS.CEDAR) - (PARSE.BIN 'REF) - [COND - ((FMEMB PARSE.ATOM PARSE.TYPEEXP.FOLLOW) - (SETQ TYPE 'ANY)) - (T (PARSE.READONLY) - (COND - ((EQ PARSE.ATOM 'ANY) - (PARSE.BIN) - (SETQ TYPE 'ANY)) - (T (SETQ TYPE (PARSE.TYPEEXP] - (SETQ ANSWER (create MREF - TYPE _ TYPE)) - (RETURN ANSWER]) - -(PARSE.TYPECONS.LIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TYPE ANSWER) (* CEDAR (typecons LIST OF readonly - typeexp) *) - (PARSE.THISIS.CEDAR) - (PARSE.BIN 'LIST) - (PARSE.BIN 'OF) - (PARSE.READONLY) - (SETQ TYPE (PARSE.TYPEEXP)) - (SETQ ANSWER (create MLIST - TYPE _ TYPE)) - (RETURN ANSWER]) - -(PARSE.IDENT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ID) (* (ident id position %:) - (ident id %:) *) - (SETQ ID (PARSE.BIN 'ID)) - [COND - ((EQ PARSE.ATOM '%:) - (PARSE.BIN)) - (T (PARSE.POSITION) - (PARSE.BIN '%:] - (RETURN ID]) - -(PARSE.ELEMENT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ID EXP ANSWER) (* (element id %( exp %)) - (element %( exp %)) (element id) *) - [COND - ((NOT (EQ PARSE.ATOM '%()) - (SETQ ID (PARSE.BIN 'ID] - (COND - ((EQ PARSE.ATOM '%() - (PARSE.BIN) - (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER ID) - (PARSE.BIN '%))) - (T (SETQ ANSWER ID))) - (RETURN ANSWER]) - -(PARSE.MONITORED - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (monitored MONITORED) - (monitored) *) - (COND - ((EQ PARSE.ATOM 'MONITORED) - (PARSE.BIN]) - -(PARSE.DEPENDENT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (dependent MACHINE DEPENDENT) - (dependent) *) - (COND - ((EQ PARSE.ATOM 'MACHINE) - (PARSE.BIN) - (PARSE.BIN 'DEPENDENT) - 'MACHINE.DEPENDENT]) - -(PARSE.RECLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (PAIRLIST TYPELIST VARIANTPAIR VARIANTPART DEFAULT ANSWER) - (* (reclist %[ %]) (reclist NULL) - (reclist %[ pairlist %]) - (reclist %[ typelist %]) - (reclist %[ pairlist %, variantpair %]) - (reclist %[ variantpart default %]) - (reclist %[ variantpair %]) *) - (COND - ((EQ PARSE.ATOM 'NULL) - (PARSE.BIN) - (RETURN NIL))) - (PARSE.BIN '%[) - (COND - ((EQ PARSE.ATOM '%]) - (PARSE.BIN) - (RETURN NIL))) - (COND - [(FMEMB PARSE.ATOM PARSE.VARIANTPART.FIRST) - (SETQ VARIANTPART (PARSE.VARIANTPART)) - (SETQ DEFAULT (PARSE.DEFAULT)) - (SETQ ANSWER (LIST (create PAIRITEM - TYPEEXP _ VARIANTPART - DEFAULT _ DEFAULT] - ([AND (EQ PARSE.CLASS 'ID) - (NOT (FMEMB PARSE.ATOM PARSE.PREDEFINED.TYPES)) - (FMEMB PARSE.ATOM2 '(%( %, %:] - (SETQ PAIRLIST (PARSE.PAIRLIST 'RECLIST)) - [for PAIRITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST) - do (replace (PAIRITEM ID) of PAIRITEM with (BUILD.FIELDID NIL (fetch (PAIRITEM - ID) - of PAIRITEM] - (SETQ ANSWER PAIRLIST)) - (T (SETQ TYPELIST (PARSE.TYPELIST)) - (SETQ ANSWER TYPELIST))) - (PARSE.BIN '%]) - (RETURN ANSWER]) - -(PARSE.VARIANTPAIR - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (IDENTLIST PUBLIC VARIANTPART DEFAULT ANSWER) (* (variantpair identlist public - variantpart default) *) - (SETQ IDENTLIST (PARSE.IDENTLIST)) - (PARSE.PUBLIC) - (SETQ VARIANTPART (PARSE.VARIANTPART)) - (SETQ DEFAULT (PARSE.DEFAULT)) - (SETQ ANSWER (for ID in IDENTLIST - collect (create PAIRITEM - ID _ ID - TYPEEXP _ VARIANTPART - DEFAULT _ DEFAULT))) - (RETURN ANSWER]) - -(PARSE.PAIRITEM - [LAMBDA (KIND) (* kbr%: "25-Nov-85 12:47") - (PROG (IDENTLIST VARIANTPART TYPEEXP DEFAULT ANSWER) (* (pairitem identlist public typeexp - default) (variantpair identlist public - variantpart default) *) - (SETQ IDENTLIST (PARSE.IDENTLIST KIND)) - (COND - ((type? TYPELIST IDENTLIST) - - (* Thought we we're parsing a pairlist but found a typelist. - *) - - (RETURN IDENTLIST))) - (PARSE.PUBLIC) - [COND - ([AND (FMEMB PARSE.ATOM PARSE.VARIANTPART.FIRST) - (OR (NOT (EQ PARSE.ATOM 'PACKED)) - (NOT (EQ PARSE.ATOM2 'ARRAY] (* Variantpair. *) - (COND - ((NOT (EQ KIND 'RECLIST)) - (SHOULDNT))) - (SETQ TYPEEXP (PARSE.VARIANTPART))) - (T (* Typeexp. *) - (SETQ TYPEEXP (PARSE.TYPEEXP] - (SETQ DEFAULT (PARSE.DEFAULT)) - (SETQ ANSWER (for ID in IDENTLIST - collect (create PAIRITEM - ID _ ID - TYPEEXP _ TYPEEXP - DEFAULT _ DEFAULT))) - (RETURN ANSWER]) - -(PARSE.DEFAULTOPT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (EXP TRASH ANSWER) (* (defaultopt TRASH) - (defaultopt NULL) (defaultopt exp %| - TRASH) (defaultopt exp %| NULL) - (defaultopt) (defaultopt exp) *) - [COND - ((FMEMB PARSE.ATOM '(TRASH NULL)) - (PARSE.BIN) - (SETQ TRASH T)) - ((NOT (FMEMB PARSE.ATOM PARSE.DEFAULTOPT.FOLLOW)) - (SETQ EXP (PARSE.EXP)) - (COND - ((EQ PARSE.ATOM '%|) - (PARSE.BIN '%|) - (COND - ((FMEMB PARSE.ATOM '(TRASH NULL)) - (PARSE.BIN) - (SETQ TRASH T] - (SETQ ANSWER (create DEFAULT - EXP _ EXP - TRASH _ TRASH)) - (RETURN ANSWER]) - -(PARSE.VARIANTPART - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (VCASEHEAD VARIANTLIST TYPEEXP ANSWER) (* (variantpart SELECT vcasehead FROM - variantlist ENDCASE) - (variantpart SELECT vcasehead FROM - variantlist %, ENDCASE) - (variantpart packed SEQUENCE vcasehead - OF typeexp) *) - [COND - ((EQ PARSE.ATOM 'SELECT) - (PARSE.BIN) - (SETQ VCASEHEAD (PARSE.VCASEHEAD)) - (PARSE.BIN 'FROM) - (SETQ VARIANTLIST (PARSE.VARIANTLIST)) - (COND - ((EQ PARSE.ATOM '%,) - (PARSE.BIN))) - (PARSE.BIN 'ENDCASE) - (SETQ ANSWER (LIST 'SELECT VCASEHEAD VARIANTLIST))) - (T (SETQ PACKED (PARSE.PACKED)) - (PARSE.BIN 'SEQUENCE) - (SETQ VCASEHEAD (PARSE.VCASEHEAD)) - (PARSE.BIN 'OF) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (SETQ ANSWER (LIST 'SEQUENCE VCASEHEAD TYPEEXP] - (RETURN ANSWER]) - -(PARSE.VCASEHEAD - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (IDENT PUBLIC TAGTYPE ANSWER) (* (vcasehead ident public tagtype) - (vcasehead COMPUTED tagtype) - (vcasehead OVERLAID tagtype) *) - [COND - ([NOT (FMEMB PARSE.ATOM '(COMPUTED OVERLAID] - (SETQ IDENT (PARSE.IDENT)) - (SETQ PUBLIC (PARSE.PUBLIC)) - (SETQ TAGTYPE (PARSE.TAGTYPE)) - (SETQ ANSWER (LIST 'vcasehead IDENT PUBLIC TAGTYPE))) - (T (SETQ ANSWER (LIST 'vcasehead (PARSE.BIN) - (PARSE.TAGTYPE] - (RETURN ANSWER]) - -(PARSE.TAGTYPE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (tagtype *) (tagtype typeexp) *) - (COND - ((EQ PARSE.ATOM '*) - (PARSE.BIN)) - (T (PARSE.TYPEEXP]) - -(PARSE.VARIANTITEM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (IDLIST RECLIST ANSWER) (* (variantitem idlist => reclist) *) - (SETQ IDLIST (PARSE.IDLIST)) - (PARSE.BIN '=>) - (SETQ RECLIST (PARSE.RECLIST)) - (SETQ ANSWER (LIST 'variantitem IDLIST RECLIST)) - (RETURN ANSWER]) - -(PARSE.TYPELIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TYPEITEMS ANSWER) (* (typelist typecons default) - (typelist typeid default) - (typelist id) (typelist id _ - defaultopt) (typelist typecons default - %, typelist) (typelist typeid default - %, typelist) (typelist id %, typelist) - (typelist id _ defaultopt %, typelist) - *) - (push TYPEITEMS (PARSE.TYPEITEM)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push TYPEITEMS (PARSE.TYPEITEM))) - (SETQ ANSWER (create TYPELIST - ITEMS _ (DREVERSE TYPEITEMS))) - (RETURN ANSWER]) - -(PARSE.TYPEITEM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TYPEEXP DEFAULT ANSWER) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - [COND - ((NOT (LITATOM TYPEEXP)) - (SETQ DEFAULT (PARSE.DEFAULT))) - ((EQ PARSE.ATOM '_) - (SETQ DEFAULT (PARSE.DEFAULTOPT] - (SETQ ANSWER (create TYPEITEM - TYPEEXP _ TYPEEXP - DEFAULT _ DEFAULT)) - (RETURN ANSWER]) - -(PARSE.POINTERTYPE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TYPE ANSWER) (* (pointertype pointerprefix) - (pointertype pointerprefix TO readonly - typeexp) *) - (PARSE.POINTERPREFIX) - [COND - ((EQ PARSE.ATOM 'TO) - (PARSE.BIN) - (PARSE.READONLY) - (SETQ TYPE (PARSE.TYPEEXP))) - (T (SETQ TYPE 'UNSPECIFIED] - (SETQ ANSWER (create MPOINTER - TYPE _ TYPE)) - (RETURN ANSWER]) - -(PARSE.TRANSFERMODE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (transfermode PROCEDURE) - (transfermode PROC) (transfermode PORT) - (transfermode SIGNAL) - (transfermode ERROR) - (transfermode PROCESS) - (transfermode PROGRAM) *) - (PROG NIL - (PARSE.BIN) - (RETURN 'PROC]) - -(PARSE.INITIALIZATION - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ANSWER) (* (initialization) (initialization _ - initvalue) (initialization tilde - initvalue) *) - (* In MESA tilde must be =. - *) - [COND - ([OR (FMEMB PARSE.ATOM '(_ =)) - (AND (EQ PARSE.LANGUAGE 'CEDAR) - (EQ PARSE.ATOM '~] - (PARSE.BIN) - (SETQ ANSWER (PARSE.INITVALUE] - (RETURN ANSWER]) - -(PARSE.INITVALUE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (INLINE BLOCK CODELIST EXP ANSWER) (* (initvalue procaccess trusted - checked inline block) - (initvalue CODE) (initvalue procaccess - trusted checked MACHINE CODE BEGIN - codelist END) (initvalue procaccess - trusted checked MACHINE CODE { - codelist }) (initvalue TRASH) - (initvalue NULL) (initvalue exp) *) - [COND - ((FMEMB PARSE.ATOM '(CODE TRASH NULL)) - (PARSE.BIN) - (SETQ ANSWER 'TRASH)) - (T (PARSE.CHECKED) - (COND - ((FMEMB PARSE.ATOM '(INLINE BEGIN {)) - (SETQ INLINE (PARSE.INLINE)) - (SETQ BLOCK (PARSE.BLOCK)) - (SETQ ANSWER BLOCK)) - ((EQ PARSE.ATOM 'MACHINE) - (PARSE.BIN) - (PARSE.BIN 'CODE) - (PARSE.BIN '(BEGIN {)) - (SETQ CODELIST (PARSE.CODELIST)) - (PARSE.BIN '(END })) - (SETQ ANSWER CODELIST)) - (T (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER EXP] - (RETURN ANSWER]) - -(PARSE.CHECKED - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* BOTH (checked) *) - (* CEDAR (checked CHECKED) - (checked TRUSTED) (checked UNCHECKED) - *) - (COND - ((FMEMB PARSE.ATOM '(CHECKED TRUSTED UNCHECKED)) - (PARSE.THISIS.CEDAR) - (PARSE.BIN]) - -(PARSE.CODELIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG NIL (* (codelist orderlist) - (codelist codelist ; - orderlist) *) - (BREAK1 NIL T]) - -(PARSE.STATEMENT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (COND - ((FMEMB PARSE.CLASS '(ID %()) - (PARSE.STATEMENT1)) - (T (PARSE.STATEMENT2]) - -(PARSE.STATEMENT1 - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (LHS EXP OPTCATCH ANSWER) (* (statement lhs) (statement lhs _ - exp) (statement free %[ exp optcatch - %]) (statement lhs _ STATE) *) - (SETQ LHS (PARSE.LHS)) - (COND - ((AND (EQ PARSE.ATOM '%.) - (EQ PARSE.ATOM2 'FREE)) - (PARSE.BIN) - (PARSE.BIN) - (PARSE.BIN '%[) - (SETQ EXP (PARSE.EXP)) - (SETQ OPTCATCH (PARSE.OPTCATCH)) - (PARSE.BIN '%]) - (SETQ ANSWER (LIST LHS EXP OPTCATCH))) - ((AND (EQ PARSE.ATOM '_) - (EQ PARSE.ATOM2 'STATE)) - (PARSE.BIN) - (PARSE.BIN) - (SETQ ANSWER LHS)) - ((EQ PARSE.ATOM '_) - (PARSE.BIN) - (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER (BUILD.SETQ LHS EXP))) - (T (SETQ ANSWER LHS))) - (RETURN ANSWER]) - -(PARSE.STATEMENT2 - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ANSWER) - - (* (statement %[ explist %] _ exp) (statement trusted checked block) - (statement IF exp THEN statement elsepart) - (statement casehead casestmtlist ENDCASE otherpart) - (statement forclause dotest DO scope doexit ENDLOOP) - (statement EXIT) (statement LOOP) (statement GOTO id) - (statement GO TO id) (statement RETURN optargs) - (statement transfer lhs) (statement WAIT lhs) - (statement ERROR) (statement STOP) (statement NULL) - (statement RESUME optargs) (statement REJECT) - (statement CONTINUE) (statement RETRY) *) - - [SETQ ANSWER (COND - ((FMEMB PARSE.ATOM PARSE.CASEHEAD.FIRST) - (PARSE.STATEMENT.CASEHEAD)) - ((OR (FMEMB PARSE.ATOM PARSE.FORCLAUSE.FIRST) - (FMEMB PARSE.ATOM PARSE.DOTEST.FIRST) - (EQ PARSE.ATOM 'DO)) - (PARSE.STATEMENT.FORCLAUSE)) - ([AND (EQ PARSE.ATOM 'RETURN) - (NOT (EQ PARSE.ATOM2 'WITH] - - (* Don't confuse statement RETURN with the transfer RETURN WITH. - *) - - (PARSE.STATEMENT.RETURN)) - ((FMEMB PARSE.ATOM PARSE.TRANSFER.FIRST) - (PARSE.STATEMENT.TRANSFER)) - (T (SELECTQ PARSE.ATOM - (%[ (PARSE.STATEMENT.LBRACKET)) - (({ BEGIN CHECKED TRUSTED UNCHECKED) - (PARSE.CHECKED) - (PARSE.BLOCK)) - (IF (PARSE.STATEMENT.IF)) - (EXIT (PARSE.BIN) - '(RETURN)) - (LOOP (PARSE.BIN) - '(GO LOOP)) - (GOTO (PARSE.BIN) - (LIST 'GO (PARSE.BIN 'ID))) - (GO (PARSE.BIN) - (PARSE.BIN 'TO) - (LIST 'GO (PARSE.BIN 'ID))) - (WAIT (PARSE.BIN) - (PARSE.LHS)) - (ERROR (PARSE.BIN) - '(SHOULDNT)) - (STOP (PARSE.BIN) - '(GO STOP)) - (NULL (PARSE.BIN) - NIL) - (RESUME (PARSE.BIN) - (PARSE.OPTARGS)) - (REJECT (PARSE.BIN) - '(SHOULDNT)) - (CONTINUE (PARSE.BIN) - '(GO CONTINUE)) - (RETRY (PARSE.BIN) - '(GO RETRY)) - (SHOULDNT] - (RETURN ANSWER]) - -(PARSE.STATEMENT.CASEHEAD - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (CASEHEAD CASESTMTLIST OTHERPART ANSWER) (* (statement casehead casestmtlist - ENDCASE otherpart) *) - (BUILD.PUSH.SCOPE) - (SETQ CASEHEAD (PARSE.CASEHEAD)) - (SETQ CASESTMTLIST (PARSE.CASESTMTLIST CASEHEAD)) - (PARSE.BIN 'ENDCASE) - (SETQ OTHERPART (PARSE.OTHERPART)) - (SETQ ANSWER (BUILD.SELECTQ CASEHEAD CASESTMTLIST OTHERPART)) - (COND - ((fetch (CASEHEAD ID) of CASEHEAD) - (BUILD.INITIALIZE.VAR (fetch (CASEHEAD ID) of CASEHEAD) - NIL - (fetch (CASEHEAD EXP) of CASEHEAD) - BUILD.CURRENT.SCOPE))) - (SETQ ANSWER (BUILD.PROG (LIST ANSWER))) - (BUILD.POP.SCOPE) - (RETURN ANSWER]) - -(PARSE.STATEMENT.FORCLAUSE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (FORCLAUSE DOTEST SCOPE DOEXIT EXITLIST STATEMENT ANSWER) - (* (statement forclause dotest DO - scope doexit ENDLOOP) *) - (BUILD.STORE.IDENTLIST '(DO)) - (BUILD.PUSH.SCOPE) - (SETQ FORCLAUSE (PARSE.FORCLAUSE)) - (SETQ DOTEST (PARSE.DOTEST)) - (PARSE.BIN 'DO) - (SETQ SCOPE (PARSE.SCOPE)) - (SETQ DOEXIT (PARSE.DOEXIT)) - (SETQ EXITLIST (CAR DOEXIT)) - (SETQ STATEMENT (CADR DOEXIT)) - (PARSE.BIN 'ENDLOOP) - (BUILD.POP.SCOPE) - [SETQ ANSWER `(,@FORCLAUSE ,@DOTEST do ,@(BUILD.TAIL SCOPE] - [COND - (STATEMENT (SETQ ANSWER `(,@ANSWER finally ,@(BUILD.TAIL STATEMENT] - [COND - (EXITLIST (SETQ ANSWER (BUILD.PROGN (CONS ANSWER EXITLIST] - (RETURN ANSWER]) - -(PARSE.STATEMENT.RETURN - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (OPTARGS ANSWER) (* (statement RETURN optargs) *) - (PARSE.BIN 'RETURN) - (SETQ OPTARGS (PARSE.OPTARGS)) - (SETQ ANSWER (BUILD.RETURN OPTARGS)) - (RETURN ANSWER]) - -(PARSE.STATEMENT.TRANSFER - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TRANSFER LHS ANSWER) (* (statement transfer lhs) *) - (SETQ TRANSFER (PARSE.TRANSFER)) - (SETQ LHS (PARSE.LHS)) - [SETQ ANSWER `(SHOULDNT ',LHS] - (RETURN ANSWER]) - -(PARSE.STATEMENT.LBRACKET - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (EXPLIST EXP ANSWER) (* (statement %[ explist %] _ exp) *) - (PARSE.BIN '%[) - (SETQ EXPLIST (PARSE.EXPLIST)) - (PARSE.BIN '%]) - (PARSE.BIN '_) - (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER (BUILD.SETQ EXPLIST EXP)) - (RETURN ANSWER]) - -(PARSE.STATEMENT.IF - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (EXP STATEMENT ELSEPART HEAD TAIL ANSWER) (* (statement IF exp THEN statement - elsepart) *) - (PARSE.BIN 'IF) - (SETQ EXP (PARSE.EXP)) - (PARSE.BIN 'THEN) - (SETQ STATEMENT (PARSE.STATEMENT)) - (SETQ ELSEPART (PARSE.ELSEPART)) - (SETQ ANSWER (BUILD.COND EXP STATEMENT ELSEPART)) - (RETURN ANSWER]) - -(PARSE.BLOCK - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (SCOPE EXITS ANSWER) (* (block BEGIN scope exits END) - (block { scope exits }) *) - (BUILD.PUSH.SCOPE) - (PARSE.BIN '(BEGIN {)) - (SETQ SCOPE (PARSE.SCOPE)) - (SETQ EXITS (PARSE.EXITS)) - (PARSE.BIN '(END })) - (BUILD.POP.SCOPE) - (SETQ ANSWER (APPEND SCOPE EXITS)) - (RETURN ANSWER]) - -(PARSE.SCOPE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (STATEMENTLIST ANSWER) (* (scope open enables statementlist) - (scope open enables declist ; - statementlist) *) - (BUILD.STORE.OPEN (PARSE.OPEN)) - (PARSE.ENABLES) - (COND - ([AND (EQ PARSE.CLASS 'ID) - (FMEMB PARSE.ATOM2 '(%, %:] - (PARSE.DECLIST))) - (SETQ STATEMENTLIST (PARSE.STATEMENTLIST)) - (SETQ ANSWER (BUILD.PROG STATEMENTLIST)) - (RETURN ANSWER]) - -(PARSE.BINDITEM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ID EXP ANSWER) (* BOTH (binditem exp) - (binditem id %: exp) *) - (* CEDAR (binditem id ~ ~ exp) *) - [COND - ((AND (EQ PARSE.CLASS 'ID) - (EQ PARSE.ATOM2 '%:)) - (SETQ ID (PARSE.BIN)) - (PARSE.BIN)) - ((AND (EQ PARSE.LANGUAGE 'CEDAR) - (EQ PARSE.CLASS 'ID) - (EQ PARSE.ATOM2 '~)) - (SETQ ID (PARSE.BIN)) - (PARSE.BIN) - (PARSE.BIN '~] - (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER (create BINDITEM - ID _ ID - EXP _ EXP)) - (RETURN ANSWER]) - -(PARSE.EXITS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (exits EXITS exitlist) - (exits) *) - (COND - ((EQ PARSE.ATOM 'EXITS) - (PARSE.BIN) - (PARSE.EXITLIST]) - -(PARSE.CASESTMTITEM - [LAMBDA (CASEHEAD) (* kbr%: "25-Nov-85 12:47") - (PROG (CASELABEL STATEMENT ANSWER) (* (casestmtitem caselabel => - statement) *) - (SETQ CASELABEL (PARSE.CASELABEL)) - (PARSE.BIN '=>) - (SETQ STATEMENT (PARSE.STATEMENT)) - (SETQ ANSWER (CONS CASELABEL (BUILD.TAIL STATEMENT))) - (RETURN ANSWER]) - -(PARSE.CASEEXPITEM - [LAMBDA (CASEHEAD) (* kbr%: "25-Nov-85 12:47") - (PROG (CASELABEL EXP ANSWER) (* (caseexpitem caselabel => exp) *) - (SETQ CASELABEL (PARSE.CASELABEL)) - (PARSE.BIN '=>) - (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER (CONS CASELABEL (BUILD.TAIL EXP))) - (RETURN ANSWER]) - -(PARSE.EXITITEM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (IDLIST STATEMENT ANSWER) (* (exititem idlist => statement) *) - (SETQ IDLIST (PARSE.IDLIST)) - (PARSE.BIN '=>) - (SETQ STATEMENT (PARSE.STATEMENT)) - [SETQ ANSWER (BUILD.PROGN (NCONC IDLIST (BUILD.TAIL STATEMENT] - (RETURN ANSWER]) - -(PARSE.CASETEST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (OPTRELATION EXP ANSWER) (* (casetest optrelation) - (casetest exp) *) - (COND - ((FMEMB PARSE.ATOM PARSE.OPTRELATION.FIRST) - (SETQ OPTRELATION (PARSE.OPTRELATION)) - (SETQ ANSWER OPTRELATION)) - (T (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER EXP))) - (RETURN ANSWER]) - -(PARSE.CONTROLID - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ID TYPEEXP) (* (controlid ident typeexp) - (controlid id) *) - [COND - ((FMEMB PARSE.ATOM2 PARSE.CONTROLID.FOLLOW) - (SETQ ID (PARSE.BIN 'ID)) - (SETQ TYPEEXP 'INTEGER)) - (T (SETQ ID (PARSE.IDENT)) - (SETQ TYPEEXP (PARSE.TYPEEXP] - (BUILD.INITIALIZE.VAR ID TYPEEXP NIL BUILD.CURRENT.SCOPE) - (RETURN ID]) - -(PARSE.FORCLAUSE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (CONTROLID EXP1 EXP2 DIRECTION RANGE ANSWER) (* (forclause FOR controlid _ exp %, - exp) (forclause FOR controlid - direction IN range) (forclause THROUGH - range) (forclause) *) - [COND - [(EQ PARSE.ATOM 'FOR) - (PARSE.BIN) - (SETQ CONTROLID (PARSE.CONTROLID)) - (COND - ((EQ PARSE.ATOM '_) - (PARSE.BIN) - (SETQ EXP1 (PARSE.EXP)) - (PARSE.BIN '%,) - (SETQ EXP2 (PARSE.EXP)) - (SETQ ANSWER (BUILD.FORCLAUSE.BY CONTROLID EXP1 EXP2))) - (T (SETQ DIRECTION (PARSE.DIRECTION)) - (PARSE.BIN 'IN) - (SETQ RANGE (PARSE.RANGE)) - (SETQ ANSWER (BUILD.FORCLAUSE.IN CONTROLID DIRECTION RANGE] - ((EQ PARSE.ATOM 'THROUGH) - (PARSE.BIN) - (SETQ RANGE (PARSE.RANGE)) - (SETQ ANSWER (BUILD.FORCLAUSE.THROUGH RANGE] - (RETURN ANSWER]) - -(PARSE.DIRECTION - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (direction DECREASING) - (direction) *) - (COND - ((EQ PARSE.ATOM 'DECREASING) - (PARSE.BIN]) - -(PARSE.DOTEST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (dotest UNTIL exp) - (dotest WHILE exp) (dotest) *) - (COND - ((EQ PARSE.ATOM 'UNTIL) - (PARSE.BIN) - (LIST 'until (PARSE.EXP))) - ((EQ PARSE.ATOM 'WHILE) - (PARSE.BIN) - (LIST 'while (PARSE.EXP]) - -(PARSE.DOEXIT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (EXITLIST STATEMENT ANSWER) (* (doexit) (doexit REPEAT exitlist) - (doexit REPEAT exitlist FINISHED => - statement) (doexit REPEAT exitlist - FINISHED => statement ;) *) - [COND - ((EQ PARSE.ATOM 'REPEAT) - (PARSE.BIN) - (SETQ EXITLIST (PARSE.EXITLIST)) - (COND - ((EQ PARSE.ATOM 'FINISHED) - (PARSE.BIN) - (PARSE.BIN '=>) - (SETQ STATEMENT (PARSE.STATEMENT)) - (COND - ((EQ PARSE.ATOM ';) - (PARSE.BIN] - (SETQ ANSWER (LIST EXITLIST STATEMENT)) - (RETURN ANSWER]) - -(PARSE.ENABLES - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (CATCHCASE CATCHANY CATCHLIST ANSWER) (* (enables ENABLE catchcase ;) - (enables ENABLE catchany ;) - (enables ENABLE BEGIN catchlist END ;) - (enables ENABLE { catchlist } ;) - (enables) *) - [COND - ((EQ PARSE.ATOM 'ENABLE) - (PARSE.BIN) - [COND - ((EQ PARSE.ATOM 'ANY) - (SETQ CATCHANY (PARSE.CATCHANY)) - (SETQ ANSWER (LIST CATCHANY))) - ((FMEMB PARSE.ATOM '(BEGIN {)) - (PARSE.BIN) - (SETQ CATCHLIST (PARSE.CATCHLIST)) - (PARSE.BIN '(END })) - (SETQ ANSWER CATCHLIST)) - (T (SETQ CATCHCASE (PARSE.CATCHCASE)) - (SETQ ANSWER (LIST CATCHCASE] - (PARSE.BIN ';] - (RETURN ANSWER]) - -(PARSE.CATCHLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (CATCHHEAD CATCHANY CATCHCASE ANSWER) (* (catchlist catchhead) - (catchlist catchhead catchcase) - (catchlist catchhead catchany) - (catchlist catchhead catchany ;) *) - (SETQ CATCHHEAD (PARSE.CATCHHEAD)) - [COND - ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW) - (SETQ ANSWER CATCHHEAD)) - [(EQ PARSE.ATOM 'ANY) - (SETQ CATCHANY (PARSE.CATCHANY)) - (SETQ ANSWER (NCONC1 CATCHHEAD CATCHANY)) - (COND - ((EQ PARSE.ATOM ';) - (PARSE.BIN] - (T (SETQ CATCHCASE (PARSE.CATCHCASE)) - (SETQ ANSWER (NCONC1 CATCHHEAD CATCHCASE] - (RETURN ANSWER]) - -(PARSE.CATCHCASE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (LHSLIST STATEMENT ANSWER) (* (catchcase lhslist => statement) *) - (SETQ LHSLIST (PARSE.LHSLIST)) - (PARSE.BIN '=>) - (SETQ STATEMENT (PARSE.STATEMENT)) - (SETQ ANSWER (LIST 'catchcase LHSLIST STATEMENT)) - (RETURN ANSWER]) - -(PARSE.OPTARGS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ANSWER) (* (optargs %[ explist %]) - (optargs) (optargs lhs) *) - [COND - ((EQ PARSE.ATOM '%[) - (PARSE.BIN '%[) - (SETQ ANSWER (PARSE.EXPLIST)) - (PARSE.BIN '%])) - ((NOT (FMEMB PARSE.ATOM PARSE.OPTARGS.FOLLOW)) - (SETQ ANSWER (LIST (PARSE.LHS] - (RETURN ANSWER]) - -(PARSE.TRANSFER - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - - (* (transfer SIGNAL) (transfer ERROR) (transfer RETURN WITH ERROR) - (transfer START) (transfer RESTART) (transfer JOIN) - (transfer NOTIFY) (transfer BROADCAST) (transfer TRANSFER WITH) - (transfer RETURN WITH) *) - - (COND - [(EQ PARSE.ATOM 'RETURN) - (PARSE.BIN) - (PARSE.BIN 'WITH) - (COND - ((EQ PARSE.ATOM 'ERROR) - 'SHOULDNT) - (T 'RETURN] - ((EQ PARSE.ATOM 'TRANSFER) - (PARSE.BIN) - (PARSE.BIN 'WITH) - 'RETURN) - (T (PARSE.BIN]) - -(PARSE.KEYITEM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ID OPTEXP ANSWER) (* BOTH (keyitem id %: optexp) *) - (* CEDAR (keyitem id ~ optexp) *) - (SETQ ID (PARSE.BIN 'ID)) - (COND - ((EQ PARSE.ATOM '%:) - (PARSE.BIN)) - ((AND (EQ PARSE.LANGUAGE 'CEDAR) - (EQ PARSE.ATOM '~)) - (PARSE.BIN)) - (T (SHOULDNT))) - (SETQ OPTEXP (PARSE.OPTEXP)) - (SETQ ANSWER (create KEYITEM - ID _ ID - OPTEXP _ OPTEXP)) - (RETURN ANSWER]) - -(PARSE.OPTEXP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (ANSWER) (* (optexp TRASH) (optexp NULL) - (optexp exp) (optexp) *) - [SETQ ANSWER (COND - ((FMEMB PARSE.ATOM '(NULL TRASH)) - (PARSE.BIN) - 'TRASH) - ((FMEMB PARSE.ATOM PARSE.OPTEXP.FOLLOW) - 'TRASH) - (T (PARSE.EXP] - (RETURN ANSWER]) - -(PARSE.EXP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (COND - ((EQ PARSE.CLASS 'ID) - (PARSE.EXP1)) - (T (PARSE.EXP2]) - -(PARSE.EXP1 - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* First token of EXP is ID. - *) - (PROG (DISJUNCT EXP ANSWER) (* (exp lhs _ exp) (exp disjunct) *) - (SETQ DISJUNCT (PARSE.DISJUNCT)) - (COND - ((EQ PARSE.ATOM '_) - (PARSE.BIN) - (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER (BUILD.SETQ DISJUNCT EXP))) - (T (SETQ ANSWER DISJUNCT))) - (RETURN ANSWER]) - -(PARSE.EXP2 - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* First token of EXP is not ID. - *) - (PROG (DISJUNCT ANSWER) (* (exp transferop lhs) - (exp IF exp THEN exp ELSE exp) - (exp casehead caseexplist ENDCASE => - exp) (exp lhs _ exp) - (exp %[ explist %] _ exp) - (exp ERROR) (exp disjunct) *) - [SETQ ANSWER - (COND - ([AND (FMEMB PARSE.ATOM PARSE.TRANSFEROP.FIRST) - (OR (NOT (EQ PARSE.ATOM 'NEW)) - (NOT (EQ PARSE.ATOM2 '%[] (* Don't confuse with - (primary new %[ typeexp initialization - optcatch %]) *) - (PARSE.EXP.TRANSFEROP)) - ((EQ PARSE.ATOM 'IF) - (PARSE.EXP.IF)) - ((FMEMB PARSE.ATOM PARSE.CASEHEAD.FIRST) - (PARSE.EXP.CASEHEAD)) - ((EQ PARSE.ATOM) - (PARSE.EXP.LBRACKET '%[)) - ((EQ PARSE.ATOM 'ERROR) - (PARSE.EXP.ERROR)) - ((NUMBERP PARSE.ATOM) - (PARSE.EXP.DISJUNCT)) - ((STRINGP PARSE.ATOM) - (PARSE.EXP.DISJUNCT)) - ((FMEMB PARSE.ATOM - '(ABS ALL BASE DESCRIPTOR FIRST ISTYPE LAST LENGTH LONG MAX MIN NILL NOT ORD - PRED SIZE SUCC VAL + - @ %[)) - (PARSE.EXP.DISJUNCT)) - (T (PROGN (SETQ DISJUNCT (PARSE.EXP.DISJUNCT)) - (COND - ((EQ PARSE.ATOM '_) - (PARSE.BIN) - (BUILD.SETQ DISJUNCT (PARSE.EXP))) - (T DISJUNCT] - (RETURN ANSWER]) - -(PARSE.EXP.TRANSFEROP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (TRANSFEROP LHS ANSWER) (* (exp transferop lhs) *) - (SETQ TRANSFEROP (PARSE.TRANSFEROP)) - (SETQ LHS (PARSE.LHS)) - [SETQ ANSWER `(SHOULDNT ',LHS] - (RETURN ANSWER]) - -(PARSE.EXP.IF - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (EXP1 EXP2 EXP3 ANSWER) (* (exp IF exp THEN exp ELSE exp) *) - (PARSE.BIN 'IF) - (SETQ EXP1 (PARSE.EXP)) - (PARSE.BIN 'THEN) - (SETQ EXP2 (PARSE.EXP)) - (PARSE.BIN 'ELSE) - (SETQ EXP3 (PARSE.EXP)) - (SETQ ANSWER (BUILD.COND EXP1 EXP2 EXP3)) - (RETURN ANSWER]) - -(PARSE.EXP.CASEHEAD - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (CASEHEAD CASEEXPLIST EXP ANSWER) (* (exp casehead caseexplist ENDCASE - => exp) *) - (SETQ CASEHEAD (PARSE.CASEHEAD)) - (SETQ CASEEXPLIST (PARSE.CASEEXPLIST)) - (PARSE.BIN 'ENDCASE) - (PARSE.BIN '=>) - (SETQ EXP (PARSE.EXP)) - (SETQ ANSWER (BUILD.SELECTQ CASEHEAD CASEEXPLIST EXP)) - (RETURN ANSWER]) - -(PARSE.EXP.LHS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (LHS EXP ANSWER) (* (exp lhs _ exp) *) - (SETQ LHS (PARSE.LHS)) - (PARSE.BIN '_) - (SETQ EXP (PARSE.EXP)) - [SETQ ANSWER `(SETQ ,LHS ,EXP] - (RETURN ANSWER]) - -(PARSE.EXP.LBRACKET - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (EXPLIST EXP ANSWER) (* (exp %[ explist %] _ exp) *) - (PARSE.BIN '%[) - (SETQ EXPLIST (PARSE.EXPLIST)) - (PARSE.BIN '%]) - (PARSE.BIN '_) - (SETQ EXP (PARSE.EXP)) - [SETQ ANSWER `(SETQ ,EXPLIST ,EXP] - (RETURN ANSWER]) - -(PARSE.EXP.ERROR - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (exp ERROR) *) - (PARSE.BIN 'ERROR) - '(SHOULDNT]) - -(PARSE.EXP.DISJUNCT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (exp disjunct) *) - (PARSE.DISJUNCT]) - -(PARSE.DISJUNCT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (CONJUNCTS ANSWER) (* (disjunct disjunct OR conjunct) - (disjunct conjunct) *) - (push CONJUNCTS (PARSE.CONJUNCT)) - (while (EQ PARSE.ATOM 'OR) do (PARSE.BIN) - (push CONJUNCTS (PARSE.CONJUNCT))) - [SETQ ANSWER (COND - ((CDR CONJUNCTS) - (CONS 'OR (DREVERSE CONJUNCTS))) - (T (CAR CONJUNCTS] - (RETURN ANSWER]) - -(PARSE.CONJUNCT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (NEGATIONS ANSWER) (* (conjunct conjunct AND negation) - (conjunct negation) *) - (push NEGATIONS (PARSE.NEGATION)) - (while (EQ PARSE.ATOM 'AND) do (PARSE.BIN) - (push NEGATIONS (PARSE.NEGATION))) - [SETQ ANSWER (COND - ((CDR NEGATIONS) - (CONS 'AND (DREVERSE NEGATIONS))) - (T (CAR NEGATIONS] - (RETURN ANSWER]) - -(PARSE.NEGATION - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (NOT ANSWER) (* (negation not relation) - (negation relation) *) - [COND - ((FMEMB PARSE.ATOM PARSE.NOTS) - (SETQ NOT (PARSE.NOT] - (SETQ ANSWER (PARSE.RELATION)) - [COND - (NOT (SETQ ANSWER `(NOT ,ANSWER] - (RETURN ANSWER]) - -(PARSE.RELATION - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (SUM OPTRELATION NOT ANSWER) (* (relation sum optrelation) - (relation sum) *) - (SETQ SUM (PARSE.SUM)) - (COND - ((NOT (FMEMB PARSE.ATOM PARSE.OPTRELATION.FIRST)) - (RETURN SUM))) - (SETQ OPTRELATION (PARSE.OPTRELATION)) - [COND - ((EQ (CAR OPTRELATION) - 'NOT) - (SETQ NOT T) - (SETQ OPTRELATION (CADR OPTRELATION] - [SETQ ANSWER (COND - ((EQ (CAR OPTRELATION) - 'IN) - (BUILD.IN SUM (CADR OPTRELATION))) - (T (BUILD.ARITH.EXP2 (CAR OPTRELATION) - SUM - (CADR OPTRELATION] - [COND - (NOT (SETQ ANSWER (LIST 'NOT ANSWER] - (RETURN ANSWER]) - -(PARSE.SUM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (PRODUCTS PRODUCT ANSWER) (* (sum sum addop product) - (sum product) *) - (SETQ PRODUCT (PARSE.PRODUCT)) - [while (FMEMB PARSE.ATOM PARSE.ADDOPS) do (COND - ((EQ PARSE.ATOM '+) - (PARSE.BIN) - (push PRODUCTS PRODUCT) - (SETQ PRODUCT (PARSE.PRODUCT))) - [(EQ PARSE.ATOM '-) - (PARSE.BIN) - (SETQ PRODUCT (BUILD.ARITH.EXP2 '- PRODUCT - (PARSE.PRODUCT] - (T (SHOULDNT] - (push PRODUCTS PRODUCT) - [SETQ ANSWER (COND - ((CDR PRODUCTS) - (BUILD.ARITH.EXP* '+ (DREVERSE PRODUCTS))) - (T (CAR PRODUCTS] - (RETURN ANSWER]) - -(PARSE.PRODUCT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (FACTORS FACTOR ANSWER) (* (product product multop factor) - (product factor) *) - (SETQ FACTOR (PARSE.FACTOR)) - [while (FMEMB PARSE.ATOM PARSE.MULTOPS) do (COND - ((EQ PARSE.ATOM '*) - (PARSE.BIN) - (push FACTORS FACTOR) - (SETQ FACTOR (PARSE.FACTOR))) - [(EQ PARSE.ATOM '/) - (PARSE.BIN) - (SETQ FACTOR (BUILD.ARITH.EXP2 '/ FACTOR - (PARSE.FACTOR] - [(EQ PARSE.ATOM 'MOD) - (PARSE.BIN) - (SETQ FACTOR (BUILD.ARITH.EXP2 'MOD FACTOR - (PARSE.FACTOR] - (T (SHOULDNT] - (push FACTORS FACTOR) - [SETQ ANSWER (COND - ((CDR FACTORS) - (BUILD.ARITH.EXP* '* (DREVERSE FACTORS))) - (T (CAR FACTORS] - (RETURN ANSWER]) - -(PARSE.OPTRELATION - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (NOT ANSWER) (* (optrelation not relationtail) - (optrelation relationtail) *) - (* In CEDAR, not must be NOT. - *) - [COND - ([OR (EQ PARSE.ATOM 'NOT) - (AND (EQ PARSE.LANGUAGE 'MESA) - (EQ PARSE.ATOM '~] - (SETQ NOT (PARSE.NOT] - (SETQ ANSWER (PARSE.RELATIONTAIL)) - [COND - (NOT (SETQ ANSWER (LIST 'NOT ANSWER] - (RETURN ANSWER]) - -(PARSE.RELATIONTAIL - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (PROG (RANGE RELOP SUM ANSWER) (* (relationtail IN range) - (relationtail relop sum) *) - [COND - ((EQ PARSE.ATOM 'IN) - (PARSE.BIN) - (SETQ RANGE (PARSE.RANGE)) - (SETQ ANSWER (LIST 'IN RANGE))) - (T (SETQ RELOP (PARSE.RELOP)) - (SETQ SUM (PARSE.SUM)) - (SETQ ANSWER (LIST RELOP SUM] - (RETURN ANSWER]) - -(PARSE.RELOP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (relop =) (relop %#) - (relop <) (relop <=) - (relop >) (relop >=) *) - (PARSE.BIN]) - -(PARSE.ADDOP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:47") - (* (addop +) (addop -) *) - (PARSE.BIN]) - -(PARSE.MULTOP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (multop *) (multop /) - (multop MOD) *) - (PARSE.BIN]) - -(PARSE.FACTOR - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ADDOP PRIMARY ANSWER) (* (factor addop primary) - (factor primary) *) - [COND - ((FMEMB PARSE.ATOM PARSE.ADDOPS) - (SETQ ADDOP (PARSE.BIN] - (SETQ ANSWER (PARSE.PRIMARY)) - [COND - ((EQ ADDOP '-) - (SETQ ANSWER (BUILD.ARITH.EXP1 '- ANSWER] - (RETURN ANSWER]) - -(PARSE.PRIMARY - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ANSWER LHS) - - (* BOTH (primary num) (primary lnum) (primary flnum) - (primary string) (primary lstring) (primary atom) - (primary NIL) (primary %[ explist %]) (primary prefixop %[ orderlist %]) - (primary VAL %[ orderlist %]) (primary ALL %[ orderlist %]) - (primary new %[ typeexp initialization optcatch %]) - (primary typeop %[ typeexp %]) (primary SIZE %[ typeexp %]) - (primary SIZE %[ typeexp %, exp %]) (primary ISTYPE %[ exp %, typeexp %]) - (primary @ lhs) (primary DESCRIPTOR %[ desclist %]) - (primary lhs) *) - (* CEDAR (primary cons %[ explist - optcatch %]) (primary listcons %[ - explist %]) *) - (* In CEDAR, new can be NEW. - *) - [SETQ ANSWER (COND - ((EQ PARSE.CLASS 'CHAR) - (BUILD.CHARCODE (PARSE.BIN))) - ((NUMBERP PARSE.ATOM) - (PARSE.BIN)) - ((STRINGP PARSE.ATOM) - (PARSE.BIN)) - ((FMEMB PARSE.ATOM PARSE.PREFIXOP.FIRST) - (PARSE.PRIMARY.PREFIXOP)) - ((AND [OR (FMEMB PARSE.ATOM PARSE.TYPEOP.FIRST) - (AND (EQ PARSE.LANGUAGE 'CEDAR) - (EQ PARSE.ATOM 'CODE] - (EQ PARSE.ATOM2 '%[)) - (PARSE.PRIMARY.TYPEOP)) - (T (SELECTQ PARSE.ATOM - ($ (PARSE.ATOM)) - (NILL (PARSE.PRIMARY.NIL)) - (%[ (PARSE.PRIMARY.LBRACKET)) - (VAL (PARSE.PRIMARY.VAL)) - (ALL (PARSE.PRIMARY.ALL)) - (SIZE (PARSE.PRIMARY.SIZE)) - (ISTYPE (PARSE.PRIMARY.ISTYPE)) - (@ (PARSE.PRIMARY.AT)) - (DESCRIPTOR (PARSE.PRIMARY.DESCRIPTOR)) - (NEW (PARSE.PRIMARY.NEW)) - (CONS (PARSE.PRIMARY.CONS)) - (LIST (PARSE.PRIMARY.LIST)) - (PARSE.PRIMARY.LHS] - (RETURN ANSWER]) - -(PARSE.ATOM - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (atom $ id) *) - (PARSE.BIN '$) - `',(PARSE.BIN 'ID]) - -(PARSE.PRIMARY.NIL - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (primary NIL) *) - (PARSE.BIN 'NILL) - NIL]) - -(PARSE.PRIMARY.LBRACKET - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ANSWER) (* (primary %[ explist %]) *) - (PARSE.BIN '%[) - (SETQ ANSWER (PARSE.EXPLIST)) - (PARSE.BIN '%]) - (RETURN ANSWER]) - -(PARSE.PRIMARY.PREFIXOP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (PREFIXOP ORDERLIST ANSWER) (* (primary prefixop %[ orderlist %]) - *) - (SETQ PREFIXOP (PARSE.PREFIXOP)) - (PARSE.BIN '%[) - (SETQ ORDERLIST (PARSE.ORDERLIST)) - (PARSE.BIN '%]) - (SETQ ANSWER (CONS PREFIXOP (fetch (ORDERLIST ITEMS) of ORDERLIST))) - (RETURN ANSWER]) - -(PARSE.PRIMARY.VAL - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ORDERLIST ANSWER) (* (primary VAL %[ orderlist %]) *) - (PARSE.BIN 'VAL) - (PARSE.BIN '%[) - (SETQ ORDERLIST (PARSE.ORDERLIST)) - (PARSE.BIN '%]) - (SETQ ANSWER (CONS 'VAL (fetch (ORDERLIST ITEMS) of ORDERLIST))) - (RETURN ANSWER]) - -(PARSE.PRIMARY.ALL - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ORDERLIST ANSWER) (* (primary ALL %[ orderlist %]) *) - (PARSE.BIN 'ALL) - (PARSE.BIN '%[) - (SETQ ORDERLIST (PARSE.ORDERLIST)) - (PARSE.BIN '%]) - (SETQ ANSWER (CONS 'ALL (fetch (ORDERLIST ITEMS) of ORDERLIST))) - (RETURN ANSWER]) - -(PARSE.PRIMARY.NEW - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (TYPEEXP INITIALIZATION ANSWER) (* (primary new %[ typeexp - initialization optcatch %]) *) - (PARSE.NEW) - (PARSE.BIN '%[) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (SETQ INITIALIZATION (PARSE.INITIALIZATION)) - (PARSE.OPTCATCH) - (PARSE.BIN '%]) - (SETQ ANSWER (BUILD.NEW TYPEEXP INITIALIZATION)) - (RETURN ANSWER]) - -(PARSE.PRIMARY.TYPEOP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (TYPEOP TYPEEXP ANSWER) (* (primary typeop %[ typeexp %]) *) - (SETQ TYPEOP (PARSE.TYPEOP)) - (PARSE.BIN '%[) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (PARSE.BIN '%]) - (SETQ ANSWER (LIST TYPEOP TYPEEXP)) - (RETURN ANSWER]) - -(PARSE.PRIMARY.SIZE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (TYPEEXP EXP ANSWER) (* (primary SIZE %[ typeexp %]) - (primary SIZE %[ typeexp %, exp %]) *) - (PARSE.BIN 'SIZE) - (PARSE.BIN '%[) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - [COND - ((NOT (EQ PARSE.ATOM '%,)) - (PARSE.BIN '%]) - (SETQ ANSWER (LIST 'SIZE TYPEEXP))) - (T (PARSE.BIN) - (SETQ EXP (PARSE.EXP)) - (PARSE.BIN '%]) - (SETQ ANSWER (LIST 'SIZE TYPEEXP EXP] - (RETURN ANSWER]) - -(PARSE.PRIMARY.ISTYPE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (primary ISTYPE %[ exp %, typeexp - %]) *) - (PROG (EXP TYPEEXP ANSWER) - (PARSE.BIN 'ISTYPE) - (PARSE.BIN '%[) - (SETQ EXP (PARSE.EXP)) - (PARSE.BIN '%,) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (PARSE.BIN '%]) - (SETQ ANSWER (BUILD.ISTYPE EXP TYPEEXP)) - (RETURN ANSWER]) - -(PARSE.PRIMARY.AT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (LHS ANSWER) (* (primary @ lhs) *) - (PARSE.BIN '@) - (SETQ LHS (PARSE.LHS)) - (SETQ ANSWER LHS) - (RETURN ANSWER]) - -(PARSE.PRIMARY.DESCRIPTOR - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (DESCLIST ANSWER) (* (primary DESCRIPTOR %[ desclist %]) - *) - (PARSE.BIN 'DESCRIPTOR) - (PARSE.BIN '%[) - (SETQ DESCLIST (PARSE.DESCLIST)) - (PARSE.BIN '%]) - (SETQ ANSWER (CONS 'DESCRIPTOR DESCLIST)) - (RETURN ANSWER]) - -(PARSE.PRIMARY.CONS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (EXPLIST ANSWER) (* CEDAR (primary CONS %[ explist - optcatch %]) *) - (PARSE.THISIS.CEDAR) - (PARSE.BIN 'CONS) - (PARSE.BIN '%[) - (SETQ EXPLIST (PARSE.EXPLIST)) - (PARSE.OPTCATCH) - (PARSE.BIN '%]) - (SETQ ANSWER (CONS 'CONS (fetch (EXPLIST ITEMS) of EXPLIST))) - (RETURN ANSWER]) - -(PARSE.PRIMARY.LIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (EXPLIST ANSWER) (* CEDAR (primary LIST %[ explist %]) - *) - (PARSE.THISIS.CEDAR) - (PARSE.BIN 'LIST) - (PARSE.BIN '%[) - (SETQ EXPLIST (PARSE.EXPLIST)) - (PARSE.BIN '%]) - (SETQ ANSWER (CONS 'LIST (fetch (EXPLIST ITEMS) of EXPLIST))) - (RETURN ANSWER]) - -(PARSE.PRIMARY.LHS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (LHS QUALIFIER ANSWER) (* BOTH (primary lhs) - (primary new %[ typeexp initialization - optcatch %]) *) - (* CEDAR (primary cons %[ explist - optcatch %]) (primary listcons %[ - explist %]) *) - (SETQ LHS (PARSE.LHS)) - (COND - ([NOT (AND (EQ PARSE.ATOM '%.) - (OR (EQ PARSE.ATOM2 'NEW) - (AND (EQ PARSE.LANGUAGE 'CEDAR) - (FMEMB PARSE.ATOM2 '(CONS LIST] - (RETURN LHS))) - (PARSE.BIN '%.) - (SETQ ANSWER (SELECTQ PARSE.ATOM - (NEW (PARSE.PRIMARY.LHS.NEW LHS)) - (CONS (PARSE.PRIMARY.LHS.CONS LHS)) - (LIST (PARSE.PRIMARY.LHS.LIST LHS)) - (SHOULDNT))) - (RETURN ANSWER]) - -(PARSE.PRIMARY.LHS.NEW - [LAMBDA (LHS) (* kbr%: "25-Nov-85 12:48") - (PROG (TYPEEXP INITIALIZATION ANSWER) (* (primary new %[ typeexp - initialization optcatch %]) *) - (PARSE.BIN 'NEW) - (PARSE.BIN '%[) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (SETQ INITIALIZATION (PARSE.INITIALIZATION)) - (PARSE.OPTCATCH) - (PARSE.BIN '%]) - (SETQ ANSWER (LIST 'create LHS TYPEEXP INITIALIZATION)) - (RETURN ANSWER]) - -(PARSE.PRIMARY.LHS.CONS - [LAMBDA (LHS) (* kbr%: "25-Nov-85 12:48") - (PROG (EXPLIST OPTCATCH ANSWER) (* CEDAR (primary cons %[ explist - optcatch %]) *) - (PARSE.BIN 'CONS) - (PARSE.BIN '%[) - (SETQ EXPLIST (PARSE.EXPLIST)) - (PARSE.OPTCATCH) - (PARSE.BIN '%]) - [SETQ ANSWER `(CONS ,LHS ,@EXPLIST] - (RETURN ANSWER]) - -(PARSE.PRIMARY.LHS.LIST - [LAMBDA (LHS) (* kbr%: "25-Nov-85 12:48") - (PROG (EXPLIST OPTCATCH ANSWER) (* CEDAR (primary listcons %[ explist - %]) *) - (PARSE.BIN 'LIST) - (PARSE.BIN '%[) - (SETQ EXPLIST (PARSE.EXPLIST)) - (PARSE.BIN '%]) - [SETQ ANSWER `(LIST ,LHS ,@EXPLIST] - (RETURN ANSWER]) - -(PARSE.QUALIFIER - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ANSWER) (* (qualifier %. prefixop) - (qualifier %. typeop) - (qualifier %. SIZE) (qualifier %[ - explist optcatch %]) - (qualifier %. id) (qualifier ^) *) - [COND - [(EQ PARSE.ATOM '%.) - (PARSE.BIN) - (COND - ((FMEMB PARSE.ATOM PARSE.PREFIXOPS) - (SETQ ANSWER (PARSE.PREFIXOP))) - ([OR (FMEMB PARSE.ATOM PARSE.TYPEOPS) - (AND (EQ PARSE.LANGUAGE 'CEDAR) - (EQ PARSE.ATOM 'CODE] - (SETQ ANSWER (PARSE.TYPEOP))) - ((EQ PARSE.ATOM 'SIZE) - (SETQ ANSWER (PARSE.BIN))) - ((EQ PARSE.ATOM 'FREE) (* (free lhs %. FREE) *) - (SETQ ANSWER (PARSE.BIN))) - ((EQ PARSE.ATOM 'NEW) (* (new lhs %. NEW) *) - (SETQ ANSWER (PARSE.BIN))) - ([AND (EQ PARSE.LANGUAGE 'CEDAR) - (FMEMB PARSE.ATOM '(LIST CONS] - (SETQ ANSWER (PARSE.BIN))) - (T (SETQ ANSWER (PARSE.BIN 'ID] - ((EQ PARSE.ATOM '%[) - (PARSE.BIN) - (SETQ ANSWER (PARSE.EXPLIST)) - (PARSE.OPTCATCH) - (PARSE.BIN '%])) - (T (SETQ ANSWER (PARSE.BIN '^] - (RETURN ANSWER]) - -(PARSE.LHS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (EXP1 EXP2 OPTTYPE ANSWER) (* (lhs id) (lhs char) - (lhs NARROW %[ exp opttype optcatch %]) - (lhs LOOPHOLE %[ exp opttype %]) - (lhs APPLY %[ exp %, exp optcatch %]) - (lhs %( exp %)) (lhs lhs qualifier) *) - [COND - ((EQ PARSE.ATOM 'TRUE) - (PARSE.BIN) - (SETQ ANSWER T)) - ((EQ PARSE.ATOM 'FALSE) - (PARSE.BIN)) - ((EQ PARSE.ATOM 'NARROW) - (PARSE.BIN) - (PARSE.BIN '%[) - (SETQ EXP1 (PARSE.EXP)) - (SETQ OPTTYPE (PARSE.OPTTYPE)) - (PARSE.OPTCATCH) - (PARSE.BIN '%]) - (SETQ ANSWER (BUILD.COERCE EXP1 OPTTYPE))) - ((EQ PARSE.ATOM 'LOOPHOLE) - (PARSE.BIN) - (PARSE.BIN '%[) - (SETQ EXP1 (PARSE.EXP)) - (SETQ OPTTYPE (PARSE.OPTTYPE)) - (PARSE.BIN '%]) - (SETQ ANSWER (BUILD.COERCE EXP1 OPTTYPE))) - ((EQ PARSE.ATOM 'APPLY) - (PARSE.BIN) - (PARSE.BIN '%[) - (SETQ EXP1 (PARSE.EXP)) - (PARSE.BIN '%,) - (SETQ EXP2 (PARSE.EXP)) - (PARSE.OPTCATCH) - (PARSE.BIN '%]) - (SETQ ANSWER (LIST 'APPLY EXP1 EXP2))) - ((EQ PARSE.ATOM '%() - (PARSE.BIN) - (SETQ EXP1 (PARSE.EXP)) - (PARSE.BIN '%)) - (SETQ ANSWER EXP1)) - ((EQ PARSE.CLASS 'ID) - (SETQ ANSWER (PARSE.BIN))) - ((EQ PARSE.CLASS 'CHAR) - (SETQ ANSWER (BUILD.CHARCODE (PARSE.BIN] - [while (PARSE.QUALIFIER.HERE) do (SETQ ANSWER (BUILD.QUALIFY ANSWER (PARSE.QUALIFIER] - (RETURN ANSWER]) - -(PARSE.QUALIFIER.HERE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (AND (FMEMB PARSE.ATOM PARSE.QUALIFIER.FIRST) - (NOT (AND (EQ PARSE.ATOM '%.) - (OR (FMEMB PARSE.ATOM2 '(FREE NEW)) - (AND (EQ PARSE.LANGUAGE 'CEDAR) - (FMEMB PARSE.ATOM2 '(CONS LIST]) - -(PARSE.OPTCATCH - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (CATCHLIST ANSWER) (* (optcatch ! catchlist) - (optcatch) *) - [COND - ((EQ PARSE.ATOM '!) - (PARSE.BIN) - (SETQ ANSWER (PARSE.CATCHLIST] - (RETURN ANSWER]) - -(PARSE.TRANSFEROP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (transferop SIGNAL) - (transferop ERROR) (transferop START) - (transferop JOIN) (transferop NEW) - (transferop FORK) *) - (PARSE.BIN]) - -(PARSE.PREFIXOP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - - (* (prefixop LONG) (prefixop ABS) (prefixop PRED) - (prefixop SUCC) (prefixop ORD) (prefixop MIN) - (prefixop MAX) (prefixop BASE) (prefixop LENGTH) *) - - (PARSE.BIN]) - -(PARSE.TYPEOP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* BOTH (typeop FIRST) - (typeop LAST) (typeop NIL) *) - (* CEDAR (typeop CODE) *) - (COND - ((EQ PARSE.ATOM 'CODE) - (PARSE.THISIS.CEDAR))) - (PARSE.BIN]) - -(PARSE.DESCLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (EXP1 EXP2 OPTTYPE ANSWER) (* (desclist exp %, exp opttype) - (desclist exp) *) - (SETQ EXP1 (PARSE.EXP)) - [COND - ((EQ PARSE.ATOM '%,) - (PARSE.BIN) - (SETQ EXP2 (PARSE.EXP)) - (SETQ OPTTYPE (PARSE.OPTTYPE)) - (SETQ ANSWER (LIST 'desclist EXP1 EXP2 OPTTYPE)) - (RETURN ANSWER)) - (T (SETQ ANSWER (LIST 'desclist EXP1] - (RETURN ANSWER]) - -(PARSE.DIRECTORY - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG NIL (* (directory DIRECTORY ;) - (directory DIRECTORY includelist ;) - (directory) *) - (COND - ((EQ PARSE.ATOM 'DIRECTORY) - (PARSE.BIN) - (COND - ((EQ PARSE.ATOM ';)) - (T (PARSE.INCLUDELIST) - (PARSE.BIN ';]) - -(PARSE.IMPORTS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG NIL (* (imports IMPORTS) - (imports IMPORTS modulelist) - (imports) *) - (COND - ((EQ PARSE.ATOM 'IMPORTS) - (PARSE.BIN) - (PARSE.MODULELIST]) - -(PARSE.POINTERPREFIX - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ANSWER) (* (pointerprefix POINTER) - (pointerprefix POINTER interval) *) - (PARSE.BIN 'POINTER) - [COND - ((FMEMB PARSE.ATOM PARSE.INTERVAL.FIRST) - (SETQ ANSWER (LIST 'POINTER (PARSE.INTERVAL] - (RETURN ANSWER]) - -(PARSE.EXPORTS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (MODULELIST ANSWER) (* (exports EXPORTS) - (exports EXPORTS modulelist) - (exports) *) - (COND - ((EQ PARSE.ATOM 'EXPORTS) - (PARSE.BIN) - (BUILD.STORE.EXPORTS (PARSE.MODULELIST]) - -(PARSE.FIELDLIST - [LAMBDA (KIND) (* kbr%: "25-Nov-85 12:48") - (PROG (ANSWER) (* (fieldlist %[ %]) - (fieldlist %[ pairlist %]) - (fieldlist %[ typelist %]) *) - (PARSE.BIN '%[) - [COND - ((NOT (EQ PARSE.ATOM '%])) - (COND - [[AND (EQ PARSE.CLASS 'ID) - (NOT (FMEMB PARSE.ATOM PARSE.PREDEFINED.TYPES)) - (FMEMB PARSE.ATOM2 '(%( %, %:] - (SETQ ANSWER (PARSE.PAIRLIST 'FIELDLIST] - (T (SETQ ANSWER (PARSE.TYPELIST] - (PARSE.BIN '%]) - (RETURN ANSWER]) - -(PARSE.USING - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (IDLIST) (* (using USING %[ %]) - (using USING %[ idlist %]) - (using) *) - [COND - ((EQ PARSE.ATOM 'USING) - (PARSE.BIN) - (PARSE.BIN '%[) - (COND - ((EQ PARSE.ATOM '%]) - (PARSE.BIN)) - (T (SETQ IDLIST (PARSE.IDLIST)) - (PARSE.BIN '%]] - (RETURN IDLIST]) - -(PARSE.CATCHHEAD - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (CATCHCASES ANSWER) (* (catchhead) (catchhead catchhead - catchcase ;) *) - (COND - ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW) - (RETURN))) - (push CATCHCASES (PARSE.CATCHCASE)) - (while (EQ PARSE.ATOM ';) do (PARSE.BIN) - (COND - ((FMEMB PARSE.ATOM PARSE.CATCHLIST.FOLLOW) - (RETURN))) - (push CATCHCASES (PARSE.CATCHCASE))) - (SETQ ANSWER (DREVERSE CATCHCASES)) - (RETURN ANSWER]) - -(PARSE.DECLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (VARLIST) (* (declist declaration) - (declist declist ; declaration) *) - (SETQ VARLIST (PARSE.DECLARATION)) - [do (COND - ((EQ PARSE.ATOM ';) - (PARSE.BIN)) - ((FMEMB PARSE.ATOM PARSE.DECLIST.FOLLOW) - (RETURN)) - (T (SHOULDNT "PARSE.DECLIST"))) - (COND - ([NOT (AND (EQ PARSE.CLASS 'ID) - (FMEMB PARSE.ATOM2 '(%, %:] - (RETURN))) - (SETQ VARLIST (NCONC VARLIST (PARSE.DECLARATION] - (BUILD.STORE.VARLIST VARLIST]) - -(PARSE.PAIRLIST - [LAMBDA (KIND) (* kbr%: "25-Nov-85 12:48") - (PROG (PAIRITEMS ANSWER) (* (pairlist pairitem) - (pairlist pairlist %, pairitem) *) - (* PARSE.PAIRITEM returns a list of - PAIRITEM records. *) - (SETQ PAIRITEMS (PARSE.PAIRITEM KIND)) - (COND - ((type? TYPELIST PAIRITEMS) - - (* Thought we we're parsing a pairlist, but found a typelist. - *) - - (RETURN PAIRITEMS))) - [while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (SETQ PAIRITEMS (NCONC PAIRITEMS (PARSE.PAIRITEM KIND] - (SETQ ANSWER (create PAIRLIST - ITEMS _ PAIRITEMS)) - (RETURN ANSWER]) - -(PARSE.VARIANTLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (VARIANTITEMS ANSWER) (* (variantlist variantitem) - (variantlist variantlist %, - variantitem) *) - (push VARIANTITEMS (PARSE.VARIANTITEM)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push VARIANTITEMS (PARSE.VARIANTITEM))) - (SETQ ANSWER (CONS 'variantlist (DREVERSE VARIANTITEMS))) - (RETURN ANSWER]) - -(PARSE.ORDERLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (OPTEXPS ANSWER) (* (orderlist optexp) - (orderlist orderlist %, optexp) *) - (COND - ((FMEMB PARSE.ATOM PARSE.ORDERLIST.FOLLOW) - (RETURN))) - (push OPTEXPS (PARSE.OPTEXP)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push OPTEXPS (PARSE.OPTEXP))) - (SETQ ANSWER (create ORDERLIST - ITEMS _ (DREVERSE OPTEXPS))) - (RETURN ANSWER]) - -(PARSE.LHSLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (LHSS ANSWER) (* (lhslist lhs) (lhslist lhslist %, - lhs) *) - (push LHSS (PARSE.LHS)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push LHSS (PARSE.LHS))) - (SETQ ANSWER (DREVERSE LHSS)) - (RETURN ANSWER]) - -(PARSE.INCLUDELIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG NIL (* (includelist includeitem) - (includelist includelist %, - includeitem) *) - (PARSE.INCLUDEITEM) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (PARSE.INCLUDEITEM]) - -(PARSE.MODULELIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (MODULEITEMS ANSWER) (* (modulelist moduleitem) - (modulelist modulelist %, moduleitem) - *) - (COND - ((FMEMB PARSE.ATOM PARSE.MODULELIST.FOLLOW) - (RETURN NIL))) - (push MODULEITEMS (PARSE.MODULEITEM)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push MODULEITEMS (PARSE.MODULEITEM))) - (SETQ ANSWER (DREVERSE MODULEITEMS)) - (RETURN ANSWER]) - -(PARSE.ELEMENTLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ELEMENTS ANSWER) (* (elementlist element) - (elementlist elementlist %, element) *) - (push ELEMENTS (PARSE.ELEMENT)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push ELEMENTS (PARSE.ELEMENT))) - (SETQ ANSWER (DREVERSE ELEMENTS)) - (RETURN ANSWER]) - -(PARSE.BINDLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (BINDITEMS ANSWER) (* (bindlist binditem) - (bindlist bindlist %, binditem) *) - (push BINDITEMS (PARSE.BINDITEM)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push BINDITEMS (PARSE.BINDITEM))) - (SETQ ANSWER (DREVERSE BINDITEMS)) - (RETURN ANSWER]) - -(PARSE.STATEMENTLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (STATEMENTS ANSWER) (* (statementlist statement) - (statementlist statementlist ; - statement) *) - (COND - ((FMEMB PARSE.ATOM PARSE.STATEMENTLIST.FOLLOW) - (RETURN))) - (push STATEMENTS (PARSE.STATEMENT)) - (do (COND - ((EQ PARSE.ATOM ';) - (PARSE.BIN))) - (COND - ((FMEMB PARSE.ATOM PARSE.STATEMENTLIST.FOLLOW) - (RETURN))) - (push STATEMENTS (PARSE.STATEMENT))) - (SETQ ANSWER (DREVERSE STATEMENTS)) - (RETURN ANSWER]) - -(PARSE.CASESTMTLIST - [LAMBDA (CASEHEAD) (* kbr%: "25-Nov-85 12:48") - (PROG (CASESTMTITEMS ANSWER) (* (casestmtlist casestmtitem) - (casestmtlist casestmtlist ; - casestmtitem) *) - (push CASESTMTITEMS (PARSE.CASESTMTITEM CASEHEAD)) - (do (COND - ((EQ PARSE.ATOM ';) - (PARSE.BIN))) - (COND - ((EQ PARSE.ATOM 'ENDCASE) - (RETURN))) - (push CASESTMTITEMS (PARSE.CASESTMTITEM CASEHEAD))) - (SETQ ANSWER (DREVERSE CASESTMTITEMS)) - (RETURN ANSWER]) - -(PARSE.CASELABEL - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (CASETESTS IDENT TYPEEXP ANSWER) (* (caselabel ident typeexp) - (caselabel caselabel') - (caselabel' casetest) - (caselabel' caselabel' %, casetest) *) - (COND - ([AND (EQ PARSE.CLASS 'ID) - (FMEMB PARSE.ATOM2 '(%: %(] - (SETQ IDENT (PARSE.IDENT)) - (SETQ TYPEEXP (PARSE.TYPEEXP)) - (SETQ ANSWER (LIST (BUILD.ISTYPE IDENT TYPEEXP))) - (BUILD.INITIALIZE.VAR IDENT TYPEEXP NIL BUILD.CURRENT.SCOPE) - (RETURN ANSWER))) - (push CASETESTS (PARSE.CASETEST)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push CASETESTS (PARSE.CASETEST))) - (SETQ ANSWER (DREVERSE CASETESTS)) - (RETURN ANSWER]) - -(PARSE.EXITLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (EXITITEMS ANSWER) (* (exitlist exititem) - (exitlist exitlist ; - exititem) *) - (COND - ((FMEMB PARSE.ATOM PARSE.EXITLIST.FOLLOW) - (RETURN))) - (push EXITITEMS (PARSE.EXITITEM)) - (do (COND - ((EQ PARSE.ATOM ';) - (PARSE.BIN))) - (COND - ((FMEMB PARSE.ATOM PARSE.EXITLIST.FOLLOW) - (RETURN))) - (push EXITITEMS (PARSE.EXITITEM))) - (SETQ ANSWER (DREVERSE EXITITEMS)) - (RETURN ANSWER]) - -(PARSE.KEYLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (KEYITEMS ANSWER) (* (keylist keyitem) - (keylist keylist %, keyitem) *) - (push KEYITEMS (PARSE.KEYITEM)) - (while (EQ PARSE.ATOM '%,) do (PARSE.BIN) - (push KEYITEMS (PARSE.KEYITEM))) - (SETQ ANSWER (create KEYLIST - ITEMS _ (DREVERSE KEYITEMS))) - (RETURN ANSWER]) - -(PARSE.CASEEXPLIST - [LAMBDA (CASEHEAD) (* kbr%: "25-Nov-85 12:48") - (PROG (CASEEXPITEMS ANSWER) (* (caseexplist caseexpitem) - (caseexplist caseexplist %, - caseexpitem) *) - (push CASEEXPITEMS (PARSE.CASEEXPITEM CASEHEAD)) - (do (COND - ((EQ PARSE.ATOM '%,) - (PARSE.BIN))) - (COND - ((EQ PARSE.ATOM 'ENDCASE) - (RETURN))) - (push CASEEXPITEMS (PARSE.CASEEXPITEM CASEHEAD))) - (SETQ ANSWER (DREVERSE CASEEXPITEMS)) - (RETURN ANSWER]) - -(PARSE.EXPLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (explist orderlist) - (explist keylist) *) - (PROG (ORDERLIST KEYLIST ANSWER) - [COND - ((AND (EQ PARSE.CLASS 'ID) - (EQ PARSE.ATOM2 '%:)) - (SETQ ANSWER (PARSE.KEYLIST))) - (T (SETQ ANSWER (PARSE.ORDERLIST] - (RETURN ANSWER]) - -(PARSE.OPEN - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (BINDLIST) (* (open OPEN bindlist ;) - (open) *) - [COND - ((EQ PARSE.ATOM 'OPEN) - (PARSE.BIN) - (SETQ BINDLIST (PARSE.BINDLIST)) - (PARSE.BIN ';] - (RETURN BINDLIST]) - -(PARSE.CLASS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (class PROGRAM) (class MONITOR) *) - (PARSE.BIN '(MONITOR PROGRAM]) - -(PARSE.CASEHEAD - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (ID EXP OPTEXP BINDITEM OPTEXP ANSWER) (* (casehead SELECT exp FROM) - (casehead WITH binditem SELECT optexp - FROM) *) - [COND - ((EQ PARSE.ATOM 'SELECT) - (PARSE.BIN) - (SETQ EXP (PARSE.EXP)) - (PARSE.BIN 'FROM)) - (T (PARSE.BIN 'WITH) - (SETQ BINDITEM (PARSE.BINDITEM)) - (SETQ ID (fetch (BINDITEM ID) of BINDITEM)) - (SETQ EXP (fetch (BINDITEM EXP) of BINDITEM)) - (PARSE.BIN 'SELECT) - (SETQ OPTEXP (PARSE.OPTEXP)) - (PARSE.BIN 'FROM] - (SETQ ANSWER (create CASEHEAD - ID _ ID - EXP _ EXP - OPTEXP _ OPTEXP)) - (RETURN ANSWER]) - -(PARSE.READONLY - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (readonly READONLY) - (readonly) *) - (COND - ((EQ PARSE.ATOM 'READONLY) - (PARSE.BIN]) - -(PARSE.ORDERED - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (ordered ORDERED) - (ordered) *) - (COND - ((EQ PARSE.ATOM 'ORDERED) - (PARSE.BIN]) - -(PARSE.BASE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (base BASE) (base) *) - (COND - ((EQ PARSE.ATOM 'BASE) - (PARSE.BIN]) - -(PARSE.PACKED - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (packed PACKED) (packed) *) - (COND - ((EQ PARSE.ATOM 'PACKED) - (PARSE.BIN]) - -(PARSE.HEAP - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* BOTH (heap UNCOUNTED) *) - (* CEDAR (heap) *) - (COND - ((EQ PARSE.ATOM 'UNCOUNTED) - (PARSE.BIN)) - (T (PARSE.THISIS.CEDAR]) - -(PARSE.INLINE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (inline INLINE) (inline) *) - (COND - ((EQ PARSE.ATOM 'INLINE) - (PARSE.BIN]) - -(PARSE.ARGUMENTS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG NIL (* (arguments arglist returnlist) *) - (PARSE.ARGLIST) - (PARSE.RETURNLIST]) - -(PARSE.INTERFACE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG NIL (* (interface imports exports shares) - *) - (PARSE.IMPORTS) - (PARSE.EXPORTS) - (PARSE.SHARES]) - -(PARSE.SHARES - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (shares SHARES idlist) - (shares) *) - (COND - ((EQ PARSE.ATOM 'SHARES) - (CONS (PARSE.BIN) - (PARSE.IDLIST]) - -(PARSE.DEFAULT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (default _ defaultopt) - (default) *) - (COND - ((EQ PARSE.ATOM '_) - (PARSE.BIN) - (PARSE.DEFAULTOPT]) - -(PARSE.OPTSIZE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (EXP ANSWER) (* (optsize %[ exp %]) - (optsize) *) - (COND - ((EQ PARSE.ATOM '%[) - (PARSE.BIN) - (SETQ EXP (PARSE.EXP)) - (PARSE.BIN '%]) - (SETQ ANSWER EXP))) - (RETURN ANSWER]) - -(PARSE.BOUNDS - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (EXP1 EXP2 ANSWER) (* (bounds exp |..| exp) *) - (SETQ EXP1 (PARSE.EXP)) - (PARSE.BIN '|..|) - (SETQ EXP2 (PARSE.EXP)) - (SETQ ANSWER (LIST EXP1 EXP2)) - (RETURN ANSWER]) - -(PARSE.LENGTH - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (EXP ANSWER) (* (length %[ exp %]) *) - (PARSE.BIN '%[) - (SETQ EXP (PARSE.EXP)) - (PARSE.BIN '%]) - (SETQ ANSWER EXP) - (RETURN ANSWER]) - -(PARSE.INDEXTYPE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (indextype typeexp) - (indextype) *) - (COND - ((NOT (EQ PARSE.ATOM 'OF)) - (PARSE.TYPEEXP]) - -(PARSE.ELSEPART - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (elsepart ELSE statement) - (elsepart) *) - (COND - ((EQ PARSE.ATOM 'ELSE) - (PARSE.BIN) - (PARSE.STATEMENT]) - -(PARSE.OTHERPART - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (otherpart => statement) - (otherpart) *) - (COND - ((EQ PARSE.ATOM '=>) - (PARSE.BIN) - (PARSE.STATEMENT]) - -(PARSE.FREE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (LHS ANSWER) (* (free lhs %. FREE) *) - (SETQ LHS (PARSE.LHS)) - (PARSE.BIN '%.) - (PARSE.BIN 'FREE) - (SETQ ANSWER (LIST 'FREE LHS)) - (RETURN ANSWER]) - -(PARSE.CATCHANY - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG (STATEMENT ANSWER) (* (catchany ANY => statement) *) - (PARSE.BIN 'ANY) - (PARSE.BIN '=>) - (SETQ STATEMENT (PARSE.STATEMENT)) - (SETQ ANSWER (LIST 'ANY STATEMENT)) - (RETURN ANSWER]) - -(PARSE.NOT - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (not ~) (not NOT) *) - (PARSE.BIN]) - -(PARSE.NEW - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (PROG NIL (* BOTH (new lhs %. NEW) *) - (* CEDAR (new NEW) *) - (COND - ((AND (EQ PARSE.ATOM 'NEW) - (EQ PARSE.LANGUAGE 'CEDAR)) - (PARSE.BIN)) - (T - - (* Throw away lhs. Interlisp doesn't have separate storage "zone" - (QUOTE s.) *) - - (PARSE.LHS) - (PARSE.BIN '%.) - (PARSE.BIN 'NEW]) - -(PARSE.OPTTYPE - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* (opttype %, typeexp) - (opttype) *) - (COND - ((EQ PARSE.ATOM '%,) - (PARSE.BIN) - (PARSE.TYPEEXP)) - (T 'ANY]) - -(PARSE.ARGLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* BOTH (arglist fieldlist) - (arglist) *) - (* CEDAR (arglist ANY) *) - (PROG (ARGLIST) - [SETQ ARGLIST (COND - ((EQ PARSE.ATOM '%[) - (COND - ((EQ PARSE.ATOM 'ANY) - (PARSE.THISIS.CEDAR) - (PARSE.BIN)) - (T (PARSE.FIELDLIST 'ARGLIST] - (BUILD.STORE.ARGLIST ARGLIST]) - -(PARSE.RETURNLIST - [LAMBDA NIL (* kbr%: "25-Nov-85 12:48") - (* BOTH (returnlist RETURNS fieldlist) - (returnlist) *) - (* CEDAR (returnlist RETURNS ANY) *) - (PROG (RETURNLIST) - [SETQ RETURNLIST (COND - ((EQ PARSE.ATOM 'RETURNS) - (PARSE.BIN) - (COND - ((EQ PARSE.ATOM 'ANY) - (PARSE.THISIS.CEDAR) - (PARSE.BIN)) - (T (PARSE.FIELDLIST 'RETURNLIST] - (BUILD.STORE.RETURNLIST RETURNLIST]) -) - - - -(* ;; "BUILD ") - - -(RPAQ? BUILD.NEXT.SCOPE NIL) - -(RPAQ? BUILD.CURRENT.SCOPE NIL) - -(RPAQ? BUILD.SCOPE.STACK NIL) - -(RPAQ? BUILD.PREFIX NIL) - -(RPAQ? BUILD.FILECOMS NIL) - -(RPAQ? BUILD.BOOLEAN.FNS - '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP MINUSP EVENP ODDP FGREATERP FLESSP - FEQP GREATERP LESSP GEQ LEQ)) - -(RPAQ? BUILD.CARDINAL.FNS - '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD IPLUS IQUOTIENT IREMAINDER ITIMES - LOGAND LOGNOT LOGOR LOGXOR NTHCHARCODE SUB1)) - -(RPAQ? BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER TIMES)) - -(RPAQ? BUILD.REAL.FNS - '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT FMAX FMIN FMINUS FMOD FPLUS - FQUOTIENT FREMAINDER FTIMES LOG SIN SQRT TAN)) - -(RPAQ? BUILD.QUALIFY.WORDS '(FREE NEW SIZE)) - -(RPAQ? BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP) - (CONS '%# 'IEQP) - (CONS '< 'ILESSP) - (CONS '<= 'ILEQ) - (CONS '> 'IGREATERP) - (CONS '>= 'IGEQ) - (CONS '+ 'IPLUS) - (CONS '- 'IDIFFERENCE) - (CONS '* 'ITIMES) - (CONS '/ 'IQUOTIENT) - (CONS '0- 'IMINUS) - (CONS 'MAX 'IMAX) - (CONS 'MIN 'IMIN) - (CONS 'MOD 'IMOD))) - -(RPAQ? BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP) - (CONS '%# 'EQP) - (CONS '< 'LESSP) - (CONS '<= 'GREATERP) - (CONS '> 'GREATERP) - (CONS '>= 'LESSP) - (CONS '+ 'PLUS) - (CONS '- 'DIFFERENCE) - (CONS '* 'TIMES) - (CONS '/ 'QUOTIENT) - (CONS '0- 'MINUS) - (CONS 'MAX 'MAX) - (CONS 'MIN 'MIN) - (CONS 'MOD 'IMOD))) - -(RPAQ? BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP) - (CONS '%# 'FEQP) - (CONS '< 'FLESSP) - (CONS '<= 'FGREATERP) - (CONS '> 'FGREATERP) - (CONS '>= 'FLESSP) - (CONS '+ 'FPLUS) - (CONS '- 'FDIFFERENCE) - (CONS '* 'FTIMES) - (CONS '/ 'FQUOTIENT) - (CONS '0- 'FMINUS) - (CONS 'MAX 'FMAX) - (CONS 'MIN 'FMIN) - (CONS 'MOD 'IMOD))) - -(RPAQ? BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD)) -(DECLARE%: EVAL@COMPILE - -(RECORD SCOPE (ID SYMBOLTABLE INITLIST ARGLIST VARLIST RETURNLIST RETURNS OPEN) - [ACCESSFNS ((RETURNVARS (FOR PAIRITEM IN (fetch (PAIRLIST ITEMS) - of (fetch (SCOPE RETURNLIST) of DATUM)) - collect (BUILD.LOCALVARID NIL (fetch (PAIRITEM ID) - of PAIRITEM]) -) -(DEFINEQ - -(BUILD.INIT - [LAMBDA (PREFIX) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (SETQ BUILD.PREFIX PREFIX) - (SETQ BUILD.FILECOMS (FILECOMS (U-CASE PREFIX))) - (SETTOPVAL BUILD.FILECOMS NIL) - (printout T "Creating " BUILD.FILECOMS T) - (SETQ BUILD.NEXT.SCOPE (create SCOPE - ID _ 'MODULE)) - (SETQ BUILD.CURRENT.SCOPE NIL) - (SETQ BUILD.SCOPE.STACK NIL]) - -(BUILD.PUSH.SCOPE - [LAMBDA NIL (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (COND - (BUILD.CURRENT.SCOPE (push BUILD.SCOPE.STACK BUILD.CURRENT.SCOPE))) - (SETQ BUILD.CURRENT.SCOPE BUILD.NEXT.SCOPE) - (SETQ BUILD.NEXT.SCOPE (create SCOPE)) - (RETURN (CAR BUILD.SCOPE.STACK]) - -(BUILD.POP.SCOPE - [LAMBDA NIL (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (SETQ BUILD.NEXT.SCOPE BUILD.CURRENT.SCOPE) - (SETQ BUILD.CURRENT.SCOPE (pop BUILD.SCOPE.STACK)) - (RETURN BUILD.CURRENT.SCOPE]) - -(BUILD.GC.SCOPE - [LAMBDA NIL (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (SETQ BUILD.NEXT.SCOPE (create SCOPE]) - -(BUILD.STORE.EXPORTS - [LAMBDA (EXPORTS) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (COND - (EXPORTS (SETQ BUILD.PREFIX (CAR EXPORTS]) - -(BUILD.STORE.IDENTLIST - [LAMBDA (IDENTLIST) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (replace (SCOPE ID) of BUILD.NEXT.SCOPE with (CAR IDENTLIST]) - -(BUILD.STORE.INTERFACES - [LAMBDA (INTERFACES) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (for INTERFACE in INTERFACES do (BUILD.STORE.INTERFACE INTERFACE]) - -(BUILD.STORE.INTERFACE - [LAMBDA (INTERFACE) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (PUTPROP INTERFACE 'MESA.INTERFACE T]) - -(BUILD.STORE.OPEN - [LAMBDA (OPEN) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (replace (SCOPE OPEN) of BUILD.NEXT.SCOPE with OPEN]) - -(BUILD.STORE.USING - [LAMBDA (INTERFACE USING) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (for USE in USING do (PUTPROP USE 'MESA.USEDBY INTERFACE]) - -(BUILD.INITIALIZATION - [LAMBDA (IDENTLIST TYPEEXP INITIALIZATION) (* kbr%: "25-Nov-85 17:27") - (PROG (ANSWER) - (SELECTQ (BUILD.TYPEATOM TYPEEXP) - (PROC (BUILD.INITIALIZE.FN (CAR IDENTLIST) - TYPEEXP INITIALIZATION)) - (MRECORD (BUILD.INITIALIZE.RECORD (CAR IDENTLIST) - TYPEEXP INITIALIZATION)) - (SETQ ANSWER (BUILD.INITIALIZE.VARS IDENTLIST TYPEEXP INITIALIZATION - BUILD.CURRENT.SCOPE))) - (RETURN ANSWER]) - -(BUILD.INITIALIZE.VARS - [LAMBDA (IDENTLIST TYPEEXP INITIALIZATION SCOPE) (* kbr%: "25-Nov-85 17:27") - (PROG (ANSWER) - (SETQ ANSWER (for ID in IDENTLIST collect (BUILD.INITIALIZE.VAR ID TYPEEXP INITIALIZATION - SCOPE))) - (RETURN ANSWER]) - -(BUILD.INITIALIZE.VAR - [LAMBDA (ID TYPEEXP INITIALIZATION SCOPE) (* kbr%: "25-Nov-85 17:27") - (PROG (PAIRITEM) - (SETQ PAIRITEM (create PAIRITEM - ID _ ID - TYPEEXP _ TYPEEXP - DEFAULT _ INITIALIZATION)) - (replace (SCOPE SYMBOLTABLE) of SCOPE with (NCONC (fetch (SCOPE SYMBOLTABLE) of SCOPE) - (LIST PAIRITEM))) - (COND - ((NULL BUILD.SCOPE.STACK) - (BUILD.ADD.TO.FILECOMS (LIST ID (BUILD.COERCE INITIALIZATION TYPEEXP)) - 'INITVARS) - (PRIN1 ID T) - (PRIN1 "," T))) - (RETURN ID]) - -(BUILD.INITIALIZE.FN - [LAMBDA (ID TYPEEXP INITIALIZATION) (* kbr%: "25-Nov-85 17:27") - (PROG (PROCID ARGLIST RETURNLIST LAMBDA) - (SETQ PROCID (BUILD.PROCID BUILD.PREFIX ID)) - (SETQ ARGLIST (fetch (SCOPE ARGLIST) of BUILD.NEXT.SCOPE)) - (SETQ RETURNLIST (fetch (SCOPE RETURNLIST) of BUILD.NEXT.SCOPE)) - (PUTPROP ID 'MESA.USEDBY BUILD.PREFIX) - (PUTPROP PROCID 'MESA.FN T) - (PUTPROP PROCID 'MESA.ARGLIST ARGLIST) - (PUTPROP PROCID 'MESA.RETURNLIST RETURNLIST) - (SETQ LAMBDA (BUILD.LAMBDA ARGLIST INITIALIZATION)) - (PUTD PROCID LAMBDA) - (BUILD.ADD.TO.FILECOMS PROCID 'FNS) - (BUILD.GC.SCOPE) - (PRIN1 ID T) - (PRIN1 "," T]) - -(BUILD.INITIALIZE.RECORD - [LAMBDA (ID TYPEEXP INITIALIZATION) (* kbr%: "25-Nov-85 17:27") - (PROG (RECORDID FIELDLIST RECORD) - (SETQ RECORDID (BUILD.RECORDID BUILD.PREFIX ID)) - (replace (MRECORD RECORDID) of TYPEEXP with RECORDID) - (SETQ RECORD (BUILD.RECORD RECORDID TYPEEXP)) - (EVAL RECORD) - (BUILD.ADD.TO.FILECOMS RECORDID 'RECORDS) - (PUTPROP ID 'MESA.USEDBY BUILD.PREFIX) - (PUTPROP RECORDID 'MESA.TYPE TYPEEXP) - (PRIN1 ID T) - (PRIN1 "," T]) - -(BUILD.RECORD - [LAMBDA (RECORDID TYPEEXP) (* kbr%: "25-Nov-85 17:27") - (PROG (FIELDLIST FIELDS DEFAULTS ANSWER) - (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of TYPEEXP)) - (COND - [(NULL FIELDLIST) - - (* I'm not really sure what an empty FIELDLIST is supposed to get you in - MESA/CEDAR. *) - - (RETURN `(TYPERECORD ,RECORDID] - [(type? PAIRLIST FIELDLIST) - (for ITEM in (REVERSE (fetch (PAIRLIST ITEMS) of FIELDLIST)) - do (push FIELDS (fetch (PAIRITEM ID) of ITEM)) - (COND - ((fetch (PAIRITEM DEFAULT) of ITEM) - (SETQ DEFAULTS (NCONC DEFAULTS `(,(fetch (PAIRITEM ID) of ITEM) - _ - ,(BUILD.COERCE (fetch (PAIRITEM DEFAULT) - of ITEM) - (fetch (PAIRITEM TYPEEXP) - of ITEM] - [(type? TYPELIST FIELDLIST) - (for ITEM in (REVERSE (fetch (TYPELIST ITEMS) of FIELDLIST)) as I from 1 - do (push FIELDS (PACK* 'FIELD I)) - (COND - ((fetch (TYPEITEM DEFAULT) of ITEM) - (SETQ DEFAULTS (NCONC DEFAULTS `(,(PACK* 'FIELD I) - _ - ,(BUILD.COERCE (fetch (TYPEITEM DEFAULT) - of ITEM) - (fetch (TYPEITEM TYPEEXP) - of ITEM] - (T (SHOULDNT))) - [SETQ ANSWER `(RECORD ,RECORDID ,FIELDS ,@DEFAULTS] - (RETURN ANSWER]) - -(BUILD.TYPE - [LAMBDA (IDENTLIST TYPEEXP DEFAULT) (* kbr%: "25-Nov-85 17:27") - (PROG (ID TYPEID) - (SELECTQ (BUILD.TYPEATOM TYPEEXP) - (MRECORD (BUILD.INITIALIZE.RECORD (CAR IDENTLIST) - TYPEEXP DEFAULT)) - (PROGN (SETQ TYPEID (BUILD.TYPEID BUILD.PREFIX (CAR IDENTLIST))) - (COND - ((NOT (EQ TYPEID TYPEEXP)) - (PUTPROP (CAR IDENTLIST) - 'MESA.USEDBY BUILD.PREFIX) - (PUTPROP TYPEID 'MESA.TYPE TYPEEXP]) - -(BUILD.STORE.ARGLIST - [LAMBDA (ARGLIST) (* kbr%: "25-Nov-85 17:27") - (* ARGLIST = args for coming function - scope. *) - (PROG NIL - (replace (SCOPE ARGLIST) of BUILD.NEXT.SCOPE with ARGLIST) - (COND - ((type? PAIRLIST ARGLIST) - (BUILD.STORE.PAIRLIST ARGLIST]) - -(BUILD.STORE.RETURNLIST - [LAMBDA (RETURNLIST) (* kbr%: "25-Nov-85 17:27") - (* RETURNLIST = args for coming - function scope. *) - (PROG NIL - (replace (SCOPE RETURNLIST) of BUILD.NEXT.SCOPE with RETURNLIST) - (COND - ((type? PAIRLIST RETURNLIST) - (BUILD.STORE.PAIRLIST RETURNLIST]) - -(BUILD.STORE.PAIRLIST - [LAMBDA (PAIRLIST) (* kbr%: "25-Nov-85 17:27") - - (* PAIRLIST = args or return vals for coming function scope. - *) - - (PROG NIL - (for PAIRITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST) collect (BUILD.STORE.PAIRITEM - PAIRITEM - BUILD.NEXT.SCOPE]) - -(BUILD.STORE.PAIRITEM - [LAMBDA (PAIRITEM SCOPE) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (replace (SCOPE SYMBOLTABLE) of SCOPE with (NCONC (fetch (SCOPE SYMBOLTABLE) of SCOPE) - (LIST PAIRITEM))) - (RETURN (fetch (PAIRITEM ID) of PAIRITEM]) - -(BUILD.STORE.VARLIST - [LAMBDA (VARLIST) (* kbr%: "25-Nov-85 17:27") - (PROG NIL - (replace (SCOPE VARLIST) of BUILD.CURRENT.SCOPE with VARLIST]) - -(BUILD.ID - [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") - (PROG (ANSWER) - (COND - ((STRPOS "." ID) - (RETURN ID))) - [SETQ INTERFACE (OR INTERFACE (GETPROP ID 'MESA.USEDBY] - (SETQ ANSWER (COND - (INTERFACE (PACK* INTERFACE "." ID)) - (T ID))) - (RETURN ANSWER]) - -(BUILD.FIELDID - [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") - ID]) - -(BUILD.PROCID - [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") - (BUILD.ID INTERFACE ID]) - -(BUILD.RECORDID - [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") - (BUILD.ID INTERFACE ID]) - -(BUILD.TYPEID - [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") - (COND - ((FMEMB ID PARSE.PREDEFINED.TYPES) - ID) - (T (BUILD.ID INTERFACE ID]) - -(BUILD.VARID - [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") - (PROG (ANSWER) - [SETQ ANSWER (COND - ((BUILD.LOOKUP ID) - (BUILD.LOCALVARID INTERFACE ID)) - (T (BUILD.GLOBALVARID INTERFACE ID] - (RETURN ANSWER]) - -(BUILD.LOCALVARID - [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") - ID]) - -(BUILD.GLOBALVARID - [LAMBDA (INTERFACE ID) (* kbr%: "25-Nov-85 17:27") - (BUILD.ID INTERFACE ID]) - -(BUILD.ULTIMATE.TYPE - [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") - (BUILD.REFINE.TYPE (BUILD.IMMEDIATE.TYPE EXP]) - -(BUILD.REFINE.TYPE - [LAMBDA (TYPE) (* kbr%: "25-Nov-85 17:27") - (PROG (PAIRITEM NEXTTYPE) - LOOP - (SETQ NEXTTYPE (COND - ((OR (FMEMB TYPE '(ANY MPROC INTERFACE)) - (FMEMB TYPE PARSE.PREDEFINED.TYPES)) - (SELECTQ TYPE - (BOOL 'BOOLEAN) - (CHAR 'CHARACTER) - ((INT INTEGER NAT WORD) - 'CARDINAL) - (StringBody 'STRING) - (UNSPECIFIED 'ANY) - TYPE)) - ((LITATOM TYPE) - (OR (BUILD.LOOKUP.TYPE TYPE) - (PROGN (printout T T TYPE " type unknown." T) - (PUTPROP TYPE 'MESA.TYPE 'UNDECLARED) - TYPE))) - ((type? MINTERVAL TYPE) - (fetch (MINTERVAL LBOUND) of TYPE)) - ((type? MPOINTER TYPE) - (fetch (MPOINTER TYPE) of TYPE)) - ((type? MREF TYPE) - (fetch (MREF TYPE) of TYPE)) - (T TYPE))) - (COND - ((EQ NEXTTYPE 'UNDECLARED) - (RETURN TYPE)) - ((NOT (EQ NEXTTYPE TYPE)) - (SETQ TYPE NEXTTYPE) - (GO LOOP))) - (RETURN TYPE]) - -(BUILD.IMMEDIATE.TYPE - [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") - (PROG (TYPE FN RECORDNAME FIELDNAME MRECORD FIELDLIST PAIRITEM) - [SETQ TYPE (COND - ((OR (NULL EXP) - (EQ EXP T)) - 'BOOLEAN) - [(LITATOM EXP) - (OR (BUILD.LOOKUP.TYPE EXP) - (PROGN (printout T T EXP " type unknown." T) - 'ANY] - ((FIXP EXP) - 'CARDINAL) - ((FLOATP EXP) - 'REAL) - ((STRINGP EXP) - 'STRING) - [(LISTP EXP) - (SETQ FN (CAR EXP)) - (COND - ((EQ FN 'SETQ) - (BUILD.IMMEDIATE.TYPE (CADR EXP))) - [(EQ FN 'CAR) - (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP))) - (COND - ((type? MLIST TYPE) - (fetch (MLIST TYPE) of TYPE)) - (T (printout T T EXP " type unknown." T) - 'ANY] - [(EQ FN 'CDR) - (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP))) - (COND - ((type? MLIST TYPE) - TYPE) - (T (printout T T EXP " type unknown." T) - 'ANY] - [(FMEMB FN '(CONS LIST)) - (SETQ TYPE (BUILD.IMMEDIATE.TYPE (CADR EXP))) - (COND - (TYPE (create MLIST - TYPE _ TYPE)) - (T (printout T T EXP " type unknown." T) - 'ANY] - [(EQ FN 'COND) - (BUILD.IMMEDIATE.TYPE (CADR (CADR EXP] - [(EQ FN 'ELT) - (SETQ TYPE (BUILD.ULTIMATE.TYPE (CADR EXP))) - (COND - ((type? MARRAY TYPE) - (fetch (MARRAY TYPE) of TYPE)) - (T (printout T T EXP " type unknown." T) - 'ANY] - ((EQ FN 'create) - (CADR EXP)) - [(EQ FN 'fetch) - (SETQ RECORDNAME (CAR (CADR EXP))) - (SETQ FIELDNAME (CADR (CADR EXP))) - (SETQ MRECORD (GETPROP RECORDNAME 'MESA.TYPE)) - (COND - ((EQ MRECORD 'UNDECLARED) - 'ANY) - (T (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of MRECORD)) - (COND - ((type? PAIRLIST FIELDLIST) - (SETQ PAIRITEM (ASSOC FIELDNAME (fetch (PAIRLIST ITEMS) - of FIELDLIST))) - (fetch (PAIRITEM TYPEEXP) of PAIRITEM)) - (T (printout T T EXP " type unknown." T) - 'ANY] - ((FMEMB FN BUILD.BOOLEAN.FNS) - 'BOOLEAN) - ((FMEMB FN BUILD.CARDINAL.FNS) - 'CARDINAL) - ((FMEMB FN BUILD.MIXED.FNS) - 'MIXED) - ((FMEMB FN BUILD.REAL.FNS) - 'REAL) - (T (printout T T EXP " type unknown." T) - 'ANY] - (T (printout T T EXP " type unknown." T) - 'ANY] - (RETURN TYPE]) - -(BUILD.LOOKUP.TYPE - [LAMBDA (ID) (* kbr%: "25-Nov-85 17:27") - (PROG (PAIRITEM TYPE) - (SETQ PAIRITEM (BUILD.LOOKUP ID)) - (COND - (PAIRITEM (SETQ TYPE (fetch (PAIRITEM TYPEEXP) of PAIRITEM)) - (RETURN TYPE))) - [SETQ TYPE (COND - ((GETPROP ID 'MESA.TYPE)) - ((GETPROP ID 'MESA.USEDBY) - (BUILD.ID (GETPROP ID 'MESA.USEDBY) - ID)) - ((GETPROP ID 'MESA.FN) - (RETURN 'MPROC)) - ((GETPROP ID 'MESA.INTERFACE) - (RETURN 'INTERFACE] - (RETURN TYPE]) - -(BUILD.LOOKUP - [LAMBDA (ID) (* kbr%: "25-Nov-85 17:27") - (PROG (ANSWER) - [for SCOPE in (CONS BUILD.CURRENT.SCOPE BUILD.SCOPE.STACK) - do (SETQ ANSWER (ASSOC ID (fetch (SCOPE SYMBOLTABLE) of SCOPE))) - (COND - (ANSWER (RETURN] - (RETURN ANSWER]) - -(BUILD.TYPEATOM - [LAMBDA (TYPEEXP) (* kbr%: "25-Nov-85 17:27") - (COND - ((LITATOM TYPEEXP) - TYPEEXP) - (T (CAR TYPEEXP]) - -(BUILD.QUALIFY - [LAMBDA (LHS QUALIFIER) (* kbr%: "25-Nov-85 17:27") - (PROG (TYPE TYPEATOM ANSWER) (* (qualifier %. prefixop) - (qualifier %. typeop) - (qualifier %. SIZE) (qualifier %[ - explist optcatch %]) - (qualifier %. id) (qualifier ^) *) - [SETQ ANSWER (COND - ((FMEMB QUALIFIER PARSE.PREFIXOPS) - (BUILD.QUALIFY.PREFIXOP LHS QUALIFIER)) - ((FMEMB QUALIFIER PARSE.TYPEOPS) - (BUILD.QUALIFY.TYPEOP LHS QUALIFIER)) - ((EQ QUALIFIER 'SIZE) - (PACK* LHS "." QUALIFIER)) - [(EQ QUALIFIER 'first) - `(CAR ,LHS] - [(EQ QUALIFIER 'rest) - `(CDR ,LHS] - ((OR (NULL QUALIFIER) - (LISTP QUALIFIER)) - (BUILD.QUALIFY.EXPLIST LHS QUALIFIER)) - ((EQ QUALIFIER '^) - LHS) - (T (BUILD.QUALIFY.ID LHS QUALIFIER] - (RETURN ANSWER]) - -(BUILD.QUALIFY.PREFIXOP - [LAMBDA (LHS QUALIFIER) (* kbr%: "25-Nov-85 17:27") - (SELECTQ QUALIFIER - ((MAX MIN) - (BUILD.ARITH.EXP* QUALIFIER LHS)) - (CONS QUALIFIER LHS]) - -(BUILD.QUALIFY.TYPEOP - [LAMBDA (LHS QUALIFIER) (* kbr%: "25-Nov-85 17:27") - (CONS QUALIFIER LHS]) - -(BUILD.QUALIFY.EXPLIST - [LAMBDA (LHS EXPLIST) (* kbr%: "25-Nov-85 17:27") - (* Qualify LHS with EXPLIST qualifier. - *) - (PROG (TYPE TYPEATOM EXPITEMS ANSWER) - [COND - ((LITATOM LHS) - (SETQ LHS (BUILD.ID NIL LHS] - (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS)) - (SETQ TYPEATOM (BUILD.TYPEATOM TYPE)) - (SETQ EXPITEMS (fetch (EXPLIST ITEMS) of EXPLIST)) - [SETQ ANSWER (SELECTQ TYPEATOM - (MARRAY `(ELT ,LHS ,@EXPITEMS)) - (MPROC (BUILD.CALL LHS EXPLIST)) - (STRING `(NTHCHARCODE ,LHS ,@EXPITEMS)) - (MRECORD (* Presumably record contains - SEQUENCE. *) - `(ELT ,LHS ,@EXPITEMS)) - (COND - ((AND (LISTP LHS) - (IEQP (LENGTH LHS) - 2)) (* "ARG1.FN[ARG2,...,ARGn]" *) - (APPEND LHS EXPITEMS)) - (T (printout T T LHS " qualified by " EXPLIST "?" T) - (COND - [(AND (type? ORDERLIST EXPLIST) - (IEQP (LENGTH EXPITEMS) - 1)) (* Guess array access. - *) - `(ELT ,LHS ,@EXPITEMS] - (T (CONS LHS EXPITEMS] - (RETURN ANSWER]) - -(BUILD.QUALIFY.ID - [LAMBDA (LHS QUALIFIER) (* kbr%: "25-Nov-85 17:27") - (* Qualify LHS with id QUALIFIER. - *) - (PROG (TYPE TYPEATOM ANSWER) - (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS)) - (SETQ TYPEATOM (BUILD.TYPEATOM TYPE)) - [SETQ ANSWER (SELECTQ TYPEATOM - (MRECORD `(fetch (,(fetch (MRECORD RECORDID) of TYPE) ,QUALIFIER) - of ,LHS)) - (MARRAY (printout T T LHS " qualified by " QUALIFIER "?" T) - `(ELT ,LHS ,QUALIFIER)) - (INTERFACE (BUILD.ID LHS QUALIFIER)) - (MPROC (COND - (QUALIFIER (LIST LHS QUALIFIER)) - (T (LIST LHS)))) - (STRING (printout T T LHS " qualified by " QUALIFIER "?" T) - `(NTHCHARCODE ,LHS ,QUALIFIER)) - (COND - [(EQ (GETPROP TYPE 'MESA.TYPE) - 'UNDECLARED) (* Guess undeclared record. - *) - `(fetch (,TYPE ,QUALIFIER) of ,LHS] - (T (* Guess undeclared fn. - *) - (LIST QUALIFIER LHS] - (RETURN ANSWER]) - -(BUILD.ARITH.EXP1 - [LAMBDA (ARITHOP EXP1) (* kbr%: "25-Nov-85 17:27") - [COND - ((EQ ARITHOP '-) - (SETQ ARITHOP '0-] - (BUILD.ARITH.EXP* ARITHOP (LIST EXP1]) - -(BUILD.ARITH.EXP2 - [LAMBDA (ARITHOP EXP1 EXP2) (* kbr%: "25-Nov-85 17:27") - (PROG (ANSWER) - (SETQ ANSWER (BUILD.ARITH.EXP* ARITHOP (LIST EXP1 EXP2))) - (RETURN ANSWER]) - -(BUILD.ARITH.EXP* - [LAMBDA (ARITHOP EXPS) (* kbr%: "25-Nov-85 17:27") - (PROG (TYPE NEWARITHOP ANSWER) - (SETQ TYPE (BUILD.STRONGEST.TYPE.AMONG EXPS)) - (SETQ NEWARITHOP (BUILD.COERCE.ARITHOP ARITHOP TYPE)) - [COND - ((EQ TYPE 'REAL) - (SETQ EXPS (for EXP in EXPS collect (COND - ((FIXP EXP) - (FLOAT EXP)) - (T EXP] - (SETQ ANSWER (CONS NEWARITHOP EXPS)) - [COND - ((FMEMB NEWARITHOP '(IPLUS IDIFFERENCE)) - (SETQ ANSWER (BUILD.ARITH.ADD1SUB1 ANSWER))) - [(AND (EQ ARITHOP '0-) - (NUMBERP (CADR ANSWER))) - (SETQ ANSWER (APPLY* (CAR ANSWER) - (CADR ANSWER] - ([OR (EQ ARITHOP '%#) - (AND (FMEMB ARITHOP (LIST '<= '>=)) - (NOT (EQ TYPE 'CARDINAL] - (SETQ ANSWER (LIST 'NOT ANSWER] - (RETURN ANSWER]) - -(BUILD.ARITH.ADD1SUB1 - [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") - - (* Use ADD1 or SUB1 instead of IPLUS or IDIFFERENCE if possible. - *) - - (PROG (FN EXP1 EXP2 ANSWER) - (COND - ((NOT (IEQP (FLENGTH EXP) - 3)) - (RETURN EXP))) - (SETQ FN (CAR EXP)) - (SETQ EXP1 (CADR EXP)) - (SETQ EXP2 (CADDR EXP)) - (COND - [(EQ FN 'IPLUS) - (COND - ((EQ EXP1 1) - (SETQ ANSWER (BUILD.ADD1 EXP2))) - ((EQ EXP2 1) - (SETQ ANSWER (BUILD.ADD1 EXP1))) - (T (SETQ ANSWER EXP] - ((AND (EQ FN 'IDIFFERENCE) - (EQ EXP2 1)) - (SETQ ANSWER (BUILD.SUB1 EXP1))) - (T (SETQ ANSWER EXP))) - (RETURN ANSWER]) - -(BUILD.COERCE.ARITHOP - [LAMBDA (ARITHOP TYPE) (* kbr%: "25-Nov-85 17:27") - (SELECTQ TYPE - (CARDINAL (CDR (ASSOC ARITHOP BUILD.CARDINAL.ARITHOP.ALIST))) - (MIXED (CDR (ASSOC ARITHOP BUILD.MIXED.ARITHOP.ALIST))) - (REAL (CDR (ASSOC ARITHOP BUILD.REAL.ARITHOP.ALIST))) - (SHOULDNT]) - -(BUILD.STRONGEST.TYPE.AMONG - [LAMBDA (EXPS) (* kbr%: "25-Nov-85 17:27") - (PROG (TYPE) - (SETQ TYPE 'CARDINAL) - [for EXP in EXPS while (NOT (EQ TYPE 'REAL)) do (SETQ TYPE (BUILD.STRONGEST.TYPE - TYPE - (BUILD.ULTIMATE.TYPE EXP] - (RETURN TYPE]) - -(BUILD.STRONGEST.TYPE - [LAMBDA (TYPE1 TYPE2) (* kbr%: "25-Nov-85 17:27") - [COND - ((FMEMB TYPE1 BUILD.CARDINAL.TYPES) - (SETQ TYPE1 'CARDINAL] - [COND - ((FMEMB TYPE2 BUILD.CARDINAL.TYPES) - (SETQ TYPE2 'CARDINAL] - (SELECTQ TYPE1 - (CARDINAL (SELECTQ TYPE2 - (CARDINAL 'CARDINAL) - (REAL 'REAL) - 'MIXED)) - (MIXED (SELECTQ TYPE2 - (REAL 'REAL) - 'MIXED)) - (REAL 'REAL) - 'MIXED]) - -(BUILD.COERCE - [LAMBDA (EXP TYPE) (* kbr%: "25-Nov-85 17:27") - (PROG (TYPEEXP ANSWER) - (SETQ TYPEEXP (BUILD.REFINE.TYPE TYPE)) - (SETQ ANSWER (COND - ((type? MARRAY TYPEEXP) - (FRESHLINE T) - (printout T T "Coercion to " TYPE " array type." T) - (BUILD.COERCE.MARRAY EXP TYPEEXP)) - ((type? MLIST TYPEEXP) - (BUILD.COERCE.MLIST EXP TYPEEXP)) - ((type? EXPLIST EXP) - (BUILD.COERCE.EXPLIST EXP TYPEEXP)) - (T EXP))) - (RETURN ANSWER]) - -(BUILD.COERCE.MARRAY - [LAMBDA (EXP MARRAY) (* kbr%: "25-Nov-85 17:27") - (PROG (TYPE ANSWER) - - (* This is legal MESA/CEDAR code with no very elegant Interlisp translation. - *) - - (SETQ TYPE (fetch (MARRAY TYPE) of MARRAY)) - (SETQ ANSWER (COND - [(type? EXPLIST EXP) (* Should be an ORDERLIST. - *) - (CONS 'LIST (for ITEM in (fetch (EXPLIST ITEMS) of EXP) - collect (BUILD.COERCE ITEM TYPE] - (T (* EXP might be an MARRAY var. - *) - EXP))) - (RETURN ANSWER]) - -(BUILD.COERCE.MLIST - [LAMBDA (EXP MLIST) (* kbr%: "25-Nov-85 17:27") - (PROG (TYPE ANSWER) - (SETQ TYPE (fetch (MLIST TYPE) of MLIST)) - (SETQ ANSWER (COND - ((NOT (LISTP EXP)) - EXP) - [(EQ (CAR EXP) - 'LIST) - `(LIST ,@(for ITEM in (CDR EXP) collect (BUILD.COERCE ITEM TYPE] - [(EQ (CAR EXP) - 'CONS) - `(CONS ,(BUILD.COERCE (CADR EXP) - TYPE) ,(BUILD.COERCE (CADDR EXP) - MLIST] - (T EXP))) - (RETURN ANSWER]) - -(BUILD.COERCE.EXPLIST - [LAMBDA (EXPLIST MRECORD) (* kbr%: "25-Nov-85 17:27") - - (* Converts a Mesa explist EXPLIST (ambiguous by itself) into a CREATE TYPE - Lisp expression. *) - - (PROG (FIELDLIST ALIGNMENT SETTINGS ANSWER) - (COND - ((NOT (type? EXPLIST EXPLIST)) - (RETURN EXPLIST))) - [COND - ((NOT (type? MRECORD MRECORD)) - (printout T T MRECORD " not a record" T) (* Proceed to do the best we can. - *) - [COND - ((type? KEYLIST EXPLIST) - [SETQ SETTINGS (for ITEM in (fetch (KEYLIST ITEMS) of EXPLIST) - join `(,(fetch (KEYITEM ID) of ITEM) _ ,(fetch (KEYITEM OPTEXP) - of ITEM] - (RETURN `(create ,MRECORD ,@SETTINGS] - (RETURN `(,MRECORD ,@(fetch (EXPLIST ITEMS) of EXPLIST] - (SETQ FIELDLIST (fetch (MRECORD FIELDLIST) of MRECORD)) - (SETQ ALIGNMENT (BUILD.ALIGN FIELDLIST EXPLIST)) - [SETQ SETTINGS (COND - [(type? PAIRLIST FIELDLIST) - (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST) as ALIGNVALUE - in ALIGNMENT when [NOT (FMEMB ALIGNVALUE '(NIL TRASH] - join `(,(fetch (PAIRITEM ID) of PAIRITEM) _ ,ALIGNVALUE] - [(type? TYPELIST FIELDLIST) - (for TYPEITEM in (fetch (TYPELIST ITEMS) of FIELDLIST) as ALIGNVALUE - in ALIGNMENT as I from 1 - when [NOT (FMEMB ALIGNVALUE '(NIL TRASH] - join `(,(PACK* 'FIELD I) _ ,ALIGNVALUE] - (T (SHOULDNT] - EXIT - [SETQ ANSWER `(create ,(fetch (MRECORD RECORDID) of MRECORD) ,@SETTINGS] - (RETURN ANSWER]) - -(BUILD.ALIGN - [LAMBDA (FIELDLIST EXPLIST) (* kbr%: "25-Nov-85 17:27") - (PROG (ANSWER) - [SETQ ANSWER (COND - ((AND (NULL FIELDLIST) - (NULL EXPLIST)) - NIL) - ((EQ FIELDLIST 'ANY) - (fetch (EXPLIST ITEMS) of EXPLIST)) - [(type? ORDERLIST EXPLIST) - (COND - ((type? PAIRLIST FIELDLIST) - (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST) as OPTEXP - in (fetch (ORDERLIST ITEMS) of EXPLIST) - collect (BUILD.ALIGN.VALUE (fetch (PAIRITEM TYPEEXP) of PAIRITEM) - (fetch (PAIRITEM DEFAULT) of PAIRITEM) - OPTEXP))) - ((type? TYPELIST FIELDLIST) - (for TYPEITEM in (fetch (TYPELIST ITEMS) of FIELDLIST) as OPTEXP - in (fetch (ORDERLIST ITEMS) of EXPLIST) - collect (BUILD.ALIGN.VALUE (fetch (TYPEITEM TYPEEXP) of TYPEITEM) - (fetch (TYPEITEM DEFAULT) of TYPEITEM) - OPTEXP))) - (T (SHOULDNT] - [(type? KEYLIST EXPLIST) - (COND - ((NOT (type? PAIRLIST FIELDLIST)) - (SHOULDNT))) - (for PAIRITEM in (fetch (PAIRLIST ITEMS) of FIELDLIST) - collect (BUILD.ALIGN.VALUE (fetch (PAIRITEM TYPEEXP) of PAIRITEM) - (fetch (PAIRITEM DEFAULT) of PAIRITEM) - (fetch (KEYITEM OPTEXP) - of (ASSOC (fetch (PAIRITEM ID) of PAIRITEM) - (fetch (KEYLIST ITEMS) of EXPLIST] - (T (SHOULDNT] - (RETURN ANSWER]) - -(BUILD.ALIGN.VALUE - [LAMBDA (TYPEEXP DEFAULT OPTEXP) (* kbr%: "25-Nov-85 17:27") - (PROG (ANSWER) - [SETQ ANSWER (OR (COND - ((AND (fetch (DEFAULT TRASH) of DEFAULT) - (EQ OPTEXP 'TRASH)) - 'TRASH)) - (BUILD.COERCE OPTEXP TYPEEXP) - (COPY (fetch (DEFAULT EXP) of DEFAULT] - (RETURN ANSWER]) - -(BUILD.ADD.TO.FILECOMS - [LAMBDA (NAME TYPE) (* kbr%: "25-Nov-85 17:27") - (PROG (FILECOMSVAR FILECOMS) - (SETQ FILECOMSVAR BUILD.FILECOMS) - (SETQ FILECOMS (GETTOPVAL FILECOMSVAR)) (* FILECOMS is reversed at this point. - *) - [COND - ((AND FILECOMS (EQ (CAR (CAR FILECOMS)) - TYPE)) - (NCONC (CAR FILECOMS) - (LIST NAME))) - (T (push FILECOMS (LIST TYPE NAME] - (SETTOPVAL FILECOMSVAR FILECOMS]) - -(BUILD.ADD1 - [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") - (COND - ((FIXP EXP) - (ADD1 EXP)) - (T `(ADD1 ,EXP]) - -(BUILD.CALL - [LAMBDA (FN EXPLIST) (* kbr%: "25-Nov-85 17:27") - - (* Function call. Cons FN onto front of coerced EXPLIST items. - *) - - (CONS FN (BUILD.ALIGN (GETPROP FN 'MESA.ARGLIST) - EXPLIST]) - -(BUILD.CHARCODE - [LAMBDA (CHARCODE) (* kbr%: "25-Nov-85 17:27") - (PROG (META CONTROL CHAR NAME ANSWER) - [SETQ NAME (SELECTQ CHARCODE - (0 'NULL) - (7 'BELL) - (8 'BS) - (9 'TAB) - (10 'LF) - (12 'FF) - (13 'CR) - (27 'ESC) - (32 'SPACE) - (127 'DEL) - (PROGN [COND - ((IGEQ CHARCODE 128) - (SETQ META T) - (SETQ CHARCODE (IDIFFERENCE CHARCODE 128] - [COND - ((ILESSP CHARCODE 32) - (SETQ CONTROL T) - (SETQ CHARCODE (IPLUS CHARCODE 32] - (SETQ CHAR (MKATOM (CHARACTER CHARCODE))) - (COND - ((AND META CONTROL) - (PACK* '%#^ CHAR)) - (META (PACK* '%# CHAR)) - (CONTROL (PACK* '^ CHAR)) - (T CHAR] - (SETQ ANSWER (LIST 'CHARCODE NAME)) - (RETURN ANSWER]) - -(BUILD.COND - [LAMBDA (EXP1 EXP2 EXP3) (* kbr%: "25-Nov-85 17:27") - (PROG (HEAD TAIL ANSWER) - (SETQ HEAD (CONS EXP1 (BUILD.TAIL EXP2))) - [SETQ TAIL (COND - ((NULL EXP3) - NIL) - ((AND (LISTP EXP3) - (EQ (CAR EXP3) - 'COND)) - (CDR EXP3)) - (T `((T ,@(BUILD.TAIL EXP3] - [SETQ ANSWER `(COND - ,HEAD - ,@TAIL] - (RETURN ANSWER]) - -(BUILD.COPY.OF - [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:27") - (COND - ((AND (LISTP EXP) - (EQ (CAR EXP) - 'SETQ)) - (CADR EXP)) - (T (COPY EXP]) - -(BUILD.FETCH - [LAMBDA (RECORDNAME FIELDNAME DATUM) (* kbr%: "25-Nov-85 17:27") - (PROG (MRECORD ANSWER) - [SETQ MRECORD (COND - (RECORDNAME (BUILD.REFINE.TYPE RECORDNAME)) - (T (BUILD.ULTIMATE.TYPE DATUM] - [SETQ ANSWER (COND - [(type? MRECORD MRECORD) - (SETQ RECORDNAME (fetch (MRECORD RECORDID) of MRECORD)) - `(fetch (,RECORDNAME ,FIELDNAME) of ,DATUM] - (T (printout T T "Bad fetch " RECORDNAME " " FIELDNAME " " DATUM T) - (LIST FIELDNAME DATUM] - (RETURN ANSWER]) - -(BUILD.FORCLAUSE.BY - [LAMBDA (CONTROLID EXP1 EXP2) (* kbr%: "25-Nov-85 17:27") - `(for ,CONTROLID _ ,EXP1 by ,EXP2]) - -(BUILD.FORCLAUSE.IN - [LAMBDA (CONTROLID DIRECTION RANGE) (* kbr%: "25-Nov-85 17:27") - (PROG (INTERVAL LBOUND UBOUND ANSWER) - (SETQ INTERVAL (fetch (MRANGE INTERVAL) of RANGE)) - (SETQ LBOUND (fetch (MINTERVAL LBOUND) of INTERVAL)) - (SETQ UBOUND (fetch (MINTERVAL UBOUND) of INTERVAL)) - (SELECTQ (fetch (MINTERVAL KIND) of INTERVAL) - (CC) - (CO (SETQ UBOUND (BUILD.SUB1 UBOUND))) - (OC (SETQ LBOUND (BUILD.ADD1 LBOUND))) - (OO (SETQ LBOUND (BUILD.ADD1 LBOUND)) - (SETQ UBOUND (BUILD.SUB1 UBOUND))) - (SHOULDNT)) - [SETQ ANSWER (COND - ((EQ DIRECTION 'DECREASING) - `(for ,CONTROLID from ,LBOUND to ,UBOUND by -1)) - (T `(for ,CONTROLID from ,LBOUND to ,UBOUND] - (RETURN ANSWER]) - -(BUILD.FORCLAUSE.THROUGH - [LAMBDA (RANGE) (* kbr%: "25-Nov-85 17:27") - (BUILD.FORCLAUSE.IN 'X NIL RANGE]) - -(BUILD.IN - [LAMBDA (EXP RANGE) (* kbr%: "25-Nov-85 17:28") - (PROG (INTERVAL EXP2 LPRED UPRED ANSWER) - (SETQ RANGE (BUILD.REFINE.TYPE RANGE)) - [COND - ((NOT (type? MRANGE RANGE)) - (printout T T RANGE " not a range." T) - (RETURN `(in ,RANGE] - (SETQ INTERVAL (fetch (MRANGE INTERVAL) of RANGE)) - (SELECTQ (fetch (MINTERVAL KIND) of INTERVAL) - (CC (SETQ LPRED 'IGEQ) - (SETQ UPRED 'ILEQ)) - (CO (SETQ LPRED 'IGEQ) - (SETQ UPRED 'ILESSP)) - (OC (SETQ LPRED 'IGREATERP) - (SETQ UPRED 'ILEQ)) - (OO (SETQ LPRED 'ILESSP) - (SETQ UPRED 'IGREATERP)) - (SHOULDNT)) - (SETQ EXP2 (BUILD.COPY.OF EXP)) - [SETQ ANSWER `(AND (,LPRED ,EXP ,(fetch (MINTERVAL LBOUND) of INTERVAL)) - (,UPRED ,EXP2 ,(fetch (MINTERVAL UBOUND) of INTERVAL] - (RETURN ANSWER]) - -(BUILD.ISTYPE - [LAMBDA (EXP TYPE) (* kbr%: "25-Nov-85 17:28") - (PROG (MRECORD RECORDID ANSWER) - (SETQ MRECORD (BUILD.REFINE.TYPE TYPE)) - (SETQ RECORDID (COND - ((type? MRECORD MRECORD) - (fetch (MRECORD RECORDID) of MRECORD)) - (T (printout T T "Bad istype " EXP " " TYPE T) - TYPE))) - [SETQ ANSWER `(type? ,TYPE ,EXP] - (RETURN ANSWER]) - -(BUILD.LAMBDA - [LAMBDA (PAIRLIST BODY) (* kbr%: "25-Nov-85 17:28") - (PROG (ARGLIST ANSWER) - [SETQ ARGLIST (for ITEM in (fetch (PAIRLIST ITEMS) of PAIRLIST) - collect (BUILD.LOCALVARID NIL (fetch (PAIRITEM ID) of ITEM] - [SETQ ANSWER `(LAMBDA ,ARGLIST - ,@(BUILD.TAIL BODY] - (RETURN ANSWER]) - -(BUILD.NEW - [LAMBDA (TYPEEXP INITIALIZATION) (* kbr%: "25-Nov-85 17:28") - (BUILD.COERCE INITIALIZATION TYPEEXP]) - -(BUILD.OR - [LAMBDA (EXPS) (* kbr%: "25-Nov-85 17:28") - (COND - ((NULL EXPS) - T) - ((NULL (CDR EXPS)) - (CAR EXPS)) - (T `(OR ,@EXPS]) - -(BUILD.PROG - [LAMBDA (STATEMENTLIST) (* kbr%: "25-Nov-85 17:28") - (PROG (VARS LAST ANSWER) - [SETQ ANSWER (APPEND (fetch (SCOPE INITLIST) of BUILD.CURRENT.SCOPE) - (BUILD.TAIL (BUILD.PROGN STATEMENTLIST] - (SETQ VARS (APPEND (fetch (SCOPE VARLIST) of BUILD.CURRENT.SCOPE) - (fetch (SCOPE RETURNVARS) of BUILD.CURRENT.SCOPE))) - [COND - [(OR VARS (fetch (SCOPE RETURNS) of BUILD.CURRENT.SCOPE) - (for EXP in ANSWER thereis (LITATOM EXP))) (* Local vars, return, or go here. - *) - [COND - (ANSWER (SETQ LAST (CAR (LAST ANSWER] - [COND - ([NOT (OR (NULL (fetch (SCOPE RETURNVARS) of BUILD.CURRENT.SCOPE)) - (AND (LISTP LAST) - (FMEMB (CAR LAST) - '(GO RETURN] - (SETQ ANSWER (APPEND ANSWER (LIST (BUILD.RETURN] - (SETQ ANSWER `(PROG ,VARS - ,@ANSWER] - (T (SETQ ANSWER (BUILD.PROGN ANSWER] - (RETURN ANSWER]) - -(BUILD.PROGN - [LAMBDA (EXPS) (* kbr%: "25-Nov-85 17:28") - (COND - ((NULL EXPS) - NIL) - ((NULL (CDR EXPS)) - (CAR EXPS)) - (T (CONS 'PROGN (for EXP in EXPS join (BUILD.TAIL EXP]) - -(BUILD.REPLACE - [LAMBDA (RECORDNAME FIELDNAME DATUM VALUE) (* kbr%: "25-Nov-85 17:28") - (PROG (MRECORD ANSWER) - [SETQ MRECORD (COND - (RECORDNAME (BUILD.REFINE.TYPE RECORDNAME)) - (T (BUILD.ULTIMATE.TYPE DATUM] - [SETQ ANSWER (COND - [(type? MRECORD MRECORD) - (SETQ RECORDNAME (fetch (MRECORD RECORDID) of MRECORD)) - `(replace (,RECORDNAME ,FIELDNAME) of ,DATUM with ,VALUE] - (T (printout T T "Bad replace " RECORDNAME " " FIELDNAME " " DATUM " " - VALUE T) - (LIST FIELDNAME DATUM] - (RETURN ANSWER]) - -(BUILD.RETURN - [LAMBDA (OPTARGS) (* kbr%: "25-Nov-85 17:28") - - (* COPY so DEDIT won't get confused by shared structure. - *) - - (PROG (SCOPE FN PROCID FIELDLIST EXPLIST ALIGNMENT ANSWER) - (* Get scope of innermost PROC or DO. - *) - (SETQ SCOPE (for SCOPE in (CONS BUILD.CURRENT.SCOPE BUILD.SCOPE.STACK) - thereis (fetch (SCOPE ID) of SCOPE))) - (replace (SCOPE RETURNS) of SCOPE with T) - (SETQ FN (fetch (SCOPE ID) of SCOPE)) - [SETQ ALIGNMENT (COND - ((EQ FN 'DO) - OPTARGS) - (OPTARGS (SETQ PROCID (BUILD.PROCID BUILD.PREFIX FN)) - [SETQ FIELDLIST - (OR (GETPROP PROCID 'MESA.RETURNLIST) - (PROGN (printout T T "No returnlist for " PROCID "." T) - 'ANY] - (BUILD.ALIGN FIELDLIST OPTARGS)) - (T (fetch (SCOPE RETURNVARS) of SCOPE] - [SETQ ANSWER (COND - ((NULL ALIGNMENT) - (LIST 'RETURN)) - [(NULL (CDR ALIGNMENT)) - `(RETURN ,@ALIGNMENT] - (T `(RETURN (LIST ,@ALIGNMENT] - (RETURN ANSWER]) - -(BUILD.SELECTQ - [LAMBDA (CASEHEAD CLAUSES OTHERWISE) (* kbr%: "25-Nov-85 17:28") - (PROG (ID EXP OPTEXP TYPE FN CCLAUSES SCLAUSES ANSWER) - (SETQ ID (fetch (CASEHEAD ID) of CASEHEAD)) - (SETQ EXP (fetch (CASEHEAD EXP) of CASEHEAD)) - (SETQ OPTEXP (fetch (CASEHEAD OPTEXP) of CASEHEAD)) - (SETQ EXP (OR OPTEXP ID EXP)) - (COND - ((EQ EXP T) (* Mesa SELECT TRUE FROM statement. - *) - (SETQ ANSWER (BUILD.SELECTTRUEFROM CLAUSES OTHERWISE)) - (RETURN ANSWER))) - (SETQ TYPE (BUILD.ULTIMATE.TYPE EXP)) - (SETQ FN (BUILD.SELECTQ.FN TYPE)) - [for CLAUSE in CLAUSES do (COND - ([for CASETEST in (CAR CLAUSE) - thereis (COND - ((AND (LISTP CASETEST) - (FMEMB (CAR CASETEST) - '(IN type?] - (push CCLAUSES CLAUSE)) - (T (push SCLAUSES CLAUSE] - (SETQ CCLAUSES (DREVERSE CCLAUSES)) - (SETQ SCLAUSES (DREVERSE SCLAUSES)) - (SETQ CCLAUSES (for CCLAUSE in CCLAUSES collect (BUILD.SELECTQ.CCLAUSE EXP CCLAUSE TYPE))) - (SETQ SCLAUSES (for SCLAUSE in SCLAUSES collect (BUILD.SELECTQ.SCLAUSE SCLAUSE TYPE))) - (SETQ ANSWER (COND - [SCLAUSES `(,FN ,EXP ,@SCLAUSES ,OTHERWISE] - (T OTHERWISE))) - (SETQ ANSWER (COND - [CCLAUSES (COND - [ANSWER `(COND - ,@CCLAUSES - (T ,@(BUILD.TAIL ANSWER] - (T `(COND - ,@CCLAUSES] - (T ANSWER))) - (RETURN ANSWER]) - -(BUILD.SELECTQ.FN - [LAMBDA (TYPE) (* kbr%: "25-Nov-85 17:28") - (COND - ((EQ TYPE 'CHARACTER) - 'SELCHARQ) - (T 'SELECTQ]) - -(BUILD.SELECTQ.CCLAUSE - [LAMBDA (EXP CCLAUSE TYPE) (* kbr%: "25-Nov-85 17:28") - (PROG (EXP2 KEYS TESTS ANSWER) - (SETQ EXP2 (BUILD.COPY.OF EXP)) - (SETQ KEYS (CAR CCLAUSE)) - [SETQ TESTS (CONS (BUILD.SELECTQ.TEST EXP (CAR KEYS)) - (for KEY in (CDR KEYS) collect (BUILD.SELECTQ.TEST EXP KEY] - [COND - ((NULL (CDR TESTS)) - (SETQ TESTS (CAR TESTS))) - (T (SETQ TESTS (CONS 'OR TESTS] - (SETQ ANSWER (CONS TESTS (CDR CCLAUSE))) - (RETURN ANSWER]) - -(BUILD.SELECTQ.TEST - [LAMBDA (EXP KEY) (* kbr%: "25-Nov-85 17:28") - (COND - ((AND (LISTP KEY) - (EQ (CAR KEY) - 'IN)) - (BUILD.IN EXP (CADR KEY))) - ((AND (LISTP KEY) - (EQ (CAR KEY) - 'type?)) - KEY) - (T `(FMEMB ,EXP ',KEY]) - -(BUILD.SELECTQ.SCLAUSE - [LAMBDA (SCLAUSE TYPE) (* kbr%: "25-Nov-85 17:28") - (PROG (KEYS ANSWER) - (SETQ KEYS (CAR SCLAUSE)) - (SETQ KEYS (for KEY in KEYS collect (BUILD.SELECTQ.KEY KEY TYPE))) - [COND - ((NULL (CDR KEYS)) - (SETQ KEYS (CAR KEYS] - (SETQ ANSWER (CONS KEYS (CDR SCLAUSE))) - (RETURN ANSWER]) - -(BUILD.SELECTQ.KEY - [LAMBDA (KEY TYPE) (* kbr%: "25-Nov-85 17:28") - (COND - ((EQ TYPE 'CHARACTER) - (COND - [(LISTP KEY) - (COND - ((EQ (CAR KEY) - 'CHARCODE) - (CADR KEY)) - ((EQ (CAR KEY) - 'IN) - (LIST 'IN (LIST (CAR (CADR KEY)) - (BUILD.SELECTQ.KEY (CADR (CADR KEY)) - 'CHARACTER) - (BUILD.SELECTQ.KEY (CADDR (CADR KEY)) - 'CHARACTER] - (T KEY))) - (T KEY]) - -(BUILD.SELECTTRUEFROM - [LAMBDA (CLAUSES OTHERWISE) (* kbr%: "25-Nov-85 17:28") - (PROG (ANSWER) - (SETQ CLAUSES (for CLAUSE in CLAUSES collect (BUILD.SELECTTRUEFROM.CLAUSE CLAUSE))) - (SETQ ANSWER (COND - [CLAUSES (COND - [OTHERWISE `(COND - ,@CLAUSES - (T ,@(BUILD.TAIL OTHERWISE] - (T `(COND - ,@CLAUSES] - (T OTHERWISE))) - (RETURN ANSWER]) - -(BUILD.SELECTTRUEFROM.CLAUSE - [LAMBDA (CLAUSE) (* kbr%: "25-Nov-85 17:28") - (CONS (BUILD.OR (CAR CLAUSE)) - (CDR CLAUSE]) - -(BUILD.SETQ - [LAMBDA (LHS RHS) (* kbr%: "25-Nov-85 17:28") - (PROG (TYPE ANSWER) - (COND - ((type? ORDERLIST LHS) - (SETQ ANSWER (BUILD.SETQ.ORDERLIST LHS RHS)) - (RETURN ANSWER))) - (SETQ TYPE (BUILD.ULTIMATE.TYPE LHS)) - (SETQ RHS (BUILD.COERCE RHS TYPE)) - [SETQ ANSWER (COND - ((NULL LHS) - RHS) - ((type? MARRAY TYPE) - (BUILD.SETQ.ARRAY LHS RHS)) - [(LISTP LHS) - (SELECTQ (CAR LHS) - (ELT `(SETA ,(CADR LHS) ,(CADDR LHS) ,RHS)) - (fetch `(replace ,@(CDR LHS) with ,RHS)) - (NTHCHARCODE `(RPLCHARCODE ,(CADR LHS) ,(CADDR LHS) ,RHS)) - (PROGN (printout T "Bad setq " LHS " " RHS) - (COND - [(IEQP (LENGTH LHS) - 2) - (COND - [(FIXP (CADR LHS)) - (* Guess array access. - *) - `(SETA ,(CAR LHS) ,(CADR LHS) ,RHS] - (T (* Guess record access. - *) - (BUILD.REPLACE NIL (CAR LHS) - (CADR LHS) - RHS] - (T (* Guess it could be anything. - *) - `(SETQ ,LHS ,RHS] - (T `(SETQ ,LHS ,RHS] - (RETURN ANSWER]) - -(BUILD.SETQ.ARRAY - [LAMBDA (LHS RHS) (* kbr%: "25-Nov-85 17:28") - (* SETQ array LHS. I.e., FILLARRAY. - *) - (PROG (EXPS ANSWER) - (COND - ((NOT (type? ORDERLIST RHS)) - (printout T T "Bad setq array " LHS " " RHS T) - [SETQ ANSWER `(SETQ ,LHS ,RHS] - (RETURN ANSWER))) - (SETQ EXPS (for ORDERITEM in (fetch (ORDERLIST ITEMS) of RHS) as I from 0 - collect (BUILD.SETQ `(ELT ,LHS ,I) ORDERITEM))) - (SETQ ANSWER (BUILD.PROGN EXPS)) - (RETURN ANSWER]) - -(BUILD.SETQ.ORDERLIST - [LAMBDA (ORDERLIST RHS) (* kbr%: "25-Nov-85 17:28") - (* SETQ orderlist ORDERLIST. - *) - (PROG (ORDERITEMS TEMP TEMPPOS EXPS ANSWER) (* Get ORDERITEMS *) - (SETQ ORDERITEMS (fetch (ORDERLIST ITEMS) of ORDERLIST)) - (COND - ((NULL ORDERITEMS) - (RETURN RHS)) - ((NULL (CDR ORDERITEMS)) - [SETQ ANSWER (BUILD.SETQ (CAR ORDERITEMS) - `(CAR ,RHS] - (RETURN ANSWER))) (* Get TEMPorary variable. - *) - (SETQ TEMP (CAR RHS)) - (SETQ TEMPPOS (STRPOS "." TEMP)) - [COND - (TEMPPOS (SETQ TEMP (SUBATOM TEMP (ADD1 TEMPPOS) - -1] (* Get EXPS. *) - [SETQ EXPS (COND - [(ILEQ (LENGTH ORDERITEMS) - 3) - (for ID in ORDERITEMS when ID as ACCESS in '(CAR CADR CADDR) - collect (BUILD.SETQ ID `(,ACCESS ,TEMP] - (T (for ID in ORDERITEMS when ID - collect (BUILD.SETQ ID `(POP ,TEMP] - [push EXPS `(SETQ ,TEMP ,RHS] (* Build PROGN ANSWER. - *) - (SETQ ANSWER (BUILD.PROGN EXPS)) - (RETURN ANSWER]) - -(BUILD.SUB1 - [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:28") - (COND - ((FIXP EXP) - (SUB1 EXP)) - (T `(SUB1 ,EXP]) - -(BUILD.TAIL - [LAMBDA (EXP) (* kbr%: "25-Nov-85 17:28") - (COND - ((NULL EXP) - NIL) - ((AND (LISTP EXP) - (EQ (CAR EXP) - 'PROGN)) - (CDR EXP)) - (T (LIST EXP]) -) -(BUILD.INIT) -(PRETTYCOMPRINT MESATOLISPCOMS) - -(RPAQQ MESATOLISPCOMS - [ - (* ;; "MESATOLISP -- By Kelly Roach. Lyricized by L. Masinter") - - (COMS - -(* ;;; "SCAN: reading mesa/cedar files") - - [INITVARS (SCAN.STRING (CL:MAKE-ARRAY 256 :INITIAL-ELEMENT '#\A :ELEMENT-TYPE - 'CL:CHARACTER :ADJUSTABLE T :FILL-POINTER 0)) - (SCAN.CHAR NIL) - (SCAN.QDOT NIL) - (SCAN.BOTH.RESERVED '(! %# %( %) * + %, - %. |..| / %: ; < <= = => > >= @ ABS - ALL AND ANY APPLY ARRAY BASE BEGIN BROADCAST CODE - COMPUTED CONTINUE DECREASING DEFINITIONS DEPENDENT - DESCRIPTOR DIRECTORY DO ELSE ENABLE END ENDCASE ENDLOOP - ENTRY ERROR EXIT EXITS EXPORTS FINISHED FIRST FOR FORK - FRAME FREE FROM GO GOTO IF IMPORTS IN INLINE INTERNAL - ISTYPE JOIN LAST LENGTH LOCKS LONG LOOP LOOPHOLE MACHINE - MAX MIN MOD MONITOR MONITORED NARROW NEW NILL NOT NOTIFY - NULL OF OPEN OR ORD ORDERED OVERLAID PACKED POINTER PORT - PRED PRIVATE PROC PROCEDURE PROCESS PROGRAM PUBLIC - READONLY RECORD REJECT RELATIVE REPEAT RESTART RESUME - RETRY RETURN RETURNS SELECT SEQUENCE SHARES SIGNAL SIZE - START STATE STOP SUCC THEN THROUGH TO TRANSFER TRASH - TYPE UNCOUNTED UNTIL USING VAL VAR WAIT WHILE WITH ZONE - %[ %] ^ _ { %| } ~)) - (SCAN.CEDAR.RESERVED '(CEDAR CHECKED CONS LIST PAINTED REF SAFE TRUSTED - UNCHECKED UNSAFE)) - (SCAN.MESA.RESERVED '(RESIDENT] - (FNS SCAN.INIT SCAN.START SCAN.TEST SCAN.TESTFILE SCAN.OPENSTREAM SCAN.TOKEN - SCAN.NUMBER SCAN.ACCEPT SCAN.APPENDDECIMAL SCAN.APPENDOCTAL SCAN.APPENDHEX - SCAN.APPENDTOSCALE SCAN.VALIDFRACTION SCAN.DECIMAL SCAN.OCTAL SCAN.OCTALCHAR - SCAN.HEX SCAN.FLOATING SCAN.ESCAPE) - (P (SCAN.INIT))) - (COMS (* ; "PARSE *") - [INITVARS (PARSE.FILELST NIL) - (PARSE.STREAM NIL) - (PARSE.FILECOMS NIL) - (PARSE.LANGUAGE NIL) - (PARSE.DIRLST NIL) - (PARSE.CLASS NIL) - (PARSE.ATOM NIL) - (PARSE.CLASS2 NIL) - (PARSE.ATOM2 NIL) - (PARSE.CASEHEAD.FIRST '(WITH SELECT)) - (PARSE.DEFHEAD.FIRST '(DEFINITIONS)) - (PARSE.DEPENDENT.FIRST '(MACHINE)) - (PARSE.DOTEST.FIRST '(UNTIL WHILE)) - (PARSE.FORCLAUSE.FIRST '(FOR THROUGH)) - (PARSE.HEAP.FIRST '(UNCOUNTED)) - (PARSE.INTERVAL.FIRST '(%( %[)) - (PARSE.OPTRELATION.FIRST '(%# < <= = > >= IN NOT ~)) - (PARSE.ORDERED.FIRST '(ORDERED)) - (PARSE.ORDERLIST.FOLLOW '(! ; END %] })) - (PARSE.PACKED.FIRST '(PACKED)) - (PARSE.PREFIXOP.FIRST '(ABS BASE LENGTH LONG MAX MIN ORD PRED SUCC)) - (PARSE.PROGHEAD.FIRST '(MONITOR PROGRAM RESIDENT)) - (PARSE.QUALIFIER.FIRST '(%. %[ ^)) - (PARSE.RANGE.FOLLOW '(! %) %, |..| %: ; => AND DO ELSE END ENDCASE ENDLOOP EXITS - FINISHED FROM NULL OR REPEAT SELECT THEN TRASH UNTIL - WHILE %] })) - (PARSE.TRANSFER.FIRST '(BROADCAST ERROR JOIN NOTIFY RESTART RETURN SIGNAL START - TRANSFER)) - (PARSE.TRANSFERMODE.FIRST '(ERROR PORT PROCESS PROGRAM SIGNAL)) - (PARSE.TRANSFEROP.FIRST '(ERROR FORK JOIN NEW SIGNAL START)) - (PARSE.TYPECONS.FIRST '(%( ARRAY BASE DESCRIPTOR ERROR FRAME LONG MACHINE - MONITORED ORDERED PACKED POINTER PORT PROC PORCEDURE - PROCESS PROGRAM RECORD SIGNAL UNCOUNTED VAR %[ {)) - (PARSE.TYPEOP.FIRST '(FIRST LAST NILL)) - (PARSE.VARIANTPART.FIRST '(PACKED SELECT SEQUENCE)) - (PARSE.CATCHLIST.FOLLOW '(END %] })) - (PARSE.CONTROLID.FOLLOW '(DECREASING IN _)) - (PARSE.DECLIST.FOLLOW '(; END })) - (PARSE.DEFAULTOPT.FOLLOW '(%, ; END %] })) - (PARSE.EXITLIST.FOLLOW '(END ENDLOOP FINISHED })) - (PARSE.MODULELIST.FOLLOW '(IEQP EXPORTS SHARES)) - (PARSE.OPTARGS.FOLLOW '(; ELSE END ENDCASE ENDLOOP EXITS FINISHED REPEAT %] })) - (PARSE.OPTEXP.FOLLOW '(! %, ; END FROM %] })) - (PARSE.SCOPE.FOLLOW '(END EXITS })) - (PARSE.STATEMENTLIST.FOLLOW '(END ENDLOOP EXITS REPEAT })) - (PARSE.TYPEEXP.FOLLOW '(! %, ; = => DECREASING END EXPORTS FROM IMPORTS IN OF - SHARES %] _ })) - (PARSE.PREDEFINED.TYPES '(ATOM BOOL BOOLEAN CARDINAL CHAR CHARACTER CONDITION - INT INTEGER MDSZone MONITORLOCK NAT REAL STRING - StringBody UNSPECIFIED WORD)) - (PARSE.RELOPS (LIST '= '%# '< '<= '> '>=)) - (PARSE.ADDOPS (LIST '+ '-)) - (PARSE.MULTOPS (LIST '* '/ 'MOD)) - (PARSE.TRANSFEROPS '(SIGNAL ERROR START JOIN NEW FORK)) - (PARSE.PREFIXOPS '(LONG ABS PRED SUCC ORD MIN MAX BASE LENGTH)) - (PARSE.TYPEOPS '(FIRST LAST NILL)) - (PARSE.NOTS '(~ NOT] - (RECORDS PARSERSTATE MINTERVAL MRANGE MRELATIVE MPAINTED MENUMERATED MRECORD MVAR - MARRAY MDESCRIPTOR MFRAME MREF MLIST PAIRITEM DEFAULT TYPELIST TYPEITEM MPOINTER - CASEHEAD BINDITEM KEYITEM FIELDLIST PAIRLIST ORDERLIST KEYLIST EXPLIST) - (FNS PARSE.MESA PARSE.CEDAR PARSE.FILE PARSE.GET.STATE PARSE.SET.STATE PARSE.BIN - PARSE.VARID PARSE.SMURF PARSE.THISIS.MESA PARSE.THISIS.CEDAR PARSE.MODULE - PARSE.INCLUDEITEM PARSE.INCLUDECHECK PARSE.SEADIRT PARSE.PROGHEAD PARSE.RESIDENT - PARSE.SAFE PARSE.DEFHEAD PARSE.TILDE PARSE.DEFINITIONS PARSE.DEFBODY PARSE.LOCKS - PARSE.LAMBDA PARSE.MODULEITEM PARSE.DECLARATION PARSE.PUBLIC PARSE.ENTRY - PARSE.IDLIST PARSE.IDENTLIST PARSE.POSITION PARSE.OPTBITS PARSE.INTERVAL - PARSE.TYPEEXP.HERE PARSE.TYPEEXP PARSE.RANGE PARSE.TYPEAPPL PARSE.TYPEAPPL.CONT - PARSE.TYPEID PARSE.TYPEID.CONT PARSE.TYPECONS PARSE.TYPECONS1 PARSE.TYPECONS.CONT - PARSE.TYPECONS.RANGE PARSE.TYPECONS.RELATIVE PARSE.TYPECONS.PAINTED - PARSE.TYPECONS2 PARSE.TYPECONS.INTERVAL PARSE.TYPECONS.DEPENDENT - PARSE.TYPECONS.ENUMERATED PARSE.TYPECONS.RECORD PARSE.TYPECONS.ORDERED - PARSE.TYPECONS.VAR PARSE.TYPECONS.PACKED PARSE.TYPECONS.DESCRIPTOR - PARSE.TYPECONS.SAFE PARSE.TYPECONS.HEAP PARSE.TYPECONS.LONG PARSE.TYPECONS.FRAME - PARSE.TYPECONS.REF PARSE.TYPECONS.LIST PARSE.IDENT PARSE.ELEMENT PARSE.MONITORED - PARSE.DEPENDENT PARSE.RECLIST PARSE.VARIANTPAIR PARSE.PAIRITEM PARSE.DEFAULTOPT - PARSE.VARIANTPART PARSE.VCASEHEAD PARSE.TAGTYPE PARSE.VARIANTITEM PARSE.TYPELIST - PARSE.TYPEITEM PARSE.POINTERTYPE PARSE.TRANSFERMODE PARSE.INITIALIZATION - PARSE.INITVALUE PARSE.CHECKED PARSE.CODELIST PARSE.STATEMENT PARSE.STATEMENT1 - PARSE.STATEMENT2 PARSE.STATEMENT.CASEHEAD PARSE.STATEMENT.FORCLAUSE - PARSE.STATEMENT.RETURN PARSE.STATEMENT.TRANSFER PARSE.STATEMENT.LBRACKET - PARSE.STATEMENT.IF PARSE.BLOCK PARSE.SCOPE PARSE.BINDITEM PARSE.EXITS - PARSE.CASESTMTITEM PARSE.CASEEXPITEM PARSE.EXITITEM PARSE.CASETEST PARSE.CONTROLID - PARSE.FORCLAUSE PARSE.DIRECTION PARSE.DOTEST PARSE.DOEXIT PARSE.ENABLES - PARSE.CATCHLIST PARSE.CATCHCASE PARSE.OPTARGS PARSE.TRANSFER PARSE.KEYITEM - PARSE.OPTEXP PARSE.EXP PARSE.EXP1 PARSE.EXP2 PARSE.EXP.TRANSFEROP PARSE.EXP.IF - PARSE.EXP.CASEHEAD PARSE.EXP.LHS PARSE.EXP.LBRACKET PARSE.EXP.ERROR - PARSE.EXP.DISJUNCT PARSE.DISJUNCT PARSE.CONJUNCT PARSE.NEGATION PARSE.RELATION - PARSE.SUM PARSE.PRODUCT PARSE.OPTRELATION PARSE.RELATIONTAIL PARSE.RELOP - PARSE.ADDOP PARSE.MULTOP PARSE.FACTOR PARSE.PRIMARY PARSE.ATOM PARSE.PRIMARY.NIL - PARSE.PRIMARY.LBRACKET PARSE.PRIMARY.PREFIXOP PARSE.PRIMARY.VAL PARSE.PRIMARY.ALL - PARSE.PRIMARY.NEW PARSE.PRIMARY.TYPEOP PARSE.PRIMARY.SIZE PARSE.PRIMARY.ISTYPE - PARSE.PRIMARY.AT PARSE.PRIMARY.DESCRIPTOR PARSE.PRIMARY.CONS PARSE.PRIMARY.LIST - PARSE.PRIMARY.LHS PARSE.PRIMARY.LHS.NEW PARSE.PRIMARY.LHS.CONS - PARSE.PRIMARY.LHS.LIST PARSE.QUALIFIER PARSE.LHS PARSE.QUALIFIER.HERE - PARSE.OPTCATCH PARSE.TRANSFEROP PARSE.PREFIXOP PARSE.TYPEOP PARSE.DESCLIST - PARSE.DIRECTORY PARSE.IMPORTS PARSE.POINTERPREFIX PARSE.EXPORTS PARSE.FIELDLIST - PARSE.USING PARSE.CATCHHEAD PARSE.DECLIST PARSE.PAIRLIST PARSE.VARIANTLIST - PARSE.ORDERLIST PARSE.LHSLIST PARSE.INCLUDELIST PARSE.MODULELIST PARSE.ELEMENTLIST - PARSE.BINDLIST PARSE.STATEMENTLIST PARSE.CASESTMTLIST PARSE.CASELABEL - PARSE.EXITLIST PARSE.KEYLIST PARSE.CASEEXPLIST PARSE.EXPLIST PARSE.OPEN - PARSE.CLASS PARSE.CASEHEAD PARSE.READONLY PARSE.ORDERED PARSE.BASE PARSE.PACKED - PARSE.HEAP PARSE.INLINE PARSE.ARGUMENTS PARSE.INTERFACE PARSE.SHARES PARSE.DEFAULT - PARSE.OPTSIZE PARSE.BOUNDS PARSE.LENGTH PARSE.INDEXTYPE PARSE.ELSEPART - PARSE.OTHERPART PARSE.FREE PARSE.CATCHANY PARSE.NOT PARSE.NEW PARSE.OPTTYPE - PARSE.ARGLIST PARSE.RETURNLIST)) - (COMS - - (* ;; "BUILD ") - - [INITVARS (BUILD.NEXT.SCOPE NIL) - (BUILD.CURRENT.SCOPE NIL) - (BUILD.SCOPE.STACK NIL) - (BUILD.PREFIX NIL) - (BUILD.FILECOMS NIL) - (BUILD.BOOLEAN.FNS '(AND OR NOT type? IGREATERP ILESSP IGEQ ILEQ IEQP ZEROP - MINUSP EVENP ODDP FGREATERP FLESSP FEQP GREATERP LESSP - GEQ LEQ)) - (BUILD.CARDINAL.FNS '(ADD1 CHARCODE FIX GCD IDIFFERENCE IMAX IMIN IMINUS IMOD - IPLUS IQUOTIENT IREMAINDER ITIMES LOGAND LOGNOT LOGOR - LOGXOR NTHCHARCODE SUB1)) - (BUILD.MIXED.FNS '(ABS DIFFERENCE EXPT MAX MIN MINUS MOD PLUS QUOTIENT REMAINDER - TIMES)) - (BUILD.REAL.FNS '(ANTILOG ARCCOS ARCSIN ARCTAN ARCTAN2 COS FDIFFERENCE FLOAT - FMAX FMIN FMINUS FMOD FPLUS FQUOTIENT FREMAINDER FTIMES - LOG SIN SQRT TAN)) - (BUILD.QUALIFY.WORDS '(FREE NEW SIZE)) - [BUILD.CARDINAL.ARITHOP.ALIST (LIST (CONS '= 'IEQP) - (CONS '%# 'IEQP) - (CONS '< 'ILESSP) - (CONS '<= 'ILEQ) - (CONS '> 'IGREATERP) - (CONS '>= 'IGEQ) - (CONS '+ 'IPLUS) - (CONS '- 'IDIFFERENCE) - (CONS '* 'ITIMES) - (CONS '/ 'IQUOTIENT) - (CONS '0- 'IMINUS) - (CONS 'MAX 'IMAX) - (CONS 'MIN 'IMIN) - (CONS 'MOD 'IMOD] - [BUILD.MIXED.ARITHOP.ALIST (LIST (CONS '= 'EQP) - (CONS '%# 'EQP) - (CONS '< 'LESSP) - (CONS '<= 'GREATERP) - (CONS '> 'GREATERP) - (CONS '>= 'LESSP) - (CONS '+ 'PLUS) - (CONS '- 'DIFFERENCE) - (CONS '* 'TIMES) - (CONS '/ 'QUOTIENT) - (CONS '0- 'MINUS) - (CONS 'MAX 'MAX) - (CONS 'MIN 'MIN) - (CONS 'MOD 'IMOD] - [BUILD.REAL.ARITHOP.ALIST (LIST (CONS '= 'FEQP) - (CONS '%# 'FEQP) - (CONS '< 'FLESSP) - (CONS '<= 'FGREATERP) - (CONS '> 'FGREATERP) - (CONS '>= 'FLESSP) - (CONS '+ 'FPLUS) - (CONS '- 'FDIFFERENCE) - (CONS '* 'FTIMES) - (CONS '/ 'FQUOTIENT) - (CONS '0- 'FMINUS) - (CONS 'MAX 'FMAX) - (CONS 'MIN 'FMIN) - (CONS 'MOD 'IMOD] - (BUILD.CARDINAL.TYPES '(CARDINAL CHAR CHARACTER INT INTEGER NAT WORD] - (RECORDS SCOPE) - (FNS BUILD.INIT BUILD.PUSH.SCOPE BUILD.POP.SCOPE BUILD.GC.SCOPE BUILD.STORE.EXPORTS - BUILD.STORE.IDENTLIST BUILD.STORE.INTERFACES BUILD.STORE.INTERFACE - BUILD.STORE.OPEN BUILD.STORE.USING BUILD.INITIALIZATION BUILD.INITIALIZE.VARS - BUILD.INITIALIZE.VAR BUILD.INITIALIZE.FN BUILD.INITIALIZE.RECORD BUILD.RECORD - BUILD.TYPE BUILD.STORE.ARGLIST BUILD.STORE.RETURNLIST BUILD.STORE.PAIRLIST - BUILD.STORE.PAIRITEM BUILD.STORE.VARLIST BUILD.ID BUILD.FIELDID BUILD.PROCID - BUILD.RECORDID BUILD.TYPEID BUILD.VARID BUILD.LOCALVARID BUILD.GLOBALVARID - BUILD.ULTIMATE.TYPE BUILD.REFINE.TYPE BUILD.IMMEDIATE.TYPE BUILD.LOOKUP.TYPE - BUILD.LOOKUP BUILD.TYPEATOM BUILD.QUALIFY BUILD.QUALIFY.PREFIXOP - BUILD.QUALIFY.TYPEOP BUILD.QUALIFY.EXPLIST BUILD.QUALIFY.ID BUILD.ARITH.EXP1 - BUILD.ARITH.EXP2 BUILD.ARITH.EXP* BUILD.ARITH.ADD1SUB1 BUILD.COERCE.ARITHOP - BUILD.STRONGEST.TYPE.AMONG BUILD.STRONGEST.TYPE BUILD.COERCE BUILD.COERCE.MARRAY - BUILD.COERCE.MLIST BUILD.COERCE.EXPLIST BUILD.ALIGN BUILD.ALIGN.VALUE - BUILD.ADD.TO.FILECOMS BUILD.ADD1 BUILD.CALL BUILD.CHARCODE BUILD.COND - BUILD.COPY.OF BUILD.FETCH BUILD.FORCLAUSE.BY BUILD.FORCLAUSE.IN - BUILD.FORCLAUSE.THROUGH BUILD.IN BUILD.ISTYPE BUILD.LAMBDA BUILD.NEW BUILD.OR - BUILD.PROG BUILD.PROGN BUILD.REPLACE BUILD.RETURN BUILD.SELECTQ BUILD.SELECTQ.FN - BUILD.SELECTQ.CCLAUSE BUILD.SELECTQ.TEST BUILD.SELECTQ.SCLAUSE BUILD.SELECTQ.KEY - BUILD.SELECTTRUEFROM BUILD.SELECTTRUEFROM.CLAUSE BUILD.SETQ BUILD.SETQ.ARRAY - BUILD.SETQ.ORDERLIST BUILD.SUB1 BUILD.TAIL) - (P (BUILD.INIT))) - (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) - (NLAML) - (LAMA PARSE.BIN - PARSE.FILE - PARSE.CEDAR]) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS - -(ADDTOVAR NLAMA ) - -(ADDTOVAR NLAML ) - -(ADDTOVAR LAMA PARSE.BIN PARSE.FILE PARSE.CEDAR) -) -(PUTPROPS MESATOLISP COPYRIGHT ("Xerox Corporation" 1985 1987)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (19182 54761 (SCAN.INIT 19192 . 19601) (SCAN.START 19603 . 19785) (SCAN.TEST 19787 . -20251) (SCAN.TESTFILE 20253 . 20746) (SCAN.OPENSTREAM 20748 . 21252) (SCAN.TOKEN 21254 . 32584) ( -SCAN.NUMBER 32586 . 36881) (SCAN.ACCEPT 36883 . 37101) (SCAN.APPENDDECIMAL 37103 . 37792) ( -SCAN.APPENDOCTAL 37794 . 38356) (SCAN.APPENDHEX 38358 . 39122) (SCAN.APPENDTOSCALE 39124 . 39808) ( -SCAN.VALIDFRACTION 39810 . 40403) (SCAN.DECIMAL 40405 . 42476) (SCAN.OCTAL 42478 . 44543) ( -SCAN.OCTALCHAR 44545 . 45852) (SCAN.HEX 45854 . 48496) (SCAN.FLOATING 48498 . 52403) (SCAN.ESCAPE -52405 . 54759)) (59379 203256 (PARSE.MESA 59389 . 59541) (PARSE.CEDAR 59543 . 59715) (PARSE.FILE 59717 - . 60284) (PARSE.GET.STATE 60286 . 61074) (PARSE.SET.STATE 61076 . 62387) (PARSE.BIN 62389 . 63223) ( -PARSE.VARID 63225 . 63384) (PARSE.SMURF 63386 . 64515) (PARSE.THISIS.MESA 64517 . 64797) ( -PARSE.THISIS.CEDAR 64799 . 65082) (PARSE.MODULE 65084 . 66127) (PARSE.INCLUDEITEM 66129 . 67429) ( -PARSE.INCLUDECHECK 67431 . 68401) (PARSE.SEADIRT 68403 . 68792) (PARSE.PROGHEAD 68794 . 69523) ( -PARSE.RESIDENT 69525 . 69925) (PARSE.SAFE 69927 . 70400) (PARSE.DEFHEAD 70402 . 70889) (PARSE.TILDE -70891 . 71346) (PARSE.DEFINITIONS 71348 . 71585) (PARSE.DEFBODY 71587 . 72486) (PARSE.LOCKS 72488 . -72925) (PARSE.LAMBDA 72927 . 73472) (PARSE.MODULEITEM 73474 . 74008) (PARSE.DECLARATION 74010 . 76112) - (PARSE.PUBLIC 76114 . 76485) (PARSE.ENTRY 76487 . 76854) (PARSE.IDLIST 76856 . 77416) ( -PARSE.IDENTLIST 77418 . 79049) (PARSE.POSITION 79051 . 79489) (PARSE.OPTBITS 79491 . 79866) ( -PARSE.INTERVAL 79868 . 81120) (PARSE.TYPEEXP.HERE 81122 . 81252) (PARSE.TYPEEXP 81254 . 82083) ( -PARSE.RANGE 82085 . 83410) (PARSE.TYPEAPPL 83412 . 83919) (PARSE.TYPEAPPL.CONT 83921 . 84674) ( -PARSE.TYPEID 84676 . 84838) (PARSE.TYPEID.CONT 84840 . 85782) (PARSE.TYPECONS 85784 . 86003) ( -PARSE.TYPECONS1 86005 . 87479) (PARSE.TYPECONS.CONT 87481 . 89721) (PARSE.TYPECONS.RANGE 89723 . 90085 -) (PARSE.TYPECONS.RELATIVE 90087 . 90476) (PARSE.TYPECONS.PAINTED 90478 . 90900) (PARSE.TYPECONS2 -90902 . 93362) (PARSE.TYPECONS.INTERVAL 93364 . 93760) (PARSE.TYPECONS.DEPENDENT 93762 . 94424) ( -PARSE.TYPECONS.ENUMERATED 94426 . 94800) (PARSE.TYPECONS.RECORD 94802 . 95191) (PARSE.TYPECONS.ORDERED - 95193 . 95622) (PARSE.TYPECONS.VAR 95624 . 96022) (PARSE.TYPECONS.PACKED 96024 . 96691) ( -PARSE.TYPECONS.DESCRIPTOR 96693 . 97260) (PARSE.TYPECONS.SAFE 97262 . 97706) (PARSE.TYPECONS.HEAP -97708 . 98006) (PARSE.TYPECONS.LONG 98008 . 98327) (PARSE.TYPECONS.FRAME 98329 . 98807) ( -PARSE.TYPECONS.REF 98809 . 99718) (PARSE.TYPECONS.LIST 99720 . 100302) (PARSE.IDENT 100304 . 100807) ( -PARSE.ELEMENT 100809 . 101464) (PARSE.MONITORED 101466 . 101823) (PARSE.DEPENDENT 101825 . 102251) ( -PARSE.RECLIST 102253 . 104422) (PARSE.VARIANTPAIR 104424 . 105219) (PARSE.PAIRITEM 105221 . 106764) ( -PARSE.DEFAULTOPT 106766 . 107902) (PARSE.VARIANTPART 107904 . 109341) (PARSE.VCASEHEAD 109343 . 110179 -) (PARSE.TAGTYPE 110181 . 110490) (PARSE.VARIANTITEM 110492 . 110918) (PARSE.TYPELIST 110920 . 112135) - (PARSE.TYPEITEM 112137 . 112690) (PARSE.POINTERTYPE 112692 . 113443) (PARSE.TRANSFERMODE 113445 . -114181) (PARSE.INITIALIZATION 114183 . 115006) (PARSE.INITVALUE 115008 . 116738) (PARSE.CHECKED 116740 - . 117329) (PARSE.CODELIST 117331 . 117727) (PARSE.STATEMENT 117729 . 117959) (PARSE.STATEMENT1 117961 - . 119184) (PARSE.STATEMENT2 119186 . 122631) (PARSE.STATEMENT.CASEHEAD 122633 . 123653) ( -PARSE.STATEMENT.FORCLAUSE 123655 . 124768) (PARSE.STATEMENT.RETURN 124770 . 125149) ( -PARSE.STATEMENT.TRANSFER 125151 . 125525) (PARSE.STATEMENT.LBRACKET 125527 . 126007) ( -PARSE.STATEMENT.IF 126009 . 126595) (PARSE.BLOCK 126597 . 127191) (PARSE.SCOPE 127193 . 127945) ( -PARSE.BINDITEM 127947 . 128924) (PARSE.EXITS 128926 . 129301) (PARSE.CASESTMTITEM 129303 . 129821) ( -PARSE.CASEEXPITEM 129823 . 130249) (PARSE.EXITITEM 130251 . 130699) (PARSE.CASETEST 130701 . 131268) ( -PARSE.CONTROLID 131270 . 131909) (PARSE.FORCLAUSE 131911 . 133290) (PARSE.DIRECTION 133292 . 133651) ( -PARSE.DOTEST 133653 . 134147) (PARSE.DOEXIT 134149 . 135169) (PARSE.ENABLES 135171 . 136397) ( -PARSE.CATCHLIST 136399 . 137433) (PARSE.CATCHCASE 137435 . 137867) (PARSE.OPTARGS 137869 . 138471) ( -PARSE.TRANSFER 138473 . 139189) (PARSE.KEYITEM 139191 . 139969) (PARSE.OPTEXP 139971 . 140612) ( -PARSE.EXP 140614 . 140818) (PARSE.EXP1 140820 . 141490) (PARSE.EXP2 141492 . 143831) ( -PARSE.EXP.TRANSFEROP 143833 . 144203) (PARSE.EXP.IF 144205 . 144712) (PARSE.EXP.CASEHEAD 144714 . -145311) (PARSE.EXP.LHS 145313 . 145686) (PARSE.EXP.LBRACKET 145688 . 146148) (PARSE.EXP.ERROR 146150 - . 146394) (PARSE.EXP.DISJUNCT 146396 . 146628) (PARSE.DISJUNCT 146630 . 147337) (PARSE.CONJUNCT -147339 . 148050) (PARSE.NEGATION 148052 . 148582) (PARSE.RELATION 148584 . 149671) (PARSE.SUM 149673 - . 151062) (PARSE.PRODUCT 151064 . 152814) (PARSE.OPTRELATION 152816 . 153620) (PARSE.RELATIONTAIL -153622 . 154261) (PARSE.RELOP 154263 . 154661) (PARSE.ADDOP 154663 . 154888) (PARSE.MULTOP 154890 . -155196) (PARSE.FACTOR 155198 . 155767) (PARSE.PRIMARY 155769 . 158651) (PARSE.ATOM 158653 . 158899) ( -PARSE.PRIMARY.NIL 158901 . 159141) (PARSE.PRIMARY.LBRACKET 159143 . 159493) (PARSE.PRIMARY.PREFIXOP -159495 . 160061) (PARSE.PRIMARY.VAL 160063 . 160533) (PARSE.PRIMARY.ALL 160535 . 161005) ( -PARSE.PRIMARY.NEW 161007 . 161626) (PARSE.PRIMARY.TYPEOP 161628 . 162073) (PARSE.PRIMARY.SIZE 162075 - . 162835) (PARSE.PRIMARY.ISTYPE 162837 . 163453) (PARSE.PRIMARY.AT 163455 . 163781) ( -PARSE.PRIMARY.DESCRIPTOR 163783 . 164306) (PARSE.PRIMARY.CONS 164308 . 164919) (PARSE.PRIMARY.LIST -164921 . 165492) (PARSE.PRIMARY.LHS 165494 . 166806) (PARSE.PRIMARY.LHS.NEW 166808 . 167439) ( -PARSE.PRIMARY.LHS.CONS 167441 . 167987) (PARSE.PRIMARY.LHS.LIST 167989 . 168499) (PARSE.QUALIFIER -168501 . 170328) (PARSE.LHS 170330 . 172571) (PARSE.QUALIFIER.HERE 172573 . 172955) (PARSE.OPTCATCH -172957 . 173398) (PARSE.TRANSFEROP 173400 . 173916) (PARSE.PREFIXOP 173918 . 174257) (PARSE.TYPEOP -174259 . 174743) (PARSE.DESCLIST 174745 . 175423) (PARSE.DIRECTORY 175425 . 176044) (PARSE.IMPORTS -176046 . 176542) (PARSE.POINTERPREFIX 176544 . 177053) (PARSE.EXPORTS 177055 . 177576) ( -PARSE.FIELDLIST 177578 . 178417) (PARSE.USING 178419 . 179118) (PARSE.CATCHHEAD 179120 . 179975) ( -PARSE.DECLIST 179977 . 180828) (PARSE.PAIRLIST 180830 . 181860) (PARSE.VARIANTLIST 181862 . 182556) ( -PARSE.ORDERLIST 182558 . 183281) (PARSE.LHSLIST 183283 . 183820) (PARSE.INCLUDELIST 183822 . 184373) ( -PARSE.MODULELIST 184375 . 185140) (PARSE.ELEMENTLIST 185142 . 185722) (PARSE.BINDLIST 185724 . 186299) - (PARSE.STATEMENTLIST 186301 . 187188) (PARSE.CASESTMTLIST 187190 . 187990) (PARSE.CASELABEL 187992 . -189129) (PARSE.EXITLIST 189131 . 189981) (PARSE.KEYLIST 189983 . 190606) (PARSE.CASEEXPLIST 190608 . -191400) (PARSE.EXPLIST 191402 . 191952) (PARSE.OPEN 191954 . 192427) (PARSE.CLASS 192429 . 192684) ( -PARSE.CASEHEAD 192686 . 193790) (PARSE.READONLY 193792 . 194144) (PARSE.ORDERED 194146 . 194493) ( -PARSE.BASE 194495 . 194762) (PARSE.PACKED 194764 . 195041) (PARSE.HEAP 195043 . 195438) (PARSE.INLINE -195440 . 195717) (PARSE.ARGUMENTS 195719 . 196002) (PARSE.INTERFACE 196004 . 196383) (PARSE.SHARES -196385 . 196773) (PARSE.DEFAULT 196775 . 197152) (PARSE.OPTSIZE 197154 . 197651) (PARSE.BOUNDS 197653 - . 198036) (PARSE.LENGTH 198038 . 198394) (PARSE.INDEXTYPE 198396 . 198754) (PARSE.ELSEPART 198756 . -199140) (PARSE.OTHERPART 199142 . 199525) (PARSE.FREE 199527 . 199896) (PARSE.CATCHANY 199898 . 200296 -) (PARSE.NOT 200298 . 200519) (PARSE.NEW 200521 . 201189) (PARSE.OPTTYPE 201191 . 201581) ( -PARSE.ARGLIST 201583 . 202361) (PARSE.RETURNLIST 202363 . 203254)) (207200 267345 (BUILD.INIT 207210 - . 207712) (BUILD.PUSH.SCOPE 207714 . 208097) (BUILD.POP.SCOPE 208099 . 208389) (BUILD.GC.SCOPE 208391 - . 208574) (BUILD.STORE.EXPORTS 208576 . 208783) (BUILD.STORE.IDENTLIST 208785 . 209006) ( -BUILD.STORE.INTERFACES 209008 . 209239) (BUILD.STORE.INTERFACE 209241 . 209427) (BUILD.STORE.OPEN -209429 . 209637) (BUILD.STORE.USING 209639 . 209853) (BUILD.INITIALIZATION 209855 . 210452) ( -BUILD.INITIALIZE.VARS 210454 . 210808) (BUILD.INITIALIZE.VAR 210810 . 211603) (BUILD.INITIALIZE.FN -211605 . 212407) (BUILD.INITIALIZE.RECORD 212409 . 212996) (BUILD.RECORD 212998 . 215217) (BUILD.TYPE -215219 . 215849) (BUILD.STORE.ARGLIST 215851 . 216355) (BUILD.STORE.RETURNLIST 216357 . 216879) ( -BUILD.STORE.PAIRLIST 216881 . 217427) (BUILD.STORE.PAIRITEM 217429 . 217821) (BUILD.STORE.VARLIST -217823 . 218043) (BUILD.ID 218045 . 218468) (BUILD.FIELDID 218470 . 218594) (BUILD.PROCID 218596 . -218743) (BUILD.RECORDID 218745 . 218894) (BUILD.TYPEID 218896 . 219113) (BUILD.VARID 219115 . 219482) -(BUILD.LOCALVARID 219484 . 219611) (BUILD.GLOBALVARID 219613 . 219765) (BUILD.ULTIMATE.TYPE 219767 . -219947) (BUILD.REFINE.TYPE 219949 . 221606) (BUILD.IMMEDIATE.TYPE 221608 . 225952) (BUILD.LOOKUP.TYPE -225954 . 226724) (BUILD.LOOKUP 226726 . 227111) (BUILD.TYPEATOM 227113 . 227307) (BUILD.QUALIFY 227309 - . 228793) (BUILD.QUALIFY.PREFIXOP 228795 . 229043) (BUILD.QUALIFY.TYPEOP 229045 . 229193) ( -BUILD.QUALIFY.EXPLIST 229195 . 231109) (BUILD.QUALIFY.ID 231111 . 232833) (BUILD.ARITH.EXP1 232835 . -233061) (BUILD.ARITH.EXP2 233063 . 233299) (BUILD.ARITH.EXP* 233301 . 234455) (BUILD.ARITH.ADD1SUB1 -234457 . 235388) (BUILD.COERCE.ARITHOP 235390 . 235746) (BUILD.STRONGEST.TYPE.AMONG 235748 . 236236) ( -BUILD.STRONGEST.TYPE 236238 . 236817) (BUILD.COERCE 236819 . 237582) (BUILD.COERCE.MARRAY 237584 . -238513) (BUILD.COERCE.MLIST 238515 . 239360) (BUILD.COERCE.EXPLIST 239362 . 241622) (BUILD.ALIGN -241624 . 244083) (BUILD.ALIGN.VALUE 244085 . 244593) (BUILD.ADD.TO.FILECOMS 244595 . 245242) ( -BUILD.ADD1 245244 . 245429) (BUILD.CALL 245431 . 245736) (BUILD.CHARCODE 245738 . 247182) (BUILD.COND -247184 . 247823) (BUILD.COPY.OF 247825 . 248069) (BUILD.FETCH 248071 . 248805) (BUILD.FORCLAUSE.BY -248807 . 248975) (BUILD.FORCLAUSE.IN 248977 . 249971) (BUILD.FORCLAUSE.THROUGH 249973 . 250141) ( -BUILD.IN 250143 . 251232) (BUILD.ISTYPE 251234 . 251790) (BUILD.LAMBDA 251792 . 252244) (BUILD.NEW -252246 . 252404) (BUILD.OR 252406 . 252627) (BUILD.PROG 252629 . 253951) (BUILD.PROGN 253953 . 254234) - (BUILD.REPLACE 254236 . 255039) (BUILD.RETURN 255041 . 256699) (BUILD.SELECTQ 256701 . 258976) ( -BUILD.SELECTQ.FN 258978 . 259175) (BUILD.SELECTQ.CCLAUSE 259177 . 259801) (BUILD.SELECTQ.TEST 259803 - . 260169) (BUILD.SELECTQ.SCLAUSE 260171 . 260608) (BUILD.SELECTQ.KEY 260610 . 261303) ( -BUILD.SELECTTRUEFROM 261305 . 262003) (BUILD.SELECTTRUEFROM.CLAUSE 262005 . 262196) (BUILD.SETQ 262198 - . 264370) (BUILD.SETQ.ARRAY 264372 . 265145) (BUILD.SETQ.ORDERLIST 265147 . 266881) (BUILD.SUB1 -266883 . 267068) (BUILD.TAIL 267070 . 267343))))) -STOP diff --git a/obsolete/lispusers/MICROTEK b/obsolete/lispusers/MICROTEK deleted file mode 100644 index 59a68a15..00000000 --- a/obsolete/lispusers/MICROTEK +++ /dev/null @@ -1,344 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED " 8-Sep-88 21:43:21" {LISPUSERS}MICROTEK.\;1 63396 - - |changes| |to:| (FNS MT.START.SCANNING MT.SETUPSCANFILE MT.INIT MT.SHRINKFN MICROTEKSCANNER RULERX RULEX# RULERY RULEY# MT.GETLENGTH MT.CURSOR.IN MT.CURSOR.OUT MT.PRINT.STATUS MT.CHANGE.BRIGHTBAR MT.CHANGE.CONTRASTBAR MT.DRAWAREABOX MT.COMMAND.MENU MT.SCAN MT.SENDCOMMAND MT.COMPUTECHECKSUM MT.SENDACK MT.SENDNAK MT.STOP.SCANNING MT.PAGEMAP MT.QUIT MT.DISPLAY.MENU MT.CREATEBM MT.BITMAPCREATE MT.CONVERTIMAGETOBM MT.CREATE.BIG.BM MT.REPAINTWINDOW MT.RESHAPEWINDOW MT.SEND.SCAN.PARAMETERS MT.PRINT.ERROR.MSG MT.RESET) - (PROPS (MICROTEK MAKEFILE-ENVIRONMENT)) - - |previous| |date:| "23-Jul-88 15:16:49" {PHYLUM}MEDLEY>MICROTEK.\;1) - - -; Copyright (c) 1987, 1988 by XEROX Corporation. All rights reserved. - -(PRETTYCOMPRINT MICROTEKCOMS) - -(RPAQQ MICROTEKCOMS ((P (FILESLOAD DLRS232C EDITBITMAP)) (* * |Microtek| |Initialization| |and| |Menu| |Functions|) (FNS MT.INIT MT.SHRINKFN MICROTEKSCANNER RULERX RULEX# RULERY RULEY# MT.GETLENGTH MT.CURSOR.IN MT.CURSOR.OUT MT.PRINT.STATUS MT.CONTROL.MENU MT.CHANGE.BRIGHTBAR MT.RAISEBRIGHTNESS MT.LOWERBRIGHTNESS MT.CHANGE.CONTRASTBAR MT.RAISECONTRAST MT.LOWERCONTRAST MT.SELECT.BACKGROUND MT.GETTRANSFRAME MT.GETWINDOW1 MT.GETWINDOW2 MT.GETWINDOW3 MT.GETWINDOW4 MT.UPDATE.HTWINDOWS MT.DRAWAREABOX) (* * |Command| |Functions|) (FNS MT.COMMAND.MENU MT.GET.OUTFILENAME MT.SCAN MT.START.SCANNING MT.SETUPSCANFILE MT.SEND.SCAN.PARAMETERS MT.SENDCOMMAND MT.COMPUTECHECKSUM MT.PRINT.ERROR.MSG MT.SENDACK MT.SENDNAK MT.STOP.SCANNING MT.RESET MT.PAGEMAP MT.QUIT) (* * |Functions| |to| |convert| |and| |print| |scanned| |images|) (FNS MT.DISPLAY.MENU MT.GET.SOURCEFILENAME MT.GET.BITMAPNAME MT.CREATEBM MT.BITMAPCREATE MT.CONVERTIMAGETOBM MT.CREATE.BIG.BM MT.CREATE.DISPLAYWINDOW MT.REPAINTWINDOW MT.RESHAPEWINDOW) (ADDVARS (|BackgroundMenuCommands| ("MicrotekScanner" (MT.INIT) "Open Microtek Scanner Command and Display windows, initilalize RS232 port and verifies Microtek Scanner is ready"))) (VARS (|BackgroundMenu| NIL)) (VARS MT.ICON MT.ICON.MASK BRIGHTBAR CONTRASTBAR INITIALBRIGHTBAR INITIALCONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW MT.POINTER) (INITVARS (MT.BAUDRATE 19200) (MT.RS232C.FRAME.TIMEOUT 2) (MT.DISPLAYFRAME (QUOTE YES)) (MT.PAPERLENGTH 4) (MT.REDUCTION 0) (MT.CONTRAST 0) (MT.BRIGHTNESS 0) (MT.GREYLEVEL 0) (MT.DATACOMPRESSION (QUOTE NO)) (MT.BACKGROUND (QUOTE HALFTONE)) (MT.WINDOW (QUOTE LINEART)) (MT.FRAME (QUOTE (0 0 40 24))) (MT.FRAME.BOX (QUOTE (0 460 200 120))) (MT.TEXTW1 (QUOTE (0 0 0 0))) (MT.TEXTW2 (QUOTE (0 0 0 0))) (MT.TEXTW3 (QUOTE (0 0 0 0))) (MT.TEXTW4 (QUOTE (0 0 0 0))) (MT.TEXTW1BOX (QUOTE (0 0 0 0))) (MT.TEXTW2BOX (QUOTE (0 0 0 0))) (MT.TEXTW3BOX (QUOTE (0 0 0 0))) (MT.TEXTW4BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW1 (QUOTE (0 0 0 0))) (MT.HALFTONEW2 (QUOTE (0 0 0 0))) (MT.HALFTONEW3 (QUOTE (0 0 0 0))) (MT.HALFTONEW4 (QUOTE (0 0 0 0))) (MT.HALFTONEW1BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW2BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW3BOX (QUOTE (0 0 0 0))) (MT.HALFTONEW4BOX (QUOTE (0 0 0 0))) (MT.OUTSTREAM NIL) (MT.INSTREAM NIL) (MT.BMSHRINKFACTOR 1)) (GLOBALVARS MT.RS232C.FRAME.TIMEOUT MT.STATUSWINDOW MT.HEIGHTRULER MT.GRID MT.PAPERLENGTH MT.REDUCTION MT.BRIGHTNESS MT.CONTRAST MT.GREYLEVEL MT.DATACOMPRESSION MT.BACKGROUND MT.WINDOW MT.HEIGHTWINDOW MT.FRAME MT.FRAME.BOX MT.TEXTW1 MT.TEXTW2 MT.TEXTW3 MT.TEXTW4 MT.HALFTONEW1 MT.HALFTONEW2 MT.HALFTONEW3 MT.HALFTONEW4 MT.OUTSTREAM MT.INSTREAM BRIGHTBAR CONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW) (PROP MAKEFILE-ENVIRONMENT MICROTEK))) - -(FILESLOAD DLRS232C EDITBITMAP) - (* * |Microtek| |Initialization| |and| |Menu| |Functions|) - -(DEFINEQ - -(MT.INIT -(LAMBDA NIL (* \; "Edited 8-Sep-88 18:58 by Briggs") (* \; "Edited 20-May-87 11:20 by ") (MICROTEKSCANNER) (MT.CONTROL.MENU) (MT.COMMAND.MENU) (MT.DISPLAY.MENU) (SETQ MT.STATUSWINDOW (CREATEW (QUOTE (0 0 387 30)) "Microtek Status Window")) (ATTACHWINDOW MT.COMMAND.MENUWINDOW MT.CONTROL.MENUWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (ATTACHWINDOW MT.DISPLAY.MENUWINDOW MT.CONTROL.MENUWINDOW (QUOTE BOTTOM) (QUOTE JUSTIFY)) (ATTACHWINDOW MT.STATUSWINDOW MT.COMMAND.MENUWINDOW (QUOTE TOP) (QUOTE JUSTIFY)) (|if| (FNTYP (QUOTE MT.PRINT.MENU)) |then| (MT.PRINT.MENU)) (MOVEW MT.CONTROL.MENUWINDOW (QUOTE (500 . 160))) (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONFN) (QUOTE MT.SHRINKFN)) (BITBLT MT.POINTER 0 0 MTHEIGHTRULER 20 (IDIFFERENCE 453 (FIX (FTIMES 5 (FDIFFERENCE (FQUOTIENT MT.PAPERLENGTH 0.125) 24))))) (CLOSEF? MT.OUTSTREAM) (CLOSEF? MT.INSTREAM) (|if| \\RS232C.READY |then| (RS232C.SHUTDOWN)) (SETQ MT.OUTSTREAM (OPENSTREAM (QUOTE {RS232}) (QUOTE OUTPUT) NIL (QUOTE ((|BaudRate| 19200) (|BitsPerSerialChar| 8) (|Parity| NONE) (|NoOfStopBits| 1) (|FlowControl| NIL) (DTR T))))) (SETQ MT.INSTREAM (RS232C.OTHER.STREAM MT.OUTSTREAM)) (SETQ MT.OLD.RS232C.FRAME.TIME.OUT (RS232C.GET.PARAMETERS (QUOTE (FRAME.TIMEOUT)))) (RS232C.SET.PARAMETERS (LIST (BQUOTE (FRAME.TIMEOUT \\\, MT.RS232C.FRAME.TIMEOUT)))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (|if| (SETQ RESPONSE (MT.SENDCOMMAND 1 (LIST (QUOTE !)))) |then| (CLRPROMPT) (MT.PRINT.STATUS (CONCAT RESPONSE " ready")) |else| (RINGBELLS) (MT.PRINT.STATUS "Microtek Not Responding ...Check scanner and cables"))) -) - -(MT.SHRINKFN -(LAMBDA (WINDOW ICON) (* \; "Edited 8-Sep-88 18:59 by Briggs") (PROG NIL (CLOSEW MTDISPLAYWINDOW) (CLOSEW MTDISPLAYWINDOW) (|if| (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONWINDOW)) |then| (RETURN (WINDOWPROP MT.CONTROL.MENUWINDOW (QUOTE ICONWINDOW))) |else| (RETURN (ICONW MT.ICON MT.ICON.MASK NIL T))))) -) - -(MICROTEKSCANNER -(LAMBDA NIL (* \; "Edited 8-Sep-88 18:59 by Briggs") (PROG (MTWIDTHRULER YHEIGHT) (SETQ MTDISPLAYWINDOW (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 350 579 "Microtek Scanner Page Map" 5)) (SETQ MTHEIGHTRULER (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 50 570 NIL 5 T)) (SETQ MTWIDTHRULER (DECODE.WINDOW.ARG (QUOTE (100 . 100)) 350 50 NIL 5 T)) (DSPFONT (FONTCREATE (QUOTE GACHA) 10 (QUOTE BRR)) MTHEIGHTRULER) (DSPFONT (FONTCREATE (QUOTE GACHA) 10 (QUOTE BRR)) MTWIDTHRULER) (ATTACHWINDOW MTHEIGHTRULER MTDISPLAYWINDOW (QUOTE LEFT) (QUOTE JUSTIFY)) (ATTACHWINDOW MTWIDTHRULER MTDISPLAYWINDOW (QUOTE TOP) (QUOTE CENTER)) (WINDOWPROP MTDISPLAYWINDOW (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (WINDOWPROP MTHEIGHTRULER (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (WINDOWPROP MTHEIGHTRULER (QUOTE CURSORINFN) (QUOTE MT.CURSOR.IN)) (WINDOWPROP MTHEIGHTRULER (QUOTE CURSOROUTFN) (QUOTE MT.CURSOR.OUT)) (WINDOWPROP MTHEIGHTRULER (QUOTE BUTTONEVENTFN) (QUOTE MT.GETLENGTH)) (WINDOWPROP MTWIDTHRULER (QUOTE RESHAPEFN) (QUOTE (DON\'T))) (RULERX 0 1 16 16 40 1 MTWIDTHRULER) (RULERX 0 1 12 32 20 1 MTWIDTHRULER) (RULERX 0 1 8 64 10 1 MTWIDTHRULER) (RULERX 0 1 4 128 5 1 MTWIDTHRULER) (RULEX# 0 20 40 0 8 MTWIDTHRULER) (SETQ YHEIGHT 580) (RULERY YHEIGHT 1 16 15 -40 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 12 28 -20 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 8 56 -10 1 MTHEIGHTRULER) (RULERY YHEIGHT 1 4 112 -5 1 MTHEIGHTRULER) (RULEY# 0 YHEIGHT -40 0 14 MTHEIGHTRULER) (SETQ MT.HEIGHT.BM (BITMAPCREATE 50 588)) (BITBLT MTHEIGHTRULER 0 0 MT.HEIGHT.BM) (SETQ MT.GRID (BITMAPCREATE 350 579)) (GRID (QUOTE (0 20 10 10)) 42 56 (QUOTE POINT) MTDISPLAYWINDOW) (BITBLT MTDISPLAYWINDOW 0 0 MT.GRID))) -) - -(RULERX -(LAMBDA (STARTX STARTY LEN NUMLINES INCR LINEWIDTH WIND) (* \; "Edited 8-Sep-88 19:00 by Briggs") (|for| I |from| 1 |to| NUMLINES |do| (DRAWLINE STARTX 1 STARTX LEN LINEWIDTH NIL WIND) (SETQ STARTX (PLUS STARTX INCR)))) -) - -(RULEX# -(LAMBDA (STARTX STARTY INCR STARTNUMBER ENDNUMBER WIND) (* \; "Edited 8-Sep-88 19:00 by Briggs") (|for| I |from| STARTNUMBER |to| ENDNUMBER |do| (MOVETO STARTX STARTY WIND) (PRINT I WIND) (SETQ STARTX (PLUS STARTX INCR)))) -) - -(RULERY -(LAMBDA (STARTY STARTX LEN NUMLINES INCR LINEWIDTH WIND) (* \; "Edited 8-Sep-88 19:00 by Briggs") (|for| I |from| 1 |to| NUMLINES |do| (DRAWLINE (DIFFERENCE (WINDOWPROP WIND (QUOTE WIDTH)) STARTX) STARTY (DIFFERENCE (DIFFERENCE (WINDOWPROP WIND (QUOTE WIDTH)) STARTX) LEN) STARTY LINEWIDTH NIL WIND) (SETQ STARTY (PLUS STARTY INCR)))) -) - -(RULEY# -(LAMBDA (STARTX STARTY INCR STARTNUMBER ENDNUMBER WIND) (* \; "Edited 8-Sep-88 19:00 by Briggs") (|for| I |from| STARTNUMBER |to| ENDNUMBER |do| (MOVETO STARTX STARTY WIND) (PRINT I WIND) (SETQ STARTY (PLUS STARTY INCR)))) -) - -(MT.GETLENGTH -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:00 by Briggs") (TOTOPW MTHEIGHTRULER) (|if| (MOUSESTATE LEFT) |then| (SETQ MT.PAPERLENGTH (IMIN 453 (CDR (CURSORPOSITION NIL MTHEIGHTRULER)))) (CLEARW MTHEIGHTRULER) (BITBLT MT.HEIGHT.BM 0 0 MTHEIGHTRULER 0 0) (BITBLT MT.POINTER 0 0 MTHEIGHTRULER 20 MT.PAPERLENGTH) (SETQ MT.PAPERLENGTH (FTIMES (FIX (FPLUS 24.0 (FQUOTIENT (FDIFFERENCE 453 MT.PAPERLENGTH) 5))) 0.125)) (FM.CHANGESTATE (FM.GETITEM (QUOTE PAGELENGTH) NIL MT.CONTROL.MENUWINDOW) MT.PAPERLENGTH MT.CONTROL.MENUWINDOW))) -) - -(MT.CURSOR.IN -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:00 by Briggs") (CURSOR (CURSORCREATE MT.POINTER 8 0)))) - -(MT.CURSOR.OUT -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:00 by Briggs") (CURSOR T))) - -(MT.PRINT.STATUS -(LAMBDA (MSG) (* \; "Edited 8-Sep-88 19:00 by Briggs") (CLEARW MT.STATUSWINDOW) (PRIN1 MSG MT.STATUSWINDOW)) -) - -(MT.CONTROL.MENU -(LAMBDA NIL (* \; "Edited 12-Mar-87 14:32 by rdc") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID RC) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL " Grain Size Levels" BOX 1 FONT (MODERN 10 BOLD) HJUSTIFY RIGHT)) ((TYPE STATE LABEL "Reduction!" MENUITEMS (" 0% = 300 DPI" " 5% = 285 DPI" "10% = 270 DPI" "15% = 255 DPI" "20% = 240 DPI" "25% = 225 DPI" "33% = 200 DPI" "35% = 195 DPI" "40% = 180 DPI" "45% = 165 DPI" "50% = 150 DPI" "55% = 135 DPI" "60% = 120 DPI" "67% = 100 DPI" "70% = 90 DPI" "75% = 75 DPI") INITSTATE " 0% = 300 DPI" LINKS (DISPLAY (GROUP REDUCTION)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID REDUCTION LABEL "" MAXWIDTH 120 BOX 1) (TYPE STATE LABEL "Gray Level!" MENUITEMS (" 0 = 8X8 33" " 1 = 8X8 33" " 2 = 8X8 33" " 3 = 8X8 33" " 4 = 6X6 37" " 5 = 5X5 26" " 6 = 5X5 18" " 7 = 4X4 17" " 8 = 4X4 17" " 9 = 4X4 17" "10 = 3X3 10" "11 = 2X2 5") INITSTATE " 0 = 8X8 33" LINKS (DISPLAY (GROUP GREYLEVEL)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID GREYLEVEL LABEL "" MAXWIDTH 120 BOX 1)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID CD) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE DISPLAY LABEL "Contrast:" FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL \, LEFTARROW HELDFN MT.LOWERCONTRAST MESSAGE "" BOX 1) (TYPE DISPLAY LABEL \, CONTRASTBAR ID CONTRASTBAR MAXWIDTH 130 BOX 1) (TYPE DISPLAY LABEL \, RIGHTARROW HELDFN MT.RAISECONTRAST MESSAGE "" BOX 1) (TYPE EDIT ID CONTRAST LABEL 0 BOX 1 MAXWIDTH 23)) ((TYPE DISPLAY LABEL |Brightness:| FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL \, LEFTARROW HELDFN MT.LOWERBRIGHTNESS MESSAGE "" BOX 1) (TYPE DISPLAY LABEL \, BRIGHTBAR ID BRIGHTBAR MAXWIDTH 130 BOX 1) (TYPE DISPLAY LABEL \, RIGHTARROW HELDFN MT.RAISEBRIGHTNESS MESSAGE "" BOX 1) (TYPE EDIT ID BRIGHTNESS LABEL 0 BOX 1 MAXWIDTH 23)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID MODE) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE STATE LABEL "Background!" ID BACK MENUITEMS ("HALFTONE" "LINEART") INITSTATE "HALFTONE" LINKS (DISPLAY (GROUP BACKGROUNDDISPLAY)) SELECTEDFN MT.SELECT.BACKGROUND FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY LABEL "" ID BACKGROUNDDISPLAY MAXWIDTH 57 BOX 1) (TYPE DISPLAY LABEL "Window Mode:" FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOWTYPE LABEL (\\\, MT.WINDOW) MAXWIDTH 58 BOX 1) (TYPE DISPLAY LABEL "Page Length:" FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID PAGELENGTH LABEL "" BOX 1 MAXWIDTH 45)) ((TYPE DISPLAY LABEL "")))) ((PROPS ID WINDOW) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL "Frame! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETTRANSFRAME BOX 1) (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL "") (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TX1 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TY1 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TX2 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID TY2 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE DISPLAY LABEL "")) ((TYPE MOMENTARY LABEL "Window 1! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW1 BOX 1) (TYPE STATE LABEL "ON?" ID SW1 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW1)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW1 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X11 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y11 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X21 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y21 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 2! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW2 BOX 1) (TYPE STATE LABEL "ON?" ID SW2 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW2)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW2 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X12 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y12 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X22 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y22 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 3! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW3 BOX 1) (TYPE STATE LABEL "ON?" ID SW3 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW3)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW3 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X13 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y13 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X23 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y23 LABEL "" MAXWIDTH 45 BOX 1)) ((TYPE MOMENTARY LABEL "Window 4! " FONT (MODERN 10 BOLD) SELECTEDFN MT.GETWINDOW4 BOX 1) (TYPE STATE LABEL "ON?" ID SW4 INITSTATE " NO" MENUITEMS (" NO" "YES") SELECTEDFN MT.UPDATE.HTWINDOWS LINKS (DISPLAY (GROUP WINDOW4)) FONT (MODERN 10 BOLD) BOX 1) (TYPE DISPLAY ID WINDOW4 LABEL "" BOX 1 MAXWIDTH 21) (TYPE DISPLAY LABEL X1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X14 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y1\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y14 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL X2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID X24 LABEL "" MAXWIDTH 45 BOX 1) (TYPE DISPLAY LABEL Y2\: FONT (MODERN 10 BOLD) BOX 1) (TYPE EDIT ID Y24 LABEL "" MAXWIDTH 45 BOX 1))))))) (SETQ MT.CONTROL.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Configuration Menu" 23130 5)) (FM.CHANGESTATE (FM.GETITEM (QUOTE BACK) NIL MT.CONTROL.MENUWINDOW) MT.BACKGROUND MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX1) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY1) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX2) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY2) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.FRAME) 0.125) MT.CONTROL.MENUWINDOW) (MT.SELECT.BACKGROUND) (FM.CHANGESTATE (FM.GETITEM (QUOTE PAGELENGTH) NIL MT.CONTROL.MENUWINDOW) MT.PAPERLENGTH MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE REDUCTION) NIL MT.CONTROL.MENUWINDOW) MT.REDUCTION MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW) (MT.CHANGE.BRIGHTBAR MT.BRIGHTNESS) (MT.CHANGE.CONTRASTBAR MT.CONTRAST) (OPENW MT.CONTROL.MENUWINDOW))) -) - -(MT.CHANGE.BRIGHTBAR -(LAMBDA (BRIGHTNESS) (* \; "Edited 8-Sep-88 19:01 by Briggs") (* |;;;| "Moves the cursor in BRIGHTBAR from one place to another.") (BITBLT INITIALBRIGHTBAR NIL NIL BRIGHTBAR NIL NIL NIL NIL NIL (QUOTE REPLACE)) (BITBLT MANCURSOR NIL NIL BRIGHTBAR (IPLUS 60 (FIX (TIMES BRIGHTNESS 2))) 0 10 10 NIL (QUOTE INVERT)) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTBAR) NIL MT.CONTROL.MENUWINDOW) BRIGHTBAR MT.CONTROL.MENUWINDOW)) -) - -(MT.RAISEBRIGHTNESS -(LAMBDA NIL (* \; "Edited 5-Mar-87 13:05 by RDC") (|if| (LEQ (IPLUS MT.BRIGHTNESS 4) 28) |then| (MT.CHANGE.BRIGHTBAR (SETQ MT.BRIGHTNESS (IPLUS MT.BRIGHTNESS 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW)) -) - -(MT.LOWERBRIGHTNESS -(LAMBDA NIL (* \; "Edited 5-Mar-87 13:04 by RDC") (|if| (GEQ (IDIFFERENCE MT.BRIGHTNESS 4) -24) |then| (MT.CHANGE.BRIGHTBAR (SETQ MT.BRIGHTNESS (IDIFFERENCE MT.BRIGHTNESS 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE BRIGHTNESS) NIL MT.CONTROL.MENUWINDOW) MT.BRIGHTNESS MT.CONTROL.MENUWINDOW)) -) - -(MT.CHANGE.CONTRASTBAR -(LAMBDA (CONTRAST) (* \; "Edited 8-Sep-88 19:01 by Briggs") (* |;;;| "Moves the diamond cursor around inside CONTRASTBAR.") (BITBLT INITIALCONTRASTBAR NIL NIL CONTRASTBAR NIL NIL NIL NIL NIL (QUOTE REPLACE)) (BITBLT MANCURSOR NIL NIL CONTRASTBAR (IPLUS 60 (FIX (TIMES CONTRAST 2))) 0 10 10 NIL (QUOTE INVERT)) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRASTBAR) NIL MT.CONTROL.MENUWINDOW) CONTRASTBAR MT.CONTROL.MENUWINDOW)) -) - -(MT.RAISECONTRAST -(LAMBDA NIL (* \; "Edited 5-Mar-87 13:04 by RDC") (|if| (LEQ (IPLUS MT.CONTRAST 4) 28) |then| (MT.CHANGE.CONTRASTBAR (SETQ MT.CONTRAST (IPLUS MT.CONTRAST 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW)) -) - -(MT.LOWERCONTRAST -(LAMBDA NIL (* \; "Edited 5-Mar-87 13:03 by RDC") (|if| (GEQ (IDIFFERENCE MT.CONTRAST 4) -24) |then| (MT.CHANGE.CONTRASTBAR (SETQ MT.CONTRAST (IDIFFERENCE MT.CONTRAST 4)))) (FM.CHANGELABEL (FM.GETITEM (QUOTE CONTRAST) NIL MT.CONTROL.MENUWINDOW) MT.CONTRAST MT.CONTROL.MENUWINDOW)) -) - -(MT.SELECT.BACKGROUND -(LAMBDA NIL (* \; "Edited 5-Mar-87 15:09 by RDC") (SETQ MT.BACKGROUND (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) (|if| (STREQUAL MT.BACKGROUND "LINEART") |then| (FM.CHANGELABEL (FM.GETITEM (QUOTE WINDOWTYPE) NIL MT.CONTROL.MENUWINDOW) "HALFTONE" MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.HALFTONEW4) 0.125) MT.CONTROL.MENUWINDOW) |else| (FM.CHANGELABEL (FM.GETITEM (QUOTE WINDOWTYPE) NIL MT.CONTROL.MENUWINDOW) "LINEART" MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW1) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW2) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW3) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CAR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES (CADDDR MT.TEXTW4) 0.125) MT.CONTROL.MENUWINDOW)) (MT.UPDATE.HTWINDOWS)) -) - -(MT.GETTRANSFRAME -(LAMBDA NIL (* \; "Edited 5-Mar-87 13:28 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX1) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY1) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TX2) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE TY2) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (SETQ MT.FRAME (LIST X1 Y1 X2 Y2)) (SETQ MT.FRAME.BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) (MT.UPDATE.HTWINDOWS))) -) - -(MT.GETWINDOW1 -(LAMBDA NIL (* \; "Edited 5-Mar-87 14:23 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X11) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y11) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X21) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y21) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW1 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW1BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW1 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW1BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS))) -) - -(MT.GETWINDOW2 -(LAMBDA NIL (* \; "Edited 5-Mar-87 14:24 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X12) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y12) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X22) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y22) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW2 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW2BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW2 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW2BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS))) -) - -(MT.GETWINDOW3 -(LAMBDA NIL (* \; "Edited 5-Mar-87 14:25 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X13) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y13) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X23) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y23) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW3 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW3BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW3 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW3BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS))) -) - -(MT.GETWINDOW4 -(LAMBDA NIL (* \; "Edited 5-Mar-87 14:26 by RDC") (PROG (WINDOWLOC TWINDOW PAGEMAPWIDTH PAGEMAPHEIGHT ORGX ORGY WIDTH HEIGHT) (TOTOPW MTDISPLAYWINDOW) (SETQ WINDOWLOC (WINDOWPROP MTDISPLAYWINDOW (QUOTE REGION))) (SETQ TWINDOW (SETQ WINDOW (GETREGION))) (SETQ PAGEMAPWIDTH (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE WIDTH)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER))))) (SETQ PAGEMAPHEIGHT (IDIFFERENCE (IDIFFERENCE (WINDOWPROP MTDISPLAYWINDOW (QUOTE HEIGHT)) (ITIMES 2 (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))) (FONTPROP |WindowTitleDisplayStream| (QUOTE HEIGHT)))) (SETQ ORGX (IMAX 0 (IMIN PAGEMAPWIDTH (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CAR TWINDOW) (CAR WINDOWLOC))) (WINDOWPROP MTDISPLAYWINDOW (QUOTE BORDER)))))) (SETQ ORGY (IMAX 0 (IMIN PAGEMAPHEIGHT (IDIFFERENCE (IMAX 0 (IDIFFERENCE (CADR TWINDOW) (CADR WINDOWLOC))) 25)))) (SETQ WIDTH (IMIN PAGEMAPWIDTH (CADDR TWINDOW))) (|if| (GREATERP (IPLUS ORGX WIDTH) PAGEMAPWIDTH) |then| (SETQ WIDTH (IDIFFERENCE PAGEMAPWIDTH ORGX))) (SETQ HEIGHT (IMIN PAGEMAPHEIGHT (CADDDR TWINDOW))) (|if| (GREATERP (IPLUS ORGY HEIGHT) PAGEMAPHEIGHT) |then| (SETQ HEIGHT (IDIFFERENCE PAGEMAPHEIGHT ORGY))) (SETQ X1 (FIX (QUOTIENT ORGX 5.0))) (SETQ Y1 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT (IPLUS ORGY HEIGHT)) 5.0))) (SETQ X2 (FIX (QUOTIENT (IPLUS ORGX WIDTH) 5.0))) (SETQ Y2 (FIX (QUOTIENT (IDIFFERENCE PAGEMAPHEIGHT ORGY) 5.0))) (FM.CHANGESTATE (FM.GETITEM (QUOTE X14) NIL MT.CONTROL.MENUWINDOW) (FTIMES X1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y14) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y1 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE X24) NIL MT.CONTROL.MENUWINDOW) (FTIMES X2 0.125) MT.CONTROL.MENUWINDOW) (FM.CHANGESTATE (FM.GETITEM (QUOTE Y24) NIL MT.CONTROL.MENUWINDOW) (FTIMES Y2 0.125) MT.CONTROL.MENUWINDOW) (|if| (STREQUAL "HALFTONE" (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BACK))) |then| (SETQ MT.TEXTW4 (LIST X1 Y1 X2 Y2)) (SETQ MT.TEXTW4BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT)) |else| (SETQ MT.HALFTONEW4 (LIST X1 Y1 X2 Y2)) (SETQ MT.HALFTONEW4BOX (LIST ORGX (IPLUS ORGY 20) WIDTH HEIGHT))) (MT.UPDATE.HTWINDOWS))) -) - -(MT.UPDATE.HTWINDOWS -(LAMBDA NIL (* \; "Edited 12-Mar-87 12:29 by rdc") (PROG ((PARAMETER.LIST (FM.GETSTATE MT.CONTROL.MENUWINDOW)) (WINDOW (LIST 0 0 0 0))) (CLEARW MTDISPLAYWINDOW) (BITBLT MT.GRID 0 0 MTDISPLAYWINDOW) (MT.DRAWAREABOX (CAR MT.FRAME.BOX) (CADR MT.FRAME.BOX) (CADDR MT.FRAME.BOX) (CADDDR MT.FRAME.BOX) 2 NIL MTDISPLAYWINDOW) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW1)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW1BOX) |else| (SETQ WINDOW MT.HALFTONEW1BOX))) (BLTSHADE 2000 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW2)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW2BOX) |else| (SETQ WINDOW MT.HALFTONEW2BOX))) (BLTSHADE GRAYSHADE MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW3)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW3BOX) |else| (SETQ WINDOW MT.HALFTONEW3BOX))) (BLTSHADE 45 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW4)) "YES") |then| (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE BACK)) "HALFTONE") |then| (SETQ WINDOW MT.TEXTW4BOX) |else| (SETQ WINDOW MT.HALFTONEW4BOX))) (BLTSHADE 50000 MTDISPLAYWINDOW (CAR WINDOW) (CADR WINDOW) (CADDR WINDOW) (CADDDR WINDOW)))) -) - -(MT.DRAWAREABOX -(LAMBDA (BOXLEFT BOXBOTTOM BOXWIDTH BOXHEIGHT BORDER OP W TEXTURE) (* \; "Edited 8-Sep-88 19:02 by Briggs") (OR TEXTURE (SETQ TEXTURE BLACKSHADE)) (* \; "draws lines inside the region.") (* \; "draw left edge") (BITBLT NIL NIL NIL W BOXLEFT BOXBOTTOM BORDER BOXHEIGHT (QUOTE TEXTURE) OP TEXTURE) (* \; "draw top") (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) (DIFFERENCE (PLUS BOXBOTTOM BOXHEIGHT) BORDER) (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) BORDER (QUOTE TEXTURE) OP TEXTURE) (* \; "draw bottom") (BITBLT NIL NIL NIL W (PLUS BOXLEFT BORDER) BOXBOTTOM (DIFFERENCE BOXWIDTH (PLUS BORDER BORDER)) BORDER (QUOTE TEXTURE) OP TEXTURE) (* \; "draw right edge") (BITBLT NIL NIL NIL W (DIFFERENCE (PLUS BOXLEFT BOXWIDTH) BORDER) BOXBOTTOM BORDER BOXHEIGHT (QUOTE TEXTURE) OP TEXTURE)) -) -) - (* * |Command| |Functions|) - -(DEFINEQ - -(MT.COMMAND.MENU -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:02 by Briggs") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID COMMAND) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL SCAN! FONT (MODERN 12 BOLD) SELECTEDFN MT.SCAN BOX 3) (TYPE MOMENTARY LABEL STOP! FONT (MODERN 12 BOLD) SELECTEDFN MT.STOP.SCANNING BOX 3) (TYPE MOMENTARY LABEL RESET! FONT (MODERN 12 BOLD) SELECTEDFN MT.RESET BOX 3) (TYPE MOMENTARY LABEL PAGEMAP! FONT (MODERN 12 BOLD) SELECTEDFN MT.PAGEMAP BOX 3) (TYPE MOMENTARY LABEL QUIT! ID QUIT FONT (MODERN 12 BOLD) SELECTEDFN MT.QUIT BOX 3)))) ((PROPS ID COMMAND2) (GROUP (PROPS FORMAT TABLE BACKGROUND 23130) ((TYPE MOMENTARY LABEL "Output Filename!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.OUTFILENAME BOX 1) (TYPE EDIT ID OUTFILENAME LABEL {DSK}IMAGE BOX 1 MAXWIDTH 375))))))) (SETQ MT.COMMAND.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Command Menu" 23130 5)) (OPENW MT.COMMAND.MENUWINDOW))) -) - -(MT.GET.OUTFILENAME -(LAMBDA NIL (* \; "Edited 12-Mar-87 14:48 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE OUTFILENAME) NIL MT.COMMAND.MENUWINDOW) MT.COMMAND.MENUWINDOW)) -) - -(MT.SCAN -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:02 by Briggs") (ADD.PROCESS (QUOTE (MT.START.SCANNING)) (QUOTE NAME) (QUOTE MICROTEK.SCANNING))) -) - -(MT.START.SCANNING -(LAMBDA NIL (* \; "Edited 8-Sep-88 21:36 by Briggs") (PROG (HDR DATACOUNT (SCANLINECOUNT 0) CHECKSUM NUMBEROFBYTES OUTFILESTREAM CORESTREAM SOR RT (LINEBUFFERSIZE 0) LINEBUFFER GREYLEVEL REDUCTION DATASIZE) (* |;;| "Reset the Scanner") (MT.RESET) (* |;;| "Send the scan parameters") (|if| (NOT (MT.SEND.SCAN.PARAMETERS)) |then| (MT.PRINT.STATUS "Scanning parameters not valid") (RINGBELLS) (BLOCK 2000) (MT.RESET) (RETURN NIL)) (* |;;| "Setup the Core output file") (SETQ CORESTREAM (MT.SETUPSCANFILE)) (* |;;| "Send start scanning command") (MT.SENDCOMMAND 1 (LIST (QUOTE S))) (MT.PRINT.STATUS "[scanning]") (* |;;| "Get headerof each line") AGAIN (SETQ SOR (BIN MT.INSTREAM)) (SETQ RT (BIN MT.INSTREAM)) (SETQ DATACOUNT (IPLUS (ITIMES 256 (BIN MT.INSTREAM)) (BIN MT.INSTREAM))) (SELECTQ RT ((0 4) (* |;;| "since we never NAK, we can speed up the processing by ACKing early") (MT.SENDACK) (SETQ DATASIZE DATACOUNT) (* \; "needed later") (SETQ SCANLINECOUNT (IPLUS SCANLINECOUNT 1)) (COND ((IGREATERP DATACOUNT LINEBUFFERSIZE) (SETQ LINEBUFFER (ARRAY DATACOUNT (QUOTE BYTE) 0 0)))) (AIN LINEBUFFER 0 DATACOUNT MT.INSTREAM) (AOUT LINEBUFFER 0 DATACOUNT CORESTREAM) (SETQ CHECKSUM (BIN MT.INSTREAM)) (GO AGAIN)) (128 (SELCHARQ (BIN MT.INSTREAM) (E (BIN MT.INSTREAM) (MT.SENDACK) (MT.PRINT.STATUS "[scanning done]")) (? (|to| DATACOUNT |do| (MT.PRINT.ERROR.MSG (BIN MT.INSTREAM))) (MT.SENDACK) (CLOSEF? CORESTREAM) (RETURN NIL)) NIL)) (PROGN (MT.PRINT.STATUS "[ERROR: unrecognized record type from scanner]") (RETURN NIL))) (MT.PRINT.STATUS "[copying to file]") (SETQ NUMBEROFBYTES (GETFILEPTR CORESTREAM)) (SETQ OUTFILESTREAM (OPENSTREAM (LISTGET (FM.GETSTATE MT.COMMAND.MENUWINDOW) (QUOTE OUTFILENAME)) (QUOTE OUTPUT))) (* |;;| "print header on file, the NO indicates that this file does not contain compressed data") (PRINT (QUOTE NO) OUTFILESTREAM) (SETQ REDUCTION (SUBSTRING (CADR (MEMBER "Reduction!" (FM.GETSTATE MT.CONTROL.MENUWINDOW))) 1 2)) (|if| (STREQUAL (SUBSTRING REDUCTION 1 1) " ") |then| (SETQ REDUCTION (SUBSTRING REDUCTION 2 2))) (PRINT (MKATOM REDUCTION) OUTFILESTREAM) (SETQ GREYLEVEL (SUBSTRING (CADR (MEMBER "Gray Level!" (FM.GETSTATE MT.CONTROL.MENUWINDOW))) 1 2)) (|if| (STREQUAL (SUBSTRING GREYLEVEL 1 1) " ") |then| (SETQ GREYLEVEL (SUBSTRING GREYLEVEL 2 2))) (PRINT (MKATOM GREYLEVEL) OUTFILESTREAM) (PRINT (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE CONTRAST)) OUTFILESTREAM) (PRINT (LISTGET (FM.GETSTATE MT.CONTROL.MENUWINDOW) (QUOTE BRIGHTNESS)) OUTFILESTREAM) (PRINT SCANLINECOUNT OUTFILESTREAM) (PRINT DATASIZE OUTFILESTREAM) (SETFILEPTR CORESTREAM 0) (COPYBYTES CORESTREAM OUTFILESTREAM NUMBEROFBYTES) (CLOSEF OUTFILESTREAM) (CLOSEF CORESTREAM) (MT.PRINT.STATUS "[done]"))) -) - -(MT.SETUPSCANFILE -(LAMBDA NIL (* \; "Edited 8-Sep-88 21:13 by Briggs") (* |;;;| "will check to see if the scratch file is in core. If it is it will dirty 500 pages to bring them into real memory (speedup when writing to them!). If there wasn't a file, it creates it and then dirtys 500 pgs. RETURNS: stream to the file") (PROG (RECOG FILE) (MT.PRINT.STATUS "[setting up scratch file]") (SETQ FILE (OPENSTREAM (QUOTE {SCRATCH}) (QUOTE BOTH) (QUOTE NEW) (QUOTE (SEQUENTIAL T)))) (* |;;;| "now expand the file so you can read and transfer fast") (|for| I |from| 0 |to| 260000 |by| 512 |do| (SETFILEPTR FILE I) (BOUT FILE 1)) (* |;;;| "and reset to the beginning") (SETFILEPTR FILE 0) (MT.PRINT.STATUS "[scratch file set up]") (RETURN FILE))) -) - -(MT.SEND.SCAN.PARAMETERS -(LAMBDA NIL (DECLARE (GLOBALVARS MT.CONTROL.MENUWINDOW MT.PAPERLENGTH MT.FRAME)) (* \; "Edited 8-Sep-88 18:38 by Briggs") (PROG (PARAMETER.LIST PAPERLENGTH SCANFRAME BACKGROUND GREYLEVEL CONTRAST BRIGHTNESS RESOLUTION REDUCTION DATACOMPRESSION (NO.OF.WINDOWS 0) (COORD.LIST NIL)) (SETQ PARAMETER.LIST (FM.GETSTATE MT.CONTROL.MENUWINDOW)) (SETQ PAPERLENGTH (IPLUS 24 (QUOTIENT (FDIFFERENCE MT.PAPERLENGTH 3.0) 0.125))) (SETQ SCANFRAME MT.FRAME) (|if| (EQ (MKATOM (LISTGET PARAMETER.LIST (QUOTE BACK))) (QUOTE HALFTONE)) |then| (SETQ BACKGROUND (QUOTE H)) |else| (SETQ BACKGROUND (QUOTE T))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW1)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW1 |else| MT.HALFTONEW1)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW2)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW2 |else| MT.HALFTONEW2)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW3)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW3 |else| MT.HALFTONEW3)))) (|if| (STREQUAL (LISTGET PARAMETER.LIST (QUOTE SW4)) "YES") |then| (SETQ NO.OF.WINDOWS (IPLUS NO.OF.WINDOWS 1)) (SETQ COORD.LIST (APPEND COORD.LIST (|if| (EQ BACKGROUND (QUOTE H)) |then| MT.TEXTW4 |else| MT.HALFTONEW4)))) (|if| (STREQUAL (SUBSTRING (SETQ GREYLEVEL (SUBSTRING (CADR (MEMBER "Gray Level!" PARAMETER.LIST)) 1 2)) 1 1) " ") |then| (SETQ GREYLEVEL (SUBSTRING GREYLEVEL 2 2))) (SETQ GREYLEVEL (MKATOM GREYLEVEL)) (SETQ CONTRAST (IPLUS 7 (IQUOTIENT (MKATOM (LISTGET PARAMETER.LIST (QUOTE CONTRAST))) 4))) (SETQ BRIGHTNESS (IPLUS 7 (IQUOTIENT (MKATOM (LISTGET PARAMETER.LIST (QUOTE BRIGHTNESS))) 4))) (|if| (STREQUAL (SUBSTRING (SETQ REDUCTION (SUBSTRING (CADR (MEMBER "Reduction!" PARAMETER.LIST)) 1 2)) 1 1) " ") |then| (SETQ REDUCTION (SUBSTRING REDUCTION 2 2))) (SETQ RESOLUTION (LISTGET (QUOTE (0 16 5 17 10 18 15 19 20 20 25 21 33 22 35 23 40 24 45 25 50 26 55 27 60 28 67 29 70 30 75 31)) (MKATOM REDUCTION))) (|if| (EQ (QUOTE YES) (MKATOM (LISTGET PARAMETER.LIST (QUOTE COMPRESSDATA)))) |then| (SETQ DATACOMPRESSION 1) |else| (SETQ DATACOMPRESSION 0)) (|if| (AND (MT.SENDCOMMAND 2 (LIST (QUOTE L) PAPERLENGTH)) (MT.SENDCOMMAND 5 (APPEND (LIST (QUOTE F)) SCANFRAME)) (|if| (GREATERP NO.OF.WINDOWS 0) |then| (MT.SENDCOMMAND (IPLUS 2 (ITIMES NO.OF.WINDOWS 4)) (APPEND (LIST BACKGROUND) (LIST NO.OF.WINDOWS) COORD.LIST)) |else| (MT.SENDCOMMAND 2 (APPEND (LIST BACKGROUND) (LIST 0)))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE G)) (LIST GREYLEVEL))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE K)) (LIST CONTRAST))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE B)) (LIST BRIGHTNESS))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE R)) (LIST RESOLUTION))) (MT.SENDCOMMAND 2 (APPEND (LIST (QUOTE C)) (LIST DATACOMPRESSION)))) |then| (RETURN T) |else| (RETURN NIL)))) -) - -(MT.SENDCOMMAND -(LAMBDA (DATACOUNT DATALIST) (* \; "Edited 8-Sep-88 19:03 by Briggs") (PROG (DATA RESPONSE (CHECKSUM 0) (RETRYCOUNT 0)) (* \; "SEND \\ AND 80H") RETRY (BOUT MT.OUTSTREAM (CHARCODE "\\")) (BOUT MT.OUTSTREAM 128) (BOUT MT.OUTSTREAM 0) (BOUT MT.OUTSTREAM DATACOUNT) (SETQ CHECKSUM (IPLUS CHECKSUM 128 0 DATACOUNT)) (|for| DATA |in| DATALIST |do| (|if| (NUMBERP DATA) |then| (BOUT MT.OUTSTREAM DATA) (SETQ CHECKSUM (IPLUS CHECKSUM DATA)) |else| (BOUT MT.OUTSTREAM (CAR (CHCON DATA))) (SETQ CHECKSUM (IPLUS CHECKSUM (CAR (CHCON DATA)))))) (FORCEOUTPUT MT.OUTSTREAM) (BOUT MT.OUTSTREAM (IPLUS (LOGXOR 255 CHECKSUM) 1)) (FORCEOUTPUT MT.OUTSTREAM) REREAD (BLOCK 500) (SETQ RESPONSE (|while| (READP MT.INSTREAM) |collect| (BIN MT.INSTREAM))) (|if| (AND (NEQ (CAR RESPONSE) 92) (NEQ (CAR RESPONSE) 6)) |then| (SETQ CHECKSUM 0) (SETQ RETRYCOUNT (IPLUS RETRYCOUNT 1)) (|if| (EQ RETRYCOUNT 5) |then| (RETURN NIL) |else| (GO RETRY))) (|if| (GREATERP (LENGTH RESPONSE) 2) |then| (* |;;;| "Compute checksum on all characters after the \\") (|if| (NOT (SETQ RESPONSE (MT.COMPUTECHECKSUM (CDR (MEMBER (CHARCODE "\\") RESPONSE))))) |then| (GO REREAD)) (|if| (EQP (CAR RESPONSE) (CHARCODE ?)) |then| (MT.PRINT.ERROR.MSG (CADR RESPONSE)) (RETURN NIL) |else| (RETURN (PACKC RESPONSE))) |else| (RETURN T)))) -) - -(MT.COMPUTECHECKSUM -(LAMBDA (RESPONSE) (* \; "Edited 8-Sep-88 19:03 by Briggs") (* |;;;| "Response should be all bytes after the \\. Byte 1 = Command type Byte 2 = High part data count Byte 3 = Low part of data count after databytes should be Checksum and remaining data after this is extraneous") (PROG (DATACOUNT LENGTHDIFF DATALIST CHECKSUM (SUMCHECK 0)) (SETQ DATALIST RESPONSE) (SETQ DATACOUNT (IPLUS (LLSH (CADR RESPONSE) 8) (CADDR RESPONSE))) (SETQ LENGTHDIFF (IDIFFERENCE (LENGTH RESPONSE) (IPLUS DATACOUNT 3))) (|for| I |from| 1 |to| LENGTHDIFF |do| (SETQ DATALIST (REVERSE (CDR (REVERSE DATALIST))))) (SETQ CHECKSUM (CAR (NTH RESPONSE (IPLUS 4 DATACOUNT)))) (|for| DATA |in| DATALIST |do| (SETQ SUMCHECK (IPLUS SUMCHECK DATA))) (|if| (OR (EQP CHECKSUM (IPLUS (LOGXOR 255 (LRSH (LLSH SUMCHECK 24) 24)) 1)) (EQ CHECKSUM 0)) |then| (MT.SENDACK) (* |;;;| "Return data minus the response type, hi & low data count and checksum") (RETURN (CDDDR DATALIST)) |else| (MT.SENDNAK) (RETURN NIL)))) -) - -(MT.PRINT.ERROR.MSG -(LAMBDA (ERRORCODE) (* \; "Edited 8-Sep-88 12:52 by Briggs") (RINGBELLS) (SELECTQ ERRORCODE (1 (MT.PRINT.STATUS "U88 ROM FAILURE")) (2 (MT.PRINT.STATUS "U81 ROM FAILURE")) (3 (MT.PRINT.STATUS "U64 ROM FAILURE")) (4 (MT.PRINT.STATUS "U72 ROM FAILURE")) (6 (MT.PRINT.STATUS "U23 ROM FAILURE")) (7 (MT.PRINT.STATUS "U31 ROM FAILURE")) (8 (MT.PRINT.STATUS "U29 ROM FAILURE")) (9 (MT.PRINT.STATUS "Paper sensor failure")) (16 (MT.PRINT.STATUS "Lamp failure or image sensor circuit failure")) (128 (MT.PRINT.STATUS "Illegal Command")) (129 (MT.PRINT.STATUS "Illegal Gray Scale Setting")) (131 (MT.PRINT.STATUS "Illegal Resolution Setting")) (132 (MT.PRINT.STATUS "Illegal Data Compression Parameter")) (133 (MT.PRINT.STATUS "Illegal Scanning Frame Coordinate")) (134 (MT.PRINT.STATUS "Illegal number of windows")) (135 (MT.PRINT.STATUS "Illegal window coordinate")) (136 (MT.PRINT.STATUS "Illegal Contrast Setting")) (137 (MT.PRINT.STATUS "Illegal Paper Length setting")) (138 (MT.PRINT.STATUS "Record Type error")) (139 (MT.PRINT.STATUS "NAK receiced on 5 consecutive transmissions")) (140 (MT.PRINT.STATUS "Paper jammed or longer than length setting")) (141 (MT.PRINT.STATUS "Illegal Brightness setting")) NIL)) -) - -(MT.SENDACK -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:03 by Briggs") (BOUT MT.OUTSTREAM 6) (FORCEOUTPUT MT.OUTSTREAM)) -) - -(MT.SENDNAK -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:03 by Briggs") (BOUT MT.OUTSTREAM 21) (FORCEOUTPUT MT.OUTSTREAM)) -) - -(MT.STOP.SCANNING -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:03 by Briggs") (PROG NIL (BOUT MT.OUTSTREAM 3) (FORCEOUTPUT MT.OUTSTREAM) (DEL.PROCESS (BQUOTE MICROTEK.SCANNING)) (MT.RESET))) -) - -(MT.RESET -(LAMBDA NIL (* \; "Edited 8-Sep-88 12:51 by Briggs") (|if| (AND (EQ \\RS232C.READY T) (EQ (CDAR (RS232C.GET.PARAMETERS (QUOTE (|BaudRate|)))) MT.BAUDRATE) (EQ (CADAR (RS232C.GET.PARAMETERS (QUOTE (|FlowControl|)))) 0) (LEQ (CDAR (RS232C.GET.PARAMETERS (QUOTE (FRAME.TIMEOUT)))) 50) (OPENP MT.OUTSTREAM) (OPENP MT.INSTREAM)) |then| (MT.SENDCOMMAND 1 (LIST (QUOTE X))) |else| (RS232C.INIT MT.BAUDRATE 8 (QUOTE NONE) 1 (QUOTE DTR)) (CLOSEF? MT.OUTSTREAM) (CLOSEF? MT.INSTREAM) (SETQ MT.OUTSTREAM (OPENSTREAM (QUOTE {RS232}) (QUOTE OUTPUT))) (SETQ MT.INSTREAM (RS232C.OTHER.STREAM MT.OUTSTREAM)) (RS232C.SET.PARAMETERS (LIST (BQUOTE (FRAME.TIMEOUT \\\, MT.RS232C.FRAME.TIMEOUT))))) (DELFILE (CLOSEF? (QUOTE {CORE}SCANNER.SCRATCH))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (MT.SENDCOMMAND 1 (LIST (QUOTE !))) (LET ((RESPONSE (MT.SENDCOMMAND 1 (LIST (QUOTE !))))) (|if| RESPONSE |then| (CLRPROMPT) (MT.PRINT.STATUS (CONCAT RESPONSE " ready")) |else| (RINGBELLS) (MT.PRINT.STATUS "Microtek Not Responding ...Check scanner and cables")))) -) - -(MT.PAGEMAP -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:04 by Briggs") (|if| (OPENWP MTDISPLAYWINDOW) |then| (CLOSEW MTDISPLAYWINDOW) |else| (OPENW MTDISPLAYWINDOW))) -) - -(MT.QUIT -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:04 by Briggs") (SETQ RESPONSE (MENU (|create| MENU ITEMS _ (QUOTE ("QUIT" "SHUTDOWN RS232 PORT ONLY")) MENUFONT _ (FONTCREATE (QUOTE MODERN) 10 (QUOTE BOLD))))) (CLOSEF? MT.INSTREAM) (CLOSEF? MT.OUTSTREAM) (RS232C.SHUTDOWN) (|if| (STREQUAL RESPONSE "QUIT") |then| (DELFILE (CLOSEF? (QUOTE {CORE}SCANNER.SCRATCH))) (CLOSEW MTDISPLAYWINDOW) (CLOSEW MT.CONTROL.MENUWINDOW))) -) -) - (* * |Functions| |to| |convert| |and| |print| |scanned| |images|) - -(DEFINEQ - -(MT.DISPLAY.MENU -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:04 by Briggs") (PROG (MENU.DESCRIPTION) (SETQ MENU.DESCRIPTION (BQUOTE (((PROPS ID DISPLAY1) (GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BACKGROUND 23130) (TYPE MOMENTARY LABEL "CREATE BITMAP!" FONT (MODERN 12 BOLD) SELECTEDFN MT.CREATEBM BOX 3 LEFT 1 BOTTOM 35) (TYPE MOMENTARY LABEL "Bitmap Name!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.BITMAPNAME BOX 1 LEFT 1 BOTTOM 18) (TYPE EDIT ID BITMAPNAME LABEL "IMAGE" BOX 1 LEFT 100 BOTTOM 18 MAXWIDTH 170) (TYPE STATE LABEL "Shrinkfactor! " MENUITEMS (10 9 8 7 6 5 4 3 2 1) INITSTATE 1 LINKS (DISPLAY (GROUP BMSHRINKFACTOR)) FONT (MODERN 10 BOLD) BOX 1 LEFT 278 BOTTOM 18) (TYPE DISPLAY LABEL "" ID BMSHRINKFACTOR BOX 1 LEFT 350 BOTTOM 18 MAXWIDTH 16) (TYPE STATE LABEL "Rotation! " MENUITEMS ("NONE" "LEFT" "RIGHT") LINKS (DISPLAY (GROUP ROTATE)) INITSTATE "NONE" FONT (MODERN 10 BOLD) BOX 1 LEFT 382 BOTTOM 18) (TYPE DISPLAY LABEL "" ID ROTATE BOX 1 LEFT 439 BOTTOM 18 MAXWIDTH 37) (TYPE DISPLAY LABEL "Source Filename!: " FONT (MODERN 10 BOLD) SELECTEDFN MT.GET.SOURCEFILENAME BOX 1 LEFT 1 BOTTOM 1) (TYPE EDIT ID SOURCEFILENAME LABEL {DSK}IMAGE BOX 1 LEFT 100 BOTTOM 1 MAXWIDTH 379)))))) (SETQ MT.DISPLAY.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Display Menu" 23130 5)) (FM.CHANGESTATE (FM.GETITEM (QUOTE BMSHRINKFACTOR) NIL MT.DISPLAY.MENUWINDOW) MT.BMSHRINKFACTOR MT.DISPLAY.MENUWINDOW) (OPENW MT.DISPLAY.MENUWINDOW))) -) - -(MT.GET.SOURCEFILENAME -(LAMBDA NIL (* \; "Edited 12-Mar-87 15:41 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE SOURCEFILENAME) NIL MT.DISPLAY.MENUWINDOW) MT.DISPLAY.MENUWINDOW)) -) - -(MT.GET.BITMAPNAME -(LAMBDA NIL (* \; "Edited 12-Mar-87 15:42 by rdc") (FM.EDITITEM (FM.GETITEM (QUOTE BITMAPNAME) NIL MT.DISPLAY.MENUWINDOW) MT.DISPLAY.MENUWINDOW)) -) - -(MT.CREATEBM -(LAMBDA NIL (* \; "Edited 8-Sep-88 19:04 by Briggs") (MT.BITMAPCREATE (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE BITMAPNAME)) (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE SOURCEFILENAME)) (CADR (MEMBER "Shrinkfactor! " (FM.GETSTATE MT.DISPLAY.MENUWINDOW))) (MKATOM (CADR (MEMBER "Rotation! " (FM.GETSTATE MT.DISPLAY.MENUWINDOW)))))) -) - -(MT.BITMAPCREATE -(LAMBDA (BITMAPNAME INFILENAME BMSHRINKFACTOR ROTATION) (* \; "Edited 8-Sep-88 19:04 by Briggs") (PROG* (SCANFILE COMPRESSION RESOLUTION GREYLEVEL CONTRAST BRIGHTNESS SCANLINES SCANTYPE BYTESPERSCANLINE SCANDENSITY FINISHEDBM) (SETQ FINISHEDBM (MKATOM BITMAPNAME)) (|if| (AND INFILENAME FINISHEDBM) |then| (SETQ SCANFILE (OPENSTREAM INFILENAME (QUOTE INPUT))) (SETQ COMPRESSION (READ SCANFILE)) (SETQ RESOLUTION (READ SCANFILE)) (SETQ GREYLEVEL (READ SCANFILE)) (SETQ CONTRAST (READ SCANFILE)) (SETQ BRIGHTNESS (READ SCANFILE)) (SETQ SCANLINES (READ SCANFILE)) (SETQ BYTESPERSCANLINE (READ SCANFILE)) (* |;;;| "To Pick up trailing CR") (BIN SCANFILE) (|if| (EQ COMPRESSION (QUOTE NO)) |then| (SET FINISHEDBM (MT.CONVERTIMAGETOBM SCANFILE SCANLINES BYTESPERSCANLINE FINISHEDBM BMSHRINKFACTOR ROTATION)) (PUTPROP (MKATOM BITMAPNAME) (QUOTE RESOLUTION) RESOLUTION) |else| (MT.PRINT.STATUS "NOT YET IMPLEMENTED") (CLOSEF? SCANFILE)) |else| (MT.PRINT.STATUS "ERROR IN BITMAP OR SCANFILE NAME") (CLOSEF? SCANFILE)) (RETURN FINISHEDBM))) -) - -(MT.CONVERTIMAGETOBM -(LAMBDA (BFILE SCANLINES BYTESPERSCANLINE BMAPNAME SCANNERSHRINKFACTOR ROTATION) (* \; "Edited 8-Sep-88 19:04 by Briggs") (* |;;;| "Returns a bitmap that is shrunken (by factor) image of the data. Creates a temporary bitmap that is exact width but only 200 lines max long. That is shrunken then blt'ed into the final bitmap") (PROG (OFFSET BITWIDTH LINEOFFSET TEMPBM FINALBMOFFSET FINALBMWNAME FINALBMOFFSETFACTOR FINALBM FINALBMLINES CLINE BMPTR CBYTE SHRINKHEIGHTFACTOR SHRINKWIDTHFACTOR) (SETQ OFFSET 0) (SETQ BITWIDTH (ITIMES BYTESPERSCANLINE 8)) (SETQ LINEOFFSET (|if| (ODDP BYTESPERSCANLINE) |then| (IPLUS BYTESPERSCANLINE 1) |else| BYTESPERSCANLINE)) (SETQ TEMPBM (BITMAPCREATE BITWIDTH 200)) (SETQ FINALBMOFFSET -1) (SETQ FINALBMWNAME (MKATOM (CONCAT BMAPNAME (QUOTE WINDOW)))) (SETQ FINALBMOFFSETFACTOR (QUOTIENT 200 SCANNERSHRINKFACTOR)) (MT.PRINT.STATUS "SETTING UP BITMAP...") (* |;;;| "Set up the bmap parameters") (SETQ SHRINKHEIGHTFACTOR SCANNERSHRINKFACTOR) (SETQ SHRINKWIDTHFACTOR SCANNERSHRINKFACTOR) (* |;;;| "Set number of lines in final bitmap") (SETQ FINALBMLINES (IPLUS (IQUOTIENT SCANLINES SHRINKHEIGHTFACTOR) 1)) (* |;;;| "create the final bitmap FACTOR width and FACTOR high") (SETQ FINALBM (|if| (GEQ (ITIMES BITWIDTH SCANLINES) 2000000) |then| (MT.CREATE.BIG.BM BITWIDTH SCANLINES) |else| (BITMAPCREATE (QUOTIENT (ITIMES BYTESPERSCANLINE 8) SHRINKWIDTHFACTOR) FINALBMLINES))) (* |;;;| "make a window that you can bitblt the image to while you are working...") (* |;;;| "now start doing the serious work") (MT.PRINT.STATUS "WORKING...") (SETQ BMPTR (|fetch| BITMAPBASE |of| TEMPBM)) (|for| Y |from| 0 |to| (SUB1 SCANLINES) |do| (|if| (EQ OFFSET 200) |then| (* \; "We've done 200 lines, so now lets move it and reset the offset pointers!") (MT.PRINT.STATUS "BLT'ING A CHUNK...") (* |;;;| "first reset everything") (SETQ BMPTR (|fetch| BITMAPBASE |of| TEMPBM)) (SETQ OFFSET 0) (* |;;;| "set the new offset into the final bitmap DONT forget we are working top down in BMAP") (SETQ FINALBMOFFSET (IPLUS FINALBMOFFSET FINALBMOFFSETFACTOR)) (* |;;;| "BITBLT the shrunken bitmap (by SHRINKHEIGHTFACTOR) to the final bitmap and then the finalbitmap to the display window") (BITBLT (SHRINKBITMAP TEMPBM SHRINKWIDTHFACTOR SHRINKHEIGHTFACTOR) 0 0 FINALBM 0 (IDIFFERENCE FINALBMLINES FINALBMOFFSET)) (MT.PRINT.STATUS "DONE...WORKING...")) (SETQ CLINE (ITIMES OFFSET LINEOFFSET)) (|for| X |from| 0 |to| (IDIFFERENCE BYTESPERSCANLINE 1) |do| (\\PUTBASEBYTE BMPTR (PLUS X CLINE) (BIN BFILE))) (SETQ OFFSET (ADD1 OFFSET))) (* |;;;| "Now do the final shrink and blt") (MT.PRINT.STATUS " BLT'ING FINAL CHUNK...") (SETQ OFFSET (IPLUS (IMOD OFFSET SHRINKHEIGHTFACTOR) (QUOTIENT OFFSET SHRINKHEIGHTFACTOR))) (SETQ FINALBMOFFSET (IPLUS FINALBMOFFSET OFFSET)) (BITBLT (SHRINKBITMAP TEMPBM SHRINKWIDTHFACTOR SHRINKHEIGHTFACTOR) 0 (IDIFFERENCE FINALBMOFFSETFACTOR OFFSET) FINALBM 0 (IDIFFERENCE FINALBMLINES FINALBMOFFSET)) (MT.CREATE.DISPLAYWINDOW (|if| (EQ ROTATION (QUOTE LEFT)) |then| (MT.PRINT.STATUS "..ROTATING BITMAP...PLEASE WAIT") (SETQ FINALBM (ROTATE.BITMAP.LEFT FINALBM)) |elseif| (EQ ROTATION (QUOTE RIGHT)) |then| (MT.PRINT.STATUS "..ROTATING BITMAP...PLEASE WAIT") (SETQ FINALBM (ROTATE.BITMAP.RIGHT FINALBM)) |else| FINALBM)) (MT.PRINT.STATUS "DONE") (CLOSEF BFILE) (CLRPROMPT) (RETURN FINALBM))) -) - -(MT.CREATE.BIG.BM -(LAMBDA (WIDTH HEIGHT) (* \; "Edited 8-Sep-88 19:05 by Briggs") (LET* ((RASTERWIDTH (IQUOTIENT (IPLUS WIDTH (IDIFFERENCE 16 (IMOD WIDTH 16))) 16)) (TOTALBYTES (ITIMES HEIGHT (ITIMES RASTERWIDTH 2))) (NPAGES (COND ((ZEROP (IMOD TOTALBYTES 512)) (IQUOTIENT TOTALBYTES 512)) (T (ADD1 (IQUOTIENT TOTALBYTES 512))))) (BMPTR (\\ALLOCPAGEBLOCK NPAGES)) (REALLYBIGBM (|create| BITMAP BITMAPBASE _ BMPTR BITMAPRASTERWIDTH _ RASTERWIDTH BITMAPHEIGHT _ HEIGHT BITMAPWIDTH _ WIDTH BITMAPBITSPERPIXEL _ 1))) (BLTSHADE WHITESHADE REALLYBIGBM) REALLYBIGBM)) -) - -(MT.CREATE.DISPLAYWINDOW -(LAMBDA (BITMAP) (* \; "Edited 13-Mar-87 15:10 by rdc") (PROG (WINDOW) (RINGBELLS) (MT.PRINT.STATUS "SWEEP OUT WINDOW FOR BITMAP") (SETQ WINDOW (CREATEW NIL (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) (QUOTE BITMAPNAME)))) (WINDOWPROP WINDOW (QUOTE SRCBM) BITMAP) (WINDOWPROP WINDOW (QUOTE REPAINTFN) (FUNCTION MT.REPAINTWINDOW)) (WINDOWPROP WINDOW (QUOTE RESHAPEFN) (FUNCTION MT.RESHAPEWINDOW)) (WINDOWPROP WINDOW (QUOTE SCROLLFN) (FUNCTION SCROLLBYREPAINTFN)) (MT.RESHAPEWINDOW WINDOW) (RETURN WINDOW))) -) - -(MT.REPAINTWINDOW -(LAMBDA (WINDOW REGION) (* \; "Edited 8-Sep-88 19:05 by Briggs") (MOVETO (WINDOWPROP WINDOW (QUOTE BMORIGX)) (WINDOWPROP WINDOW (QUOTE BMORIGY)) WINDOW) (BITBLT (WINDOWPROP WINDOW (QUOTE SRCBM)) 0 0 WINDOW)) -) - -(MT.RESHAPEWINDOW -(LAMBDA (WINDOW) (* \; "Edited 8-Sep-88 19:05 by Briggs") (PROG NIL (DSPRESET WINDOW) (WINDOWPROP WINDOW (QUOTE BMORIGX) (DSPXPOSITION NIL WINDOW)) (WINDOWPROP WINDOW (QUOTE BMORIGY) (DSPYPOSITION NIL WINDOW)) (MT.REPAINTWINDOW WINDOW) (WINDOWPROP WINDOW (QUOTE EXTENT) (CREATEREGION 0 0 (BITMAPWIDTH (WINDOWPROP WINDOW (QUOTE SRCBM))) (BITMAPHEIGHT (WINDOWPROP WINDOW (QUOTE SRCBM))))))) -) -) - -(ADDTOVAR |BackgroundMenuCommands| ("MicrotekScanner" (MT.INIT) "Open Microtek Scanner Command and Display windows, initilalize RS232 port and verifies Microtek Scanner is ready")) - -(RPAQQ |BackgroundMenu| NIL) - -(RPAQQ MT.ICON #*(50 50)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@H@@@@H@@@@@@@@@@H@@@@H@@@@@@@@@@H@@@@OOOOL@@@@@AH@@@@H@@@L@@@@@BH@@@@H@@AD@@@@@DH@@@@H@@BD@@@@@HH@@@@H@@DD@@@@A@H@@@@H@@HD@@@@B@H@@@@H@A@D@@@@DCH@@@@N@B@D@@@@HCOOOOON@D@D@@@A@@@@@@@@@H@D@@@B@@@@@@@@A@@D@@@GOOOOOOOON@@H@@@D@@@@@@@@B@A@@@@D@@@@@@@@B@B@@@@D@@@@@@@@B@D@@@@DOOOOOOOOB@H@@@@DH@@@@@@ABA@@@@@DH@@@@@@ABB@@@@@DH@@@@@@ABD@@@@@DH@@@@@@ABH@@@@@DH@@@@@@AC@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@) - -(RPAQQ MT.ICON.MASK #*(50 50)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOH@@@@@@@@@@OOOOOOOOOL@@@@@AOOOOOOOOOL@@@@@COOOOOOOOOL@@@@@GOOOOOOOOOL@@@@@OOOOOOOOOOL@@@@AOOOOOOOOOOL@@@@COOOOOOOOOOL@@@@GOOOOOOOOOOL@@@@OOOOOOOOOOOL@@@AOOOOOOOOOOOL@@@COOOOOOOOOOOL@@@GOOOOOOOOOOOH@@@GOOOOOOOOOOO@@@@GOOOOOOOOOON@@@@GOOOOOOOOOOL@@@@GOOOOOOOOOOH@@@@GOOOOOOOOOO@@@@@GOOOOOOOOON@@@@@GOOOOOOOOOL@@@@@GOOOOOOOOOH@@@@@GOOOOOOOOO@@@@@@GOOOOOOOON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@) - -(RPAQQ BRIGHTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@OGH@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO) - -(RPAQQ CONTRASTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@OGH@@@@@@@@@@@@@AH@@@@@@@@@@@@@@GG@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@CF@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@AD@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO) - -(RPAQQ INITIALBRIGHTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO) - -(RPAQQ INITIALCONTRASTBAR #*(128 10)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AH@@@@@@@@@@@@@@@H@@@@@@@@@@@@@@AOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO) - -(RPAQQ LEFTARROW #*(10 10)@H@@AH@@CH@@GOL@OOL@OOL@GOL@CH@@AH@@@H@@) - -(RPAQQ MANCURSOR #*(9 9)@H@@AL@@CN@@GO@@OOH@GO@@CN@@AL@@@@@@) - -(RPAQQ RIGHTARROW #*(10 10)@D@@@F@@@G@@OOH@OOL@OOL@OOH@@G@@@F@@@D@@) - -(RPAQQ MT.POINTER #*(16 16)L@@@O@@@OL@@OO@@OOL@OOO@OOOLOOOOOOOOOOOLOOO@OOL@OO@@OL@@O@@@L@@@) - -(RPAQ? MT.BAUDRATE 19200) - -(RPAQ? MT.RS232C.FRAME.TIMEOUT 2) - -(RPAQ? MT.DISPLAYFRAME (QUOTE YES)) - -(RPAQ? MT.PAPERLENGTH 4) - -(RPAQ? MT.REDUCTION 0) - -(RPAQ? MT.CONTRAST 0) - -(RPAQ? MT.BRIGHTNESS 0) - -(RPAQ? MT.GREYLEVEL 0) - -(RPAQ? MT.DATACOMPRESSION (QUOTE NO)) - -(RPAQ? MT.BACKGROUND (QUOTE HALFTONE)) - -(RPAQ? MT.WINDOW (QUOTE LINEART)) - -(RPAQ? MT.FRAME (QUOTE (0 0 40 24))) - -(RPAQ? MT.FRAME.BOX (QUOTE (0 460 200 120))) - -(RPAQ? MT.TEXTW1 (QUOTE (0 0 0 0))) - -(RPAQ? MT.TEXTW2 (QUOTE (0 0 0 0))) - -(RPAQ? MT.TEXTW3 (QUOTE (0 0 0 0))) - -(RPAQ? MT.TEXTW4 (QUOTE (0 0 0 0))) - -(RPAQ? MT.TEXTW1BOX (QUOTE (0 0 0 0))) - -(RPAQ? MT.TEXTW2BOX (QUOTE (0 0 0 0))) - -(RPAQ? MT.TEXTW3BOX (QUOTE (0 0 0 0))) - -(RPAQ? MT.TEXTW4BOX (QUOTE (0 0 0 0))) - -(RPAQ? MT.HALFTONEW1 (QUOTE (0 0 0 0))) - -(RPAQ? MT.HALFTONEW2 (QUOTE (0 0 0 0))) - -(RPAQ? MT.HALFTONEW3 (QUOTE (0 0 0 0))) - -(RPAQ? MT.HALFTONEW4 (QUOTE (0 0 0 0))) - -(RPAQ? MT.HALFTONEW1BOX (QUOTE (0 0 0 0))) - -(RPAQ? MT.HALFTONEW2BOX (QUOTE (0 0 0 0))) - -(RPAQ? MT.HALFTONEW3BOX (QUOTE (0 0 0 0))) - -(RPAQ? MT.HALFTONEW4BOX (QUOTE (0 0 0 0))) - -(RPAQ? MT.OUTSTREAM NIL) - -(RPAQ? MT.INSTREAM NIL) - -(RPAQ? MT.BMSHRINKFACTOR 1) -(DECLARE\: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS MT.RS232C.FRAME.TIMEOUT MT.STATUSWINDOW MT.HEIGHTRULER MT.GRID MT.PAPERLENGTH MT.REDUCTION MT.BRIGHTNESS MT.CONTRAST MT.GREYLEVEL MT.DATACOMPRESSION MT.BACKGROUND MT.WINDOW MT.HEIGHTWINDOW MT.FRAME MT.FRAME.BOX MT.TEXTW1 MT.TEXTW2 MT.TEXTW3 MT.TEXTW4 MT.HALFTONEW1 MT.HALFTONEW2 MT.HALFTONEW3 MT.HALFTONEW4 MT.OUTSTREAM MT.INSTREAM BRIGHTBAR CONTRASTBAR LEFTARROW MANCURSOR RIGHTARROW) -) - -(PUTPROPS MICROTEK MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP")) -(PUTPROPS MICROTEK COPYRIGHT ("XEROX Corporation" 1987 1988)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (3704 36121 (MT.INIT 3714 . 5283) (MT.SHRINKFN 5285 . 5611) (MICROTEKSCANNER 5613 . 7281 -) (RULERX 7283 . 7517) (RULEX# 7519 . 7756) (RULERY 7758 . 8107) (RULEY# 8109 . 8346) (MT.GETLENGTH -8348 . 8889) (MT.CURSOR.IN 8891 . 9003) (MT.CURSOR.OUT 9005 . 9090) (MT.PRINT.STATUS 9092 . 9224) ( -MT.CONTROL.MENU 9226 . 16550) (MT.CHANGE.BRIGHTBAR 16552 . 16999) (MT.RAISEBRIGHTNESS 17001 . 17303) ( -MT.LOWERBRIGHTNESS 17305 . 17620) (MT.CHANGE.CONTRASTBAR 17622 . 18072) (MT.RAISECONTRAST 18074 . -18366) (MT.LOWERCONTRAST 18368 . 18673) (MT.SELECT.BACKGROUND 18675 . 23111) (MT.GETTRANSFRAME 23113 - . 25079) (MT.GETWINDOW1 25081 . 27252) (MT.GETWINDOW2 27254 . 29425) (MT.GETWINDOW3 29427 . 31598) ( -MT.GETWINDOW4 31600 . 33771) (MT.UPDATE.HTWINDOWS 33773 . 35312) (MT.DRAWAREABOX 35314 . 36119)) ( -36156 49637 (MT.COMMAND.MENU 36166 . 37143) (MT.GET.OUTFILENAME 37145 . 37317) (MT.SCAN 37319 . 37469) - (MT.START.SCANNING 37471 . 40210) (MT.SETUPSCANFILE 40212 . 40960) (MT.SEND.SCAN.PARAMETERS 40962 . -44005) (MT.SENDCOMMAND 44007 . 45314) (MT.COMPUTECHECKSUM 45316 . 46319) (MT.PRINT.ERROR.MSG 46321 . -47555) (MT.SENDACK 47557 . 47678) (MT.SENDNAK 47680 . 47802) (MT.STOP.SCANNING 47804 . 47994) ( -MT.RESET 47996 . 49039) (MT.PAGEMAP 49041 . 49208) (MT.QUIT 49210 . 49635)) (49710 58061 ( -MT.DISPLAY.MENU 49720 . 51177) (MT.GET.SOURCEFILENAME 51179 . 51357) (MT.GET.BITMAPNAME 51359 . 51529) - (MT.CREATEBM 51531 . 51899) (MT.BITMAPCREATE 51901 . 52955) (MT.CONVERTIMAGETOBM 52957 . 56302) ( -MT.CREATE.BIG.BM 56304 . 56871) (MT.CREATE.DISPLAYWINDOW 56873 . 57410) (MT.REPAINTWINDOW 57412 . -57644) (MT.RESHAPEWINDOW 57646 . 58059))))) -STOP diff --git a/obsolete/lispusers/MICROTEK.LCOM b/obsolete/lispusers/MICROTEK.LCOM deleted file mode 100644 index 2fa62f63..00000000 Binary files a/obsolete/lispusers/MICROTEK.LCOM and /dev/null differ diff --git a/obsolete/lispusers/MICROTEKPRINT b/obsolete/lispusers/MICROTEKPRINT deleted file mode 100644 index f61bea39..00000000 --- a/obsolete/lispusers/MICROTEKPRINT +++ /dev/null @@ -1,187 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "27-Jan-89 10:23:15" {DSK}MICROTEK>MICROTEKPRINT.;1 10179 - - changes to%: (FNS MT.CREATEPRINTMASTER) - - previous date%: "23-Jul-88 15:18:48" {ERINYES}MEDLEY>LISPUSERS>MICROTEKPRINT.;1) - - -(* " -Copyright (c) 1986, 1987, 1988, 1989 by XEROX Corporation. All rights reserved. -") - -(PRETTYCOMPRINT MICROTEKPRINTCOMS) - -(RPAQQ MICROTEKPRINTCOMS - [(P (FILESLOAD MICROTEK)) - (FNS MT.PRINT.MENU MT.GETXPOS MT.GETYPOS MT.CREATEPRINT MT.CREATEPRINTMASTER - MT.SELECT.SCALEFACTOR) - (P (IF (AND (BOUNDP 'MT.DISPLAY.MENUWINDOW) - (OPENWP MT.DISPLAY.MENUWINDOW)) - THEN - (MT.PRINT.MENU]) - -(FILESLOAD MICROTEK) -(DEFINEQ - -(MT.PRINT.MENU - [LAMBDA NIL (* ; - "Edited 21-May-87 09:23 by ronald clarke:xsis:xerox") - - (PROG (MENU.DESCRIPTION) - [SETQ MENU.DESCRIPTION - `(((PROPS ID MPRINT) - (GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BACKGROUND 23130) - (TYPE MOMENTARY LABEL "PRINT" BOX 3 LEFT 0 BOTTOM 2 FONT (MODERN 12 BOLD) - SELECTEDFN MT.CREATEPRINT) - (TYPE STATE LABEL "Printer!: " ID PRINTERTYPE MENUITEMS (8044 4045) - INITSTATE 8044 LINKS (DISPLAY (GROUP PRINTER)) - FONT - (MODERN 10 BOLD) - BOX 1 LEFT 60 BOTTOM 3) - (TYPE DISPLAY ID PRINTER LABEL "" LEFT 115 BOTTOM 3 BOX 1 MAXWIDTH 30) - (TYPE MOMENTARY LABEL "XPOS!: " SELECTEDFN MT.GETXPOS FONT (MODERN 10 BOLD) - LEFT 175 BOTTOM 3 BOX 1) - (TYPE EDIT ID XPOS LABEL 0 MAXWIDTH 45 LEFT 220 BOTTOM 3 BOX 1) - (TYPE MOMENTARY LABEL "YPOS!: " SELECTEDFN MT.GETYPOS FONT (MODERN 10 BOLD) - LEFT 280 BOTTOM 3 BOX 1) - (TYPE EDIT ID YPOS LABEL 0 MAXWIDTH 45 LEFT 325 BOTTOM 3 BOX 1) - (TYPE MOMENTARY LABEL "SCALE!: " FONT (MODERN 10 BOLD) - LEFT 385 BOTTOM 3 BOX 1 SELECTEDFN MT.SELECT.SCALEFACTOR) - (TYPE EDIT LABEL "1:1" ID SCALEFACTOR LEFT 435 BOTTOM 3 BOX 1] - (SETQ MT.PRINT.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Print Menu" 23130 5)) - (OPENW MT.PRINT.MENUWINDOW) - (ATTACHWINDOW MT.PRINT.MENUWINDOW MT.DISPLAY.MENUWINDOW 'BOTTOM 'JUSTIFY]) - -(MT.GETXPOS - [LAMBDA NIL (* ; - "Edited 21-May-87 09:15 by ronald clarke:xsis:xerox") - - (FM.EDITITEM (FM.GETITEM 'XPOS NIL MT.PRINT.MENUWINDOW) - MT.PRINT.MENUWINDOW]) - -(MT.GETYPOS - [LAMBDA NIL (* ; - "Edited 21-May-87 09:17 by ronald clarke:xsis:xerox") - - (FM.EDITITEM (FM.GETITEM 'YPOS NIL MT.PRINT.MENUWINDOW) - MT.PRINT.MENUWINDOW]) - -(MT.CREATEPRINT - [LAMBDA NIL (* ; - "Edited 21-May-87 09:29 by ronald clarke:xsis:xerox") - - (PROG NIL - (if (AND [BOUNDP (SETQ BITMAP (MKATOM (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW) - 'BITMAPNAME] - (BITMAPP (SETQ BITMAP (EVAL BITMAP))) - (if (OR [AND (EQ (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) - 'PRINTERTYPE)) - 4045) - (FMEMB (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) - 'SCALEFACTOR)) - '(4%:1 2%:1 1%:1 1%:2 1%:4] - (EQ (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) - 'PRINTERTYPE)) - 8044)) - then T - else (FLASHWINDOW MT.STATUSWINDOW 3) - (MT.PRINT.STATUS "Not a valid scale for 4045 printer") - (RETURN NIL))) - then (MT.PRINT.STATUS "") - [MT.CREATEPRINTMASTER BITMAP (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) - 'XPOS)) - (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) - 'YPOS)) - (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) - 'SCALEFACTOR] - else (FLASHWINDOW MT.STATUSWINDOW 3) - (MT.PRINT.STATUS "This atom is not a bitmap") - (RETURN NIL]) - -(MT.CREATEPRINTMASTER - [LAMBDA (BITMAP X Y SCALEFACTOR) (* ; "Edited 27-Jan-89 10:21 by rclarke.pa") - (PROG (IPS SCANFACTOR SCALE) - [if (EQP (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) - 'PRINTERTYPE) - 8044) - then (if [NOT (SETQ SCANFACTOR - (LISTGET '(0 0.24 5 0.252 10 0.266 15 0.282 20 0.3 25 0.32 33 - 0.36 35 0.369 40 0.4 45 0.439 50 0.48 55 0.533 60 - 0.6 67 0.7200001 70 0.8 75 0.96) - (GETPROP (MKATOM (LISTGET (FM.GETSTATE - MT.DISPLAY.MENUWINDOW) - 'BITMAPNAME)) - 'RESOLUTION] - then (MT.PRINT.STATUS "") - (FLASHWINDOW MT.STATUSWINDOW 3) - (if [NOT (NUMBERP (SETQ SCANFACTOR - (MKATOM (PROMPTFORWORD - "Resolution not on Bitmap proplist. Enter #:" - "1" NIL MT.STATUSWINDOW] - then (FLASHWINDOW MT.STATUSWINDOW 2) - (MT.PRINT.STATUS "This is not a number") - (RETURN NIL)) - (MT.PRINT.STATUS "")) - [SETQ SCALE (FQUOTIENT (CAR (UNPACK SCALEFACTOR)) - (CADDR (UNPACK SCALEFACTOR] - (SETQ IPS (OPENIMAGESTREAM '{LPT}.IP)) - (SCALEDBITBLT BITMAP 0 0 IPS X Y 21590 27940 'INPUT 'REPLACE NIL - '(0 0 21590 27940) - (FTIMES SCALE SCANFACTOR)) - else (if [NOT (SETQ SCANFACTOR - (LISTGET '(0 1 5 1 10 1 15 1 20 1 25 1 33 1 35 1 40 2 45 2 50 2 55 - 2 60 2 67 4 70 4 75 4) - (GETPROP (MKATOM (LISTGET (FM.GETSTATE - MT.DISPLAY.MENUWINDOW) - 'BITMAPNAME)) - 'RESOLUTION] - then (MT.PRINT.STATUS "") - (FLASHWINDOW MT.STATUSWINDOW 3) - (if [NOT (NUMBERP (SETQ SCANFACTOR - (MKATOM (PROMPTFORWORD - "Resolution not on Bitmap proplist. Enter #:" - "1" NIL MT.STATUSWINDOW] - then (FLASHWINDOW MT.STATUSWINDOW 2) - (MT.PRINT.STATUS "This is not a number") - (RETURN NIL)) - (MT.PRINT.STATUS "")) - [SETQ SCALE (FQUOTIENT (CAR (UNPACK SCALEFACTOR)) - (CADDR (UNPACK SCALEFACTOR] - (SETQ IPS (OPENIMAGESTREAM '{LPT}.4045XLP)) - (if (GREATERP (FTIMES SCALE SCANFACTOR) - 4) - then (FLASHWINDOW MT.STATUSWINDOW 2) - (MT.PRINT.STATUS "Not a valid scale for reduction used on this bitmap") - (RETURN NIL)) - (SCALEDBITBLT BITMAP 0 0 IPS X Y 2550 3300 'INPUT 'REPLACE NIL - '(0 0 2550 3300) - (FIXR (FTIMES SCALE SCANFACTOR] - (CLOSEF IPS) - (MT.PRINT.STATUS "Bitmap sent to printer"]) - -(MT.SELECT.SCALEFACTOR - [LAMBDA NIL (* ; - "Edited 21-May-87 09:26 by ronald clarke:xsis:xerox") - - (PROG [(PRINTERTYPE (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW) - 'PRINTERTYPE] - [if (EQP PRINTERTYPE 8044) - then (SETQ FACTORS - '(8%:1 7%:1 6%:1 5%:1 4%:1 3%:1 2%:1 1%:1 1%:2 1%:3 1%:4 1%:5 1%:6 1%:7 1%:8)) - else (SETQ FACTORS '(4%:1 2%:1 1%:1 1%:2 1%:4] - (FM.CHANGESTATE (FM.GETITEM 'SCALEFACTOR NIL MT.PRINT.MENUWINDOW) - (MENU (create MENU - ITEMS _ FACTORS)) - MT.PRINT.MENUWINDOW]) -) - -(IF (AND (BOUNDP 'MT.DISPLAY.MENUWINDOW) - (OPENWP MT.DISPLAY.MENUWINDOW)) - THEN (MT.PRINT.MENU)) -(PUTPROPS MICROTEKPRINT COPYRIGHT ("XEROX Corporation" 1986 1987 1988 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (794 9954 (MT.PRINT.MENU 804 . 2630) (MT.GETXPOS 2632 . 2912) (MT.GETYPOS 2914 . 3194) ( -MT.CREATEPRINT 3196 . 5070) (MT.CREATEPRINTMASTER 5072 . 9197) (MT.SELECT.SCALEFACTOR 9199 . 9952)))) -) -STOP diff --git a/obsolete/lispusers/MICROTEKPRINT.LCOM b/obsolete/lispusers/MICROTEKPRINT.LCOM deleted file mode 100644 index b08965b9..00000000 Binary files a/obsolete/lispusers/MICROTEKPRINT.LCOM and /dev/null differ diff --git a/obsolete/lispusers/MTP b/obsolete/lispusers/MTP deleted file mode 100644 index 620f6552..00000000 --- a/obsolete/lispusers/MTP +++ /dev/null @@ -1,737 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - -(FILECREATED " 1-Feb-2022 17:06:07" {DSK}kaplan>Local>medley3.5>my-medley>lispusers>MTP.;2 31571 - - :CHANGES-TO (VARS MTPCOMS) - (FNS MTP.MAKEANSWERFORM) - - :PREVIOUS-DATE "19-May-86 16:54:58" -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>MTP.;1) - - -(* ; " -Copyright (c) 1983-1984, 1986 by Xerox Corporation. -") - -(PRETTYCOMPRINT MTPCOMS) - -(RPAQQ MTPCOMS - ((COMS (* Lafite mode MTP) - (FNS MTP.GET.USERDATA MTP.DELIVERMESSAGE MTP.PREPARE.SEND MTP.MAKEANSWERFORM) - (ADDVARS (LAFITEMODELST (MTP MTP.PREPARE.SEND MTP.DELIVERMESSAGE MTP.MAKEANSWERFORM - MTP.GET.USERDATA))) - (FNS \MTP.AUTHENTICATE \MTP.COERCE.MSG \MTP.FILL \MTP.INDENT \MTP.CLRBUF - \MTP.PRINTADDRESSES) - (INITVARS (MTP.SERVER) - (MTP.LINELENGTH 70) - (MTP.RIGHTMARGINWIDTH 10) - (MTP.FILLMSGFLG %'ASK) - (MTP.INSERTANSWERFLG T) - (MTP.INSERTANSWERNSPACES 3))) - [COMS (* MTP mail server) - (FNS MTP.OPENMAILBOX MTP.POLLNEWMAIL MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE - MTP.CLOSEMAILBOX) - (FNS \MTP.ENDOFMESSAGESTATE \MTP.POLLNEWMAIL) - (ADDVARS (MAILSERVERTYPES (MTP MTP.POLLNEWMAIL MTP.OPENMAILBOX MTP.NEXTMESSAGE - MTP.RETRIEVEMESSAGE MTP.CLOSEMAILBOX ETHERPORT] - (FILES LAFITE) - (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MTPMAILBOX MTPPARSE) - (CONSTANTS \PUPSOCKET.MTP \PUPSOCKET.MISCSERVICES) - (CONSTANTS * PUPTYPES) - (GLOBALVARS MTP.SERVER MTP.LINELENGTH MTP.RIGHTMARGINWIDTH MTP.FILLMSGFLG - MTP.INSERTANSWERFLG MTP.INSERTANSWERNSPACES \LAPARSE.FULL LAFITEEDITORFONT - UNSUPPLIEDFIELDSTR MESSAGESTR \LAFITEUSERDATA MAILSERVERTYPES - \LAFITE.AUTHENTICATION.FAILURE) - (FILES (LOADCOMP) - LAFITE DPUPFTP)))) - - - -(* Lafite mode MTP) - -(DEFINEQ - -(MTP.GET.USERDATA - [LAMBDA NIL (* drc%: "29-Apr-86 23:31") - (LET ((PORT (ETHERPORT MTP.SERVER)) - USER/PWD) - (SETQ \LAFITEUSERDATA - (if (NULL PORT) - then (PRINTOUT PROMPTWINDOW T "MTP.SERVER not found -- " MTP.SERVER T) - (SETQ \LAFITE.AUTHENTICATION.FAILURE "No Server") - NIL - else (SETQ USER/PWD (\INTERNAL/GETPASSWORD MTP.SERVER)) - (AND (\MTP.AUTHENTICATE MTP.SERVER USER/PWD) - (create LAFITEUSERDATA - FULLUSERNAME _ (CAR USER/PWD) - ENCRYPTEDPASSWORD _ (CDR USER/PWD) - SHORTUSERNAME _ (CAR USER/PWD) - MAILSERVERS _ (LIST (create MAILSERVER - MAILPORT _ PORT - MAILSERVERNAME _ MTP.SERVER - MAILSERVEROPS _ (CDR (ASSOC %'MTP - MAILSERVERTYPES]) - -(MTP.DELIVERMESSAGE - [LAMBDA (MSG PARSE W ABORTW) (* drc%: "29-Apr-86 23:38") - (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG)) - (RESETLST - (LET* ((USERDATA (\LAFITE.GET.USER.DATA)) - (USER (fetch (LAFITEUSERDATA FULLUSERNAME) of USERDATA)) - (MAILSERVER (CAR (fetch (LAFITEUSERDATA MAILSERVERS) of USERDATA))) - [PLIST (LIST (LIST %'MAILBOX (fetch (MTPPARSE MAILBOX) of PARSE)) - (LIST %'SENDER (CONCAT USER "@" (fetch MAILSERVERNAME of MAILSERVER] - (PW (GETPROMPTWINDOW W)) - (TEXT (\MTP.COERCE.MSG MSG (fetch (MTPPARSE EOH) of PARSE) - PW)) - INS OUTS) - (AND (WINDOWPROP ABORTW %'ABORT) - (ERROR!)) - (PRINTOUT PW "delivering...") - (SETQ INS (OPENBSPSTREAM (CONS (CAR (fetch (MAILSERVER MAILPORT) of MAILSERVER)) - \PUPSOCKET.MTP) - NIL %'\FTP.ERRORHANDLER)) - (if INS - then (RESETSAVE NIL (LIST %'CLOSEBSPSTREAM INS 5000)) - else (PRINTOUT PW (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER) - " not responding. ") - (ERROR!)) - (SETQ OUTS (BSPOUTPUTSTREAM INS)) - (FTPPUTMARK OUTS (MARK# STORE-MAIL)) - (\FTP.PRINTPLIST OUTS PLIST) - (FTPPUTMARK OUTS (MARK# EOC)) - (SELECTC (FTPGETMARK INS) - ((MARK# YES) - (FTPGETCODE INS) - (\FTP.FLUSH.TO.EOC INS (AND FTPDEBUGFLG FTPDEBUGLOG))) - ((MARK# NO) - (FTPGETCODE INS) - (\FTP.FLUSH.TO.EOC INS PW) - (ERROR!)) - (\FTPERROR INS)) - (FTPPUTMARK OUTS (MARK# HERE-IS-FILE)) - (PRINTOUT OUTS (fetch (MTPPARSE FROMLINE) of PARSE) - T) - (PRINTOUT OUTS (fetch (MTPPARSE DATELINE) of PARSE) - T) - (COPYBYTES TEXT OUTS) - (if (WINDOWPROP ABORTW %'ABORT) - then (FTPPUTMARK OUTS (MARK# NO)) - (ERROR!) - else (FTPPUTMARK OUTS (MARK# YES))) - (FTPPUTMARK OUTS (MARK# EOC)) - (SELECTC (FTPGETMARK INS) - ((MARK# YES) - (FTPGETCODE INS) - (\FTP.FLUSH.TO.EOC INS (AND FTPDEBUGFLG FTPDEBUGLOG))) - (PROGN (FTPGETCODE INS) - (\FTP.FLUSH.TO.EOC INS PROMPTWINDOW) - (ERROR!))) - T))]) - -(MTP.PREPARE.SEND - [LAMBDA (MSG W) (* drc%: "17-May-86 17:34") - (LET* [(PARSE (\LAFITE.PREPARE.SEND MSG W)) - (RECIPIENTS (APPEND (CDR (FASSOC %'To PARSE)) - (CDR (FASSOC %'cc PARSE] - (OR PARSE (\SENDMESSAGEFAIL W "Bad message format.")) - (AND (FASSOC %'Sender PARSE) - (\SENDMESSAGEFAIL W "Can't specify Sender!")) - (AND (FASSOC %''Date PARSE) - (\SENDMESSAGEFAIL W "Can't specify Date!")) - (OR RECIPIENTS (\SENDMESSAGEFAIL W "No recipients?")) - (create MTPPARSE - FROMLINE _ (CONCAT (if (ASSOC %'From PARSE) - then "Sender: " - else "From: ") - (FULLUSERNAME)) - MAILBOX _ [CONCATLIST (for TAIL on RECIPIENTS - collect (if (CDR TAIL) - then (CONCAT (CAR TAIL) - ", ") - else (CAR TAIL] - EOH _ (CADR (FASSOC %'EOF PARSE)) - DATELINE _ (CONCAT "Date: " (DATE (DATEFORMAT DAY.OF.WEEK SPACES TIME.ZONE - NO.SECONDS]) - -(MTP.MAKEANSWERFORM - [LAMBDA (MSGS FOLDER) (* ; "Edited 1-Feb-2022 17:05 by rmk") - (* drc%: "19-May-86 15:39") - (PROG ((OLD.MSG (OR (CAR (LISTP MSGS)) - MSGS)) - [INSERT? (AND MTP.INSERTANSWERFLG (MENU (\LAFITE.CREATE.MENU %' (("Yes" T - "Insert the text of the message being answered" - ) - ("No" NIL - "Normal answer form" - ) - ("Abort" %'ABORT - "Abort Answer command" - )) - "Insert Message?"] - (OLD.TEXT (\LAFITE.OPEN.FOLDER FOLDER %'INPUT)) - START END OLD.FIELDS SUBJECT FROM TO CC DATE REPLY-TO SENDER NEW.MSG NEW.TO NEW.CC) - (if (EQ INSERT? %'ABORT) - then (RETURN)) - (SETQ START (fetch (LAFITEMSG START) of OLD.MSG)) - (SETQ END (fetch (LAFITEMSG END) of OLD.MSG)) - (SETQ OLD.FIELDS (LAFITE.PARSE.HEADER OLD.TEXT \LAPARSE.FULL START END)) - (for PAIR in OLD.FIELDS do (SELECTQ (CAR PAIR) - (Subject (SETQ SUBJECT (CADR PAIR))) - (From (SETQ FROM (CDR PAIR))) - (To (SETQ TO (CDR PAIR))) - (cc (SETQ CC (CDR PAIR))) - (Date (SETQ DATE (CADR PAIR))) - (Reply-to (SETQ REPLY-TO (CDR PAIR))) - (Sender (SETQ SENDER (CDR PAIR))) - NIL)) - (SETQ NEW.TO (OR REPLY-TO FROM SENDER)) - (OR NEW.TO (RETURN (LAB.PROMPTPRINT FOLDER "Can't reply -- no From or Sender"))) - (SETQ NEW.MSG (OPENTEXTSTREAM NIL NIL NIL NIL (LIST %'FONT LAFITEEDITORFONT))) - (LINELENGTH MAX.SMALLP NEW.MSG) - (PRINTOUT NEW.MSG "Subject: ") - (if (NOT (STRING-EQUAL (SUBSTRING SUBJECT 1 3) - "Re:")) - then (printout NEW.MSG "Re: ")) - (PRINTOUT NEW.MSG (OR SUBJECT UNSUPPLIEDFIELDSTR) - T) - (AND FROM (PRINTOUT NEW.MSG "In-reply-to: " (CAR FROM) - "'s message of " DATE T)) - (PRINTOUT NEW.MSG "To: ") - (\MTP.PRINTADDRESSES NEW.TO NEW.MSG) - (SETQ NEW.CC (LA.SETDIFFERENCE (if REPLY-TO - then (LIST (FULLUSERNAME)) - else (LA.REMOVEDUPLICATES (APPEND TO CC))) - NEW.TO)) - (if NEW.CC - then (PRINTOUT NEW.MSG "cc: ") - (\MTP.PRINTADDRESSES NEW.CC NEW.MSG)) - (TERPRI NEW.MSG) - (if INSERT? - then (\MTP.FILL OLD.TEXT NEW.MSG MTP.INSERTANSWERNSPACES MTP.LINELENGTH START END) - (PRINTOUT NEW.MSG MESSAGESTR T) - else (LET [(SELECTPOSITION (ADD1 (GETFILEPTR NEW.MSG] - (PRINTOUT NEW.MSG MESSAGESTR T) - (TEDIT.SETSEL NEW.MSG SELECTPOSITION (NCHARS MESSAGESTR) - %'RIGHT T))) - (RETURN NEW.MSG]) -) - -(ADDTOVAR LAFITEMODELST (MTP MTP.PREPARE.SEND MTP.DELIVERMESSAGE MTP.MAKEANSWERFORM MTP.GET.USERDATA)) -(DEFINEQ - -(\MTP.AUTHENTICATE - [LAMBDA (HOST USER/PWD) (* drc%: "25-Apr-86 13:06") - - (* I couldn't get PUP authentication to work w/ our Misc server, so we just check - for mailbox existence. Password checking is done when retrieving mail.) - - (LET* ((RESPONSE (\MTP.POLLNEWMAIL HOST (CAR USER/PWD))) - (TYPE (CAR RESPONSE)) - (MESSAGE (CDR RESPONSE))) - (SELECTC TYPE - ((LIST \PT.NEWMAIL \PT.NONEWMAIL) - T) - ((LIST \PT.NOMAILBOX \PT.ERROR) - (SETQ \LAFITE.AUTHENTICATION.FAILURE MESSAGE) - NIL) - (NIL (PRINTOUT PROMPTWINDOW T HOST " not responding to authentication request." T) - (SETQ \LAFITE.AUTHENTICATION.FAILURE "No Server") - NIL) - NIL]) - -(\MTP.COERCE.MSG - [LAMBDA (MSG EOH ECHOSTREAM) (* drc%: "19-May-86 16:08") - (DECLARE (GLOBALVARS MTP.LINELENGTH)) - (LET [(STREAM (COERCETEXTOBJ MSG %'STREAM)) - (FILL? (SELECTQ MTP.FILLMSGFLG - (ALWAYS T) - (ASK (MENU (\LAFITE.CREATE.MENU %' (("Yes" T - "Break long lines in message to MTP.LINELENGTH" - ) - ("No" NIL "Deliver message as is") - ("Abort" %'ABORT "Abort deliver command")) - "Fill Text?"))) - (NEVER NIL) - (SHOULDNT] - (if (EQ FILL? %'ABORT) - then (ERROR!)) - (if FILL? - then (PRINTOUT ECHOSTREAM "filling...") - (LET ((OUTS (OPENSTREAM %'{NODIRCORE} %'BOTH))) - (COPYBYTES STREAM OUTS 0 EOH) - (\MTP.FILL STREAM OUTS 0 MTP.LINELENGTH) - (SETFILEPTR OUTS 0) - OUTS) - else STREAM]) - -(\MTP.FILL - [LAMBDA (INS OUTS LMARGIN RMARGIN START END) (* drc%: "19-May-86 16:46") - - (* * Copy bytes from INS to OUTS, indenting to LMARGIN. - New lines started at last space before RMARGIN -- - unless the line ends before RMARGIN + MTP.RIGHTMARGINWIDTH anyway. - Copy from START (default is current pos) to END - (default is EOF)%.) - - (until (GEQ (GETFILEPTR INS) - END) as COLUMN from (ADD1 LMARGIN) bind (LINEBUF _ (OPENSTREAM %'{NODIRCORE} %'BOTH)) - (CARRY _ LMARGIN) - (END _ (OR END (GETEOFPTR INS))) - (LIMIT _ (IPLUS RMARGIN MTP.RIGHTMARGINWIDTH) - ) - (EDGE _ (ADD1 RMARGIN)) - BYTE SPACE SPACES - first (AND START (SETFILEPTR INS START)) - (\MTP.INDENT INS OUTS END LMARGIN) eachtime (SETQ BYTE (BIN INS)) - (SELCHARQ BYTE - ((SPACE TAB) - (BOUT LINEBUF BYTE) - (push SPACES COLUMN)) - (EOL (SETFILEPTR LINEBUF 0) - (\MTP.CLRBUF LINEBUF OUTS) - (BOUT OUTS (CHARCODE EOL)) - (\MTP.INDENT INS OUTS END LMARGIN) - (SETQ CARRY (SETQ COLUMN LMARGIN))) - (BOUT LINEBUF BYTE)) - when (IGREATERP COLUMN LIMIT) do [if (SETQ SPACE (for SPACE in SPACES - thereis (LEQ SPACE EDGE))) - then (* dump line up to space) - (COPYBYTES LINEBUF OUTS 0 (SUB1 (IDIFFERENCE SPACE - CARRY))) - (BIN LINEBUF) - (* eat up space) - (SETQ COLUMN (IPLUS LMARGIN (IDIFFERENCE COLUMN - SPACE))) - else (* punt) - (COPYBYTES LINEBUF OUTS 0 (IDIFFERENCE RMARGIN CARRY)) - (SETQ COLUMN (ADD1 (IPLUS LMARGIN MTP.RIGHTMARGINWIDTH - ] - (BOUT OUTS (CHARCODE EOL)) - (\MTP.INDENT INS OUTS END LMARGIN) - (\MTP.CLRBUF LINEBUF OUTS) - (SETQ SPACES) - (SETQ CARRY COLUMN) finally (SETFILEPTR LINEBUF 0) - (COPYBYTES LINEBUF OUTS]) - -(\MTP.INDENT - [LAMBDA (INS OUTS END LMARGIN) (* drc%: "18-May-86 18:31") - - (* * indent OUTS to LMARGIN, unless at end of INS or on an empty line) - - (if (AND (ILESSP (GETFILEPTR INS) - END) - (NEQ (PEEKCCODE INS) - (CHARCODE EOL))) - then (to LMARGIN do (BOUT OUTS (CHARCODE SPACE]) - -(\MTP.CLRBUF - [LAMBDA (INS OUTS) (* drc%: "30-Apr-86 00:14") - - (* * Flush INS to OUTS, and then clear INS) - - (COPYBYTES INS OUTS) - (\SETEOFPTR INS 0) - (SETFILEPTR INS 0]) - -(\MTP.PRINTADDRESSES - [LAMBDA (ADDRESSLIST STREAM) (* bvm%: "20-Dec-83 18:20") - (for ADDR in ADDRESSLIST bind NTHTIME when ADDR do (COND - (NTHTIME (PRIN1 ", " STREAM)) - (T (SETQ NTHTIME T))) - (PRIN1 ADDR STREAM)) - (TERPRI STREAM]) -) - -(RPAQ? MTP.SERVER ) - -(RPAQ? MTP.LINELENGTH 70) - -(RPAQ? MTP.RIGHTMARGINWIDTH 10) - -(RPAQ? MTP.FILLMSGFLG %'ASK) - -(RPAQ? MTP.INSERTANSWERFLG T) - -(RPAQ? MTP.INSERTANSWERNSPACES 3) - - - -(* MTP mail server) - -(DEFINEQ - -(MTP.OPENMAILBOX - [LAMBDA (PORT USER PWD MAILSERVER) (* drc%: "20-Apr-86 17:49") - (PROG ((MTP.PORT (CONS (CAR PORT) - \PUPSOCKET.MTP)) - (HOST (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER)) - (LOGINFO (CONS USER PWD)) - INS OUTS) - (SELECTQ (MTP.POLLNEWMAIL PORT USER) - (NIL (RETURN %'EMPTY)) - (? (RETURN)) - NIL) - NEWCONNECTION - (OR (SETQ INS (OPENBSPSTREAM MTP.PORT NIL (FUNCTION \FTP.ERRORHANDLER))) - (RETURN)) - (SETQ OUTS (BSPOUTPUTSTREAM INS)) - RETRY - (FTPPUTMARK OUTS (MARK# RETRIEVE-MAIL)) - [\FTP.PRINTPLIST OUTS (LIST (LIST %'USER-NAME (CAR LOGINFO)) - (LIST %'USER-PASSWORD (CDR LOGINFO] - (.EOC. OUTS) - (SELECTC (FTPGETMARK INS) - ((MARK# NO) - (SELECTQ (FTPGETCODE INS) - ((16 17) (* bad user/pwd) - (PRINTOUT PROMPTWINDOW T HOST " : ") - (\FTP.FLUSH.TO.EOC INS PROMPTWINDOW) - (TERPRI PROMPTWINDOW) - (SETQ LOGINFO (\INTERNAL/GETPASSWORD HOST T NIL NIL NIL %'UNIX)) - (MTP.GET.USERDATA) - (if (BSPOPENP INS %'INPUT) - then (GO RETRY) - else (GO NEWCONNECTION))) - (RETURN (\FTPERROR INS "MTP error")))) - ((MARK# HERE-IS-PLIST) - (RETURN (CONS (create MTPMAILBOX - MTPIN _ INS - MTPOUT _ OUTS - MTPSTATE _ %'OPEN)))) - (RETURN (\FTPERROR NIL "MTP error"]) - -(MTP.POLLNEWMAIL - [LAMBDA (HOSTPORT USER) (* drc%: "25-Apr-86 12:44") - (LET* ((RESPONSE (\MTP.POLLNEWMAIL HOSTPORT USER)) - (TYPE (CAR RESPONSE)) - (MESSAGE (CDR RESPONSE))) - (SELECTC TYPE - (\PT.NEWMAIL T) - (\PT.NONEWMAIL NIL) - ((LIST \PT.NOMAILBOX \PT.ERROR) - (printout PROMPTWINDOW T HOSTPORT " : " MESSAGE T) - %'?) - (NIL %'?) - NIL]) - -(MTP.NEXTMESSAGE - [LAMBDA (MAILBOX) (* bvm%: " 6-JUL-83 14:27") - (SELECTQ (fetch MTPSTATE of MAILBOX) - (EMPTY NIL) - (OPEN [PROG ((PLIST (READPLIST (fetch MTPIN of MAILBOX))) - (NEXTSTATE 'MESSAGE)) - (RETURN (PROG1 (OR (for PAIR in PLIST - do (SELECTQ (CAR PAIR) - (LENGTH (push $$VAL 'LENGTH (CADR PAIR))) - (OPENED (SELECTQ (CADR PAIR) - ((YES Yes yes) - (push $$VAL 'EXAMINED T)) - NIL)) - (DELETED (SELECTQ (CADR PAIR) - ((YES Yes yes) - (push $$VAL 'DELETEDFLG T) - (FTPGETMARK (fetch MTPIN - of MAILBOX)) - (\FTP.FLUSH.TO.MARK (fetch MTPIN - of MAILBOX) - ) - (SETQ NEXTSTATE - (\MTP.ENDOFMESSAGESTATE - (fetch MTPIN of MAILBOX)))) - NIL)) - NIL)) - T) - (replace MTPSTATE of MAILBOX with NEXTSTATE]) - (ERROR "Mailbox not in good state for NEXTMESSAGE" MAILBOX]) - -(MTP.RETRIEVEMESSAGE - [LAMBDA (MAILBOX OUTSTREAM) (* bvm%: " 6-JUL-83 14:27") - (SELECTQ (fetch MTPSTATE of MAILBOX) - (MESSAGE [COND - ((EQ (FTPGETMARK (fetch MTPIN of MAILBOX)) - (MARK# HERE-IS-FILE)) - (\FTP.FLUSH.TO.MARK (fetch MTPIN of MAILBOX) - OUTSTREAM) - (replace MTPSTATE of MAILBOX with (\MTP.ENDOFMESSAGESTATE (fetch MTPIN - of MAILBOX]) - (\FTPERROR]) - -(MTP.CLOSEMAILBOX - [LAMBDA (MAILBOX FLUSHP) (* bvm%: " 9-May-84 15:35") - (COND - ((BSPOPENP (fetch MTPIN of MAILBOX)) - (PROG1 [COND - ((AND FLUSHP (EQ (fetch MTPSTATE of MAILBOX) - 'EMPTY)) - (FTPPUTMARK (fetch MTPOUT of MAILBOX) - (MARK# FLUSH-MAILBOX)) - (.EOC. (fetch MTPOUT of MAILBOX)) - (SELECTC (FTPGETMARK (fetch MTPIN of MAILBOX)) - ((MARK# YES) - (FTPGETCODE (fetch MTPIN of MAILBOX)) - (\FTP.FLUSH.TO.EOC (fetch MTPIN of MAILBOX) - (.FTPDEBUGLOG.)) - T) - ((MARK# NO) - (FTPGETCODE (fetch MTPIN of MAILBOX)) - (\FTP.FLUSH.TO.EOC (fetch MTPIN of MAILBOX) - PROMPTWINDOW) - '?) - (PROGN (\FTPERROR) - '?] - (CLOSEBSPSTREAM (fetch MTPIN of MAILBOX) - 5000))]) -) -(DEFINEQ - -(\MTP.ENDOFMESSAGESTATE - [LAMBDA (INSTREAM) (* bvm%: " 5-SEP-83 18:08") - (SELECTC (FTPGETMARK INSTREAM) - ((MARK# HERE-IS-PLIST) - 'OPEN) - ((MARK# YES) - (FTPGETCODE INSTREAM) - (\FTP.FLUSH.TO.EOC INSTREAM (.FTPDEBUGLOG.)) - 'EMPTY) - ((MARK# NO) - (FTPGETCODE INSTREAM) - (\FTP.FLUSH.TO.EOC INSTREAM PROMPTWINDOW) - 'ERROR) - (\FTPERROR]) - -(\MTP.POLLNEWMAIL - [LAMBDA (HOSTPORT USER) (* drc%: "25-Apr-86 12:28") - - (* * Does a Laurel-style mail check for USER on machine HOSTPORT, returning NIL - (timeout) or a cons of the PUP type of the response and the contents of the - response) - - (LET ((SOC (\GETMISCSOCKET)) - (OUTPUP (ALLOCATE.PUP)) - INPUP RESPONSE) - (SETUPPUP OUTPUP HOSTPORT \PUPSOCKET.MISCSERVICES \PT.LAURELCHECK NIL SOC T) - (PUTPUPSTRING OUTPUP USER) - [SETQ RESPONSE (to \MAXETHERTRIES when (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T)) - do (RETURN (CONS (fetch PUPTYPE of INPUP) - (GETPUPSTRING INPUP))) - finally (AND PUPTRACEFLG (printout PUPTRACEFILE "Mail check timed out" T] - (AND INPUP (RELEASE.PUP INPUP)) - (RELEASE.PUP OUTPUP) - RESPONSE]) -) - -(ADDTOVAR MAILSERVERTYPES (MTP MTP.POLLNEWMAIL MTP.OPENMAILBOX MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE - MTP.CLOSEMAILBOX ETHERPORT)) - -(FILESLOAD LAFITE) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD MTPMAILBOX (MTPIN MTPOUT MTPSTATE)) - -(RECORD MTPPARSE (FROMLINE MAILBOX EOH DATELINE)) -) - -(DECLARE%: EVAL@COMPILE - -(RPAQQ \PUPSOCKET.MTP 7) - -(RPAQQ \PUPSOCKET.MISCSERVICES 4) - - -(CONSTANTS \PUPSOCKET.MTP \PUPSOCKET.MISCSERVICES) -) - - -(RPAQQ PUPTYPES - ((\PT.ECHOME 1) - (\PT.IAMECHO 2) - (\PT.IAMBADECHO 3) - (\PT.ERROR 4) - (\PT.RFC 8) - (\PT.ABORT 9) - (\PT.END 10) - (\PT.ENDREPLY 11) - (\PT.DATA 16) - (\PT.ADATA 17) - (\PT.ACK 18) - (\PT.MARK 19) - (\PT.INTERRUPT 20) - (\PT.INTERRUPTREPLY 21) - (\PT.AMARK 22) - (\PT.GATEWAYREQUEST 128) - (\PT.GATEWAYRESPONSE 129) - (\PT.ALTOTIMEREQUEST 134) - (\PT.ALTOTIMERESPONSE 135) - (\PT.MSGCHECK 136) - (\PT.NEWMAIL 137) - (\PT.NONEWMAIL 138) - (\PT.NOMAILBOX 139) - (\PT.LAURELCHECK 140) - (\PT.NAMELOOKUP 144) - (\PT.NAMERESPONSE 145) - (\PT.NAME/ADDRERROR 146) - (\PT.ADDRLOOKUP 147) - (\PT.ADDRRESPONSE 148) - (\PT.PRINTERSTATUS 128) - (\PT.STATUSRESPONSE 129) - (\PT.PRINTERCAPABILITY 130) - (\PT.CAPABILITYRESPONSE 131) - (\PT.PRINTJOBSTATUS 132) - (\PT.PRINTJOBRESPONSE 133) - (\PT.WHEREUSERREQUEST 152) - (\PT.WHEREUSERRESPONSE 153) - (\PT.WHEREUSERERROR 154) - (\PT.AUTHREQ 168) - (\PT.AUTHPOSRESP 169) - (\PT.AUTHNEGRESP 170))) -(DECLARE%: EVAL@COMPILE - -(RPAQQ \PT.ECHOME 1) - -(RPAQQ \PT.IAMECHO 2) - -(RPAQQ \PT.IAMBADECHO 3) - -(RPAQQ \PT.ERROR 4) - -(RPAQQ \PT.RFC 8) - -(RPAQQ \PT.ABORT 9) - -(RPAQQ \PT.END 10) - -(RPAQQ \PT.ENDREPLY 11) - -(RPAQQ \PT.DATA 16) - -(RPAQQ \PT.ADATA 17) - -(RPAQQ \PT.ACK 18) - -(RPAQQ \PT.MARK 19) - -(RPAQQ \PT.INTERRUPT 20) - -(RPAQQ \PT.INTERRUPTREPLY 21) - -(RPAQQ \PT.AMARK 22) - -(RPAQQ \PT.GATEWAYREQUEST 128) - -(RPAQQ \PT.GATEWAYRESPONSE 129) - -(RPAQQ \PT.ALTOTIMEREQUEST 134) - -(RPAQQ \PT.ALTOTIMERESPONSE 135) - -(RPAQQ \PT.MSGCHECK 136) - -(RPAQQ \PT.NEWMAIL 137) - -(RPAQQ \PT.NONEWMAIL 138) - -(RPAQQ \PT.NOMAILBOX 139) - -(RPAQQ \PT.LAURELCHECK 140) - -(RPAQQ \PT.NAMELOOKUP 144) - -(RPAQQ \PT.NAMERESPONSE 145) - -(RPAQQ \PT.NAME/ADDRERROR 146) - -(RPAQQ \PT.ADDRLOOKUP 147) - -(RPAQQ \PT.ADDRRESPONSE 148) - -(RPAQQ \PT.PRINTERSTATUS 128) - -(RPAQQ \PT.STATUSRESPONSE 129) - -(RPAQQ \PT.PRINTERCAPABILITY 130) - -(RPAQQ \PT.CAPABILITYRESPONSE 131) - -(RPAQQ \PT.PRINTJOBSTATUS 132) - -(RPAQQ \PT.PRINTJOBRESPONSE 133) - -(RPAQQ \PT.WHEREUSERREQUEST 152) - -(RPAQQ \PT.WHEREUSERRESPONSE 153) - -(RPAQQ \PT.WHEREUSERERROR 154) - -(RPAQQ \PT.AUTHREQ 168) - -(RPAQQ \PT.AUTHPOSRESP 169) - -(RPAQQ \PT.AUTHNEGRESP 170) - - -(CONSTANTS (\PT.ECHOME 1) - (\PT.IAMECHO 2) - (\PT.IAMBADECHO 3) - (\PT.ERROR 4) - (\PT.RFC 8) - (\PT.ABORT 9) - (\PT.END 10) - (\PT.ENDREPLY 11) - (\PT.DATA 16) - (\PT.ADATA 17) - (\PT.ACK 18) - (\PT.MARK 19) - (\PT.INTERRUPT 20) - (\PT.INTERRUPTREPLY 21) - (\PT.AMARK 22) - (\PT.GATEWAYREQUEST 128) - (\PT.GATEWAYRESPONSE 129) - (\PT.ALTOTIMEREQUEST 134) - (\PT.ALTOTIMERESPONSE 135) - (\PT.MSGCHECK 136) - (\PT.NEWMAIL 137) - (\PT.NONEWMAIL 138) - (\PT.NOMAILBOX 139) - (\PT.LAURELCHECK 140) - (\PT.NAMELOOKUP 144) - (\PT.NAMERESPONSE 145) - (\PT.NAME/ADDRERROR 146) - (\PT.ADDRLOOKUP 147) - (\PT.ADDRRESPONSE 148) - (\PT.PRINTERSTATUS 128) - (\PT.STATUSRESPONSE 129) - (\PT.PRINTERCAPABILITY 130) - (\PT.CAPABILITYRESPONSE 131) - (\PT.PRINTJOBSTATUS 132) - (\PT.PRINTJOBRESPONSE 133) - (\PT.WHEREUSERREQUEST 152) - (\PT.WHEREUSERRESPONSE 153) - (\PT.WHEREUSERERROR 154) - (\PT.AUTHREQ 168) - (\PT.AUTHPOSRESP 169) - (\PT.AUTHNEGRESP 170)) -) - -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS MTP.SERVER MTP.LINELENGTH MTP.RIGHTMARGINWIDTH MTP.FILLMSGFLG MTP.INSERTANSWERFLG - MTP.INSERTANSWERNSPACES \LAPARSE.FULL LAFITEEDITORFONT UNSUPPLIEDFIELDSTR MESSAGESTR - \LAFITEUSERDATA MAILSERVERTYPES \LAFITE.AUTHENTICATION.FAILURE) -) - - -(FILESLOAD (LOADCOMP) - LAFITE DPUPFTP) -) -(PUTPROPS MTP COPYRIGHT ("Xerox Corporation" 1983 1984 1986)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (2193 11600 (MTP.GET.USERDATA 2203 . 3410) (MTP.DELIVERMESSAGE 3412 . 6253) ( -MTP.PREPARE.SEND 6255 . 7703) (MTP.MAKEANSWERFORM 7705 . 11598)) (11709 18664 (\MTP.AUTHENTICATE 11719 - . 12593) (\MTP.COERCE.MSG 12595 . 13858) (\MTP.FILL 13860 . 17553) (\MTP.INDENT 17555 . 17955) ( -\MTP.CLRBUF 17957 . 18197) (\MTP.PRINTADDRESSES 18199 . 18662)) (18894 25470 (MTP.OPENMAILBOX 18904 . -20828) (MTP.POLLNEWMAIL 20830 . 21345) (MTP.NEXTMESSAGE 21347 . 23541) (MTP.RETRIEVEMESSAGE 23543 . -24195) (MTP.CLOSEMAILBOX 24197 . 25468)) (25471 26963 (\MTP.ENDOFMESSAGESTATE 25481 . 25977) ( -\MTP.POLLNEWMAIL 25979 . 26961))))) -STOP diff --git a/obsolete/lispusers/NGROUP b/obsolete/lispusers/NGROUP deleted file mode 100644 index 6430c691..00000000 --- a/obsolete/lispusers/NGROUP +++ /dev/null @@ -1,1102 +0,0 @@ -(FILECREATED "18-Feb-87 15:45:59" {SUMEX-AIM}PS:NGROUP.;3 43703 - - changes to: (FNS NGROUP.BUTTONEVENTINFN) - - previous date: "17-Feb-87 14:25:08" {SUMEX-AIM}PS:NGROUP.;3) - - -(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) - -(PRETTYCOMPRINT NGROUPCOMS) - -(RPAQQ NGROUPCOMS ((* Developed under support from NIH grant RR-00785.) - (* Written by Frank Gilmurray and Sami Shaio.) - (* * NUMBER ImageObject functions) - (FNS NUMBEROBJ NUMBEROBJP NGROUP.NUMBEROBJP NUMBER.DISPLAYFN NUMBER.IMAGEBOXFN NUMBER.PUTFN - NUMBER.GETFN NUMBER.BUTTONEVENTINFN) - (FNS NGROUP.BUTTONEVENTINFN NGROUP.WHENSELECTEDFN) - (* * Number Group GRAPH functions) - (FNS GRAPHMENU TSP.NGROUP.GRAPHP INITIAL.NGROUP.GRAPH TSPGRAPHREGION - ADD.NGROUP.TO.MOTHER.NODE ADD.NODE.TO.GRAPH COLLECT.HASHARRAY CREATE.NGROUP.NODE - GET.FROMNODES GET.MOTHER.GROUP MAKE.MOTHER.NODE MAKE.NGROUP.NODELST GET.TONODES - FIND.NODE) - (* * Other unsorted functions) - (FNS INSERT.NGROUP VERIFY.NGROUP.ORDER ADD.NUMBER.GROUP ADD.NGROUP.TO.DBASE COLLECT.NGROUPS - LIST.FONT.PROPS MAP.NGROUP.LOOKS NGROUP.GETFONT CHANGE.NGROUP CHANGE.NGROUP.FONT - CHANGE.NGROUP.FORMAT CHANGE.NGROUP.CHARTYPE CHANGE.NGROUP.DELIMIT CHANGE.NGROUP.START - CHANGE.NGROUP.ADDTOTOC TSP.GET.NGROUP.ARRAY TSP.LEGALID) - (* * Number counting functions) - (FNS UPDATE.NUMBEROBJS RESET.DEPENDENT.CLASSES RESET.NCOUNTER GET.NCOUNTER NCOUNTER? - LIST.ANCESTORS FLATTEN.TREE.TO.STRING NGROUP.CHARTYPE NUMBER.TO.LETTER - REMOVE.ALL.COUNTERS) - (* * Table-of-Contents functions) - (FNS TOC.ENABLED? GET.TOC.TEXTSTRING CREATE.TOC.FILE VIEW.TOC.FILE GET.TOC.FILE - WRITE.TOC.FILE) - (RECORDS NGCOUNTER NGTEMPLATE NUMBEROBJ))) - - - -(* Developed under support from NIH grant RR-00785.) - - - - -(* Written by Frank Gilmurray and Sami Shaio.) - - (* * NUMBER ImageObject functions) - -(DEFINEQ - -(NUMBEROBJ - (LAMBDA (USE TEMPLATE NUMSTRING LINK.TO REF.TYPE FONT) (* fsg " 4-Feb-87 13:26") - (LET ((NEWOBJ (IMAGEOBJCREATE (create NUMBEROBJ - REF.TYPE _ REF.TYPE - NUMSTRING _(OR NUMSTRING "^n") - USE _ USE - TEMPLATE _ TEMPLATE - LINK.TO _ LINK.TO - NUMBER.TEXT _ NIL - PAGE.NUMBER _ NIL - FONT _ FONT) - (IMAGEFNSCREATE (FUNCTION NUMBER.DISPLAYFN) - (FUNCTION NUMBER.IMAGEBOXFN) - (FUNCTION NUMBER.PUTFN) - (FUNCTION NUMBER.GETFN) - (FUNCTION NILL) - (FUNCTION NUMBER.BUTTONEVENTINFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION XREF.WHENDELETEDFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL))))) - (IMAGEOBJPROP NEWOBJ 'TYPE - 'NUMBEROBJ) - NEWOBJ))) - -(NUMBEROBJP - (LAMBDA (IMOBJ) (* ss: "25-Jun-85 12:11") - - (* Tests an imageobj to see if it is a number imageobject. By convention, testing functions for an imageobject will - be named (CONCAT "P")) - - - (AND IMOBJ (EQ (IMAGEOBJPROP IMOBJ 'TYPE) - 'NUMBEROBJ)))) - -(NGROUP.NUMBEROBJP - (LAMBDA (IMOBJ) (* fsg "15-Dec-86 09:57") - - (* * Like NUMBEROBJP but also checks for NGroup ImageObject.) - - - (AND (NUMBEROBJP IMOBJ) - (EQ (fetch (NUMBEROBJ USE) of (fetch OBJECTDATUM of IMOBJ)) - 'NGROUP)))) - -(NUMBER.DISPLAYFN - (LAMBDA (OBJ STREAM) (* fsg "17-Feb-87 14:20") - - (* Display function for numberobjs. Allows different formats for display according to the use to which the  - numberobj is being put. If no specific action is specified, displaying defaults to printing out as a plain  - number.*) - - - (LET* ((DATUM (fetch OBJECTDATUM of OBJ)) - (NUMSTRING (MKSTRING (fetch NUMSTRING of DATUM))) - (NUMBER.TEXT (fetch NUMBER.TEXT of DATUM)) - (TEMPLATE (MKSTRING (fetch TEMPLATE of DATUM))) - (USE (fetch USE of DATUM)) - (REF.TYPE (fetch REF.TYPE of DATUM)) - (MAIN.WINDOW (CAR (fetch \WINDOW of TEXTOBJ))) - (FONT (SELECTQ USE - (NOTE (fetch NUMBER.FONT of (GET.ENDNOTE.FONTS MAIN.WINDOW))) - (NGROUP (NGROUP.GETFONT REF.TYPE MAIN.WINDOW)) - (SHOULDNT "Undefined USE field, neither NOTE nor NGroup")))) - (AND (STRINGP NUMBER.TEXT) - (EQ USE 'NGROUP) - (SETQ NUMSTRING (CONCAT NUMSTRING NUMBER.TEXT))) - (AND (FONTP FONT) - (DSPFONT (FONTCREATE (FONTPROP FONT 'FAMILY) - (FONTPROP FONT 'SIZE) - (FONTPROP FONT 'FACE)) - STREAM)) - (SELECTQ USE - (NGROUP (PRIN3 NUMSTRING STREAM) - (SELECTQ (IMAGESTREAMTYPE STREAM) - (DISPLAY NIL) - (replace PAGE.NUMBER of DATUM - with (CAR FORMATTINGSTATE)))) - (NOTE (LET ((CURRENT.YPOS (DSPYPOSITION NIL STREAM)) - (IMAGEBOX (LISTGET (fetch IMAGEOBJPLIST of OBJ) - 'BOUNDBOX))) - (DSPYPOSITION (IPLUS CURRENT.YPOS - (IDIFFERENCE (fetch YSIZE - of IMAGEBOX) - (FONTPROP STREAM - 'HEIGHT))) - STREAM) - (PRIN1 NUMSTRING STREAM) - (DSPYPOSITION CURRENT.YPOS STREAM))) - NIL)))) - -(NUMBER.IMAGEBOXFN - (LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* fsg "17-Feb-87 11:21") - - (* * 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.) - - - (LET* ((MAIN.WINDOW (CAR (fetch \WINDOW of TEXTOBJ))) - (DATUM (fetch OBJECTDATUM of OBJ)) - (USE (fetch USE of DATUM)) - (REF.TYPE (fetch REF.TYPE of DATUM)) - (DEFAULTSTRING (MKSTRING (fetch NUMSTRING of DATUM))) - (NUMBER.TEXT (fetch NUMBER.TEXT of DATUM)) - (FONT (SELECTQ USE - (NOTE (fetch NUMBER.FONT of (GET.ENDNOTE.FONTS MAIN.WINDOW))) - (NGROUP (NGROUP.GETFONT REF.TYPE MAIN.WINDOW)) - (SHOULDNT "Undefined USE field, neither NOTE nor NGroup")))) - (AND (STRINGP NUMBER.TEXT) - (EQ USE 'NGROUP) - (SETQ DEFAULTSTRING (CONCAT DEFAULTSTRING NUMBER.TEXT))) - (AND (FONTP FONT) - (DSPFONT (FONTCREATE (FONTPROP FONT 'FAMILY) - (FONTPROP FONT 'SIZE) - (FONTPROP FONT 'FACE)) - STREAM)) - (create IMAGEBOX - XSIZE _(STRINGWIDTH DEFAULTSTRING STREAM) - YSIZE _(IPLUS (FONTPROP (CURRENT.DISPLAY.FONT STREAM) - 'HEIGHT) - (FIX (TIMES .5 (FONTPROP STREAM 'HEIGHT)))) - YDESC _(FONTPROP STREAM 'DESCENT) - XKERN _ 0)))) - -(NUMBER.PUTFN - (LAMBDA (OBJ STREAM) (* fsg " 4-Feb-87 13:29") - (LET ((USE (fetch USE of (fetch OBJECTDATUM of OBJ))) - (MAIN.WINDOW (PROCESSPROP (THIS.PROCESS) - 'WINDOW))) - (SELECTQ USE - (NOTE (NOTE.PUTFN OBJ STREAM MAIN.WINDOW)) - (NGROUP (replace (NUMBEROBJ FONT) of (fetch OBJECTDATUM of OBJ) - with (LIST.FONT.PROPS (NGROUP.GETFONT (fetch REF.TYPE - of (fetch - OBJECTDATUM - of OBJ)) - MAIN.WINDOW))) - (replace NGROUP.MOTHER of (fetch OBJECTDATUM of OBJ) - with (GET.FROMNODES (fetch REF.TYPE - of (fetch OBJECTDATUM of OBJ)) - MAIN.WINDOW)) - (PRIN4 (LIST 'NGroup - (IMAGEOBJPROP OBJ 'TAG) - (fetch OBJECTDATUM of OBJ)) - STREAM)) - (PRIN4 (LIST 'Unknown% Number% Type - (IMAGEOBJPROP OBJ 'TAG) - (fetch OBJECTDATUM of OBJ)) - STREAM))))) - -(NUMBER.GETFN - (LAMBDA (STREAM) (* edited: "29-Jan-87 16:27") - (LET* ((USE/TEXT (CDR (READ STREAM))) - (NEWOBJ (NUMBEROBJ)) - (USE (MKATOM (fetch USE of (CADR USE/TEXT)))) - (WINDOW (PROCESSPROP (THIS.PROCESS) - 'WINDOW))) - (OR (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW) - (TSP.FMMENU (TEXTSTREAM WINDOW))) - (IMAGEOBJPROP NEWOBJ 'TAG - (CAR USE/TEXT)) - (SETQ USE/TEXT (CADR USE/TEXT)) - (replace USE of (fetch OBJECTDATUM of NEWOBJ) with USE) - (SELECTQ USE - (NOTE (NOTE.GETFN NEWOBJ USE/TEXT WINDOW)) - (NGROUP (ADD.NGROUP.TO.DBASE (fetch REF.TYPE of USE/TEXT) - (fetch TEMPLATE of USE/TEXT) - (fetch NGROUP.MOTHER of USE/TEXT) - (AND (fetch (NUMBEROBJ FONT) of USE/TEXT) - (replace (NUMBEROBJ FONT) - of USE/TEXT - with (APPLY* - 'FONTCREATE - (fetch (NUMBEROBJ FONT) - of USE/TEXT)))) - (CREATE.NGROUP.NODE (fetch REF.TYPE - of USE/TEXT) - (fetch NGROUP.MOTHER - of USE/TEXT) - USE/TEXT WINDOW) - WINDOW) - (CREATE.NGROUP.NODE (fetch NGROUP.MOTHER of USE/TEXT) - NIL NIL WINDOW) - (ADD.NGROUP.TO.MOTHER.NODE (fetch REF.TYPE of USE/TEXT) - (fetch NGROUP.MOTHER of USE/TEXT) - WINDOW) - (WINDOWPROP WINDOW 'REBUILD.GRAPHFLG - T) - (replace OBJECTDATUM of NEWOBJ with USE/TEXT)) - (replace OBJECTDATUM of NEWOBJ with USE/TEXT)) - NEWOBJ))) - -(NUMBER.BUTTONEVENTINFN - (LAMBDA (NUMBEROBJ STREAM) (* fsg " 4-Feb-87 13:31") - (LET ((USE (fetch USE of (fetch OBJECTDATUM of NUMBEROBJ))) - (REF.TYPE (fetch REF.TYPE of (fetch OBJECTDATUM of NUMBEROBJ))) - (CHANGED NIL)) - (AND (MOUSESTATE MIDDLE) - (SELECTQ USE - (NOTE (NOTE.BUTTONEVENTINFN NUMBEROBJ STREAM)) - (NGROUP.BUTTONEVENTINFN REF.TYPE NUMBEROBJ STREAM))) - CHANGED))) -) -(DEFINEQ - -(NGROUP.BUTTONEVENTINFN - (LAMBDA (USE NUMBEROBJ STREAM) (* fsg "18-Feb-87 11:19") - (LET* ((TAG (IMAGEOBJPROP NUMBEROBJ 'TAG)) - (NMENU (create MENU - TITLE _(COND - (TAG (CONCAT USE " Tag:" TAG)) - (T USE)) - ITEMS _(COND - (TAG '(Change% Tag)) - (T '(Tag))) - WHENSELECTEDFN _ 'NGROUP.WHENSELECTEDFN))) - (PUTMENUPROP NMENU 'OBJ - NUMBEROBJ) - (MENU NMENU)))) - -(NGROUP.WHENSELECTEDFN - (LAMBDA (ITEM MENU MB) (* fsg " 4-Feb-87 13:41") - (LET ((TSTREAM (TEXTSTREAM WINDOW)) - (OBJ (GETMENUPROP MENU 'OBJ)) - PREV.CODE CODE) - (SETQ CODE (TSP.GET.INCODE TSTREAM)) - (AND (SETQ PREV.CODE (IMAGEOBJPROP OBJ 'TAG)) - (TSP.PUTCODE PREV.CODE NIL WINDOW)) - (IMAGEOBJPROP OBJ 'TAG - CODE) - (COND - (CODE (TSP.PUTCODE CODE OBJ WINDOW) - (TSP.PUTCODE PREV.CODE NIL WINDOW)))))) -) - (* * Number Group GRAPH functions) - -(DEFINEQ - -(GRAPHMENU - (LAMBDA (TSTREAM TWINDOW) (* fsg " 2-Dec-86 08:54") - (LET* ((RESHAPEFLG NIL) - (GRAPH (OR (AND (NOT (WINDOWPROP TWINDOW 'REBUILD.GRAPHFLG)) - (WINDOWPROP TWINDOW 'NGROUP.GRAPH)) - (INITIAL.NGROUP.GRAPH TWINDOW))) - (REGION (TSPGRAPHREGION GRAPH TWINDOW T)) - (GRAPHW (OR (WINDOWPROP TWINDOW 'NGROUPW) - (CREATEW REGION "Number Group Graph" NIL T)))) - (WINDOWPROP GRAPHW 'REPAINTFN - NIL) - (ATTACHWINDOW (SHAPEW GRAPHW REGION) - 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 - 'DETACHWINDOW) - (WINDOWPROP GRAPHW 'TWINDOW - TWINDOW) - (WINDOWPROP GRAPHW 'TSTREAM - TSTREAM)))) - -(TSP.NGROUP.GRAPHP - (LAMBDA (TWINDOW) (* fsg "15-Dec-86 15:27") - (LET* ((MENUW (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW)) - (ITEM (FM.ITEMFROMID MENUW 'NGroup% Menu))) - (FM.ITEMPROP ITEM 'STATE)))) - -(INITIAL.NGROUP.GRAPH - (LAMBDA (WINDOW) (* ss: "24-Apr-86 14:31") - (LET* ((ROOTNODE (NODECREATE 'NEW.NGROUP - 'NEW.NGROUP - NIL NIL NIL NIL 1)) - (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))))) - -(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))) - -(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: "24-Apr-86 14:26") - (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: " 3-Apr-86 16:46") - (LET ((RESULT NIL)) - (MAPHASH HARRAY '(LAMBDA (VAL KY) - (SETQ RESULT (CONS VAL RESULT)))) - RESULT))) - -(CREATE.NGROUP.NODE - (LAMBDA (ID MOTHER USERDATA W) (* ss: " 4-Apr-86 13:13") - (LET* ((NGROUP.HARRAY (TSP.GET.NGROUP.ARRAY W)) - (NODE (GETHASH ID NGROUP.HARRAY))) - (OR NODE (LET ((NEW.NODE (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.MOTHER.GROUP - (LAMBDA (DEPENDENT WINDOW) (* ss: " 2-Apr-86 16:30") - (CAR (fetch (GRAPHNODE FROMNODES) of (FIND.NODE DEPENDENT WINDOW))))) - -(MAKE.MOTHER.NODE - (LAMBDA NIL (* ss: " 8-Feb-86 16:01") - (LET ((TONODES NIL)) - (NODECREATE 'NEW.NGROUP - 'NEW.NGROUP - NIL - (for NGROUP in (TSP.GET 'NGROUPS) - do (COND - ((NOT (GET.FROMNODES (fetch REF.TYPE of NGROUP))) - (SETQ TONODES (CONS (fetch REF.TYPE of NGROUP) - TONODES)))) - finally (RETURN TONODES)) - NIL NIL 1)))) - -(MAKE.NGROUP.NODELST - (LAMBDA NIL (* ss: " 8-Feb-86 16:04") - (LET* ((NODELST (for NGROUP in (TSP.GET 'NGROUPS) - collect (NODECREATE (fetch REF.TYPE of NGROUP) - (fetch REF.TYPE of NGROUP) - NIL - (GET.TONODES (fetch REF.TYPE of NGROUP)) - (GET.FROMNODES (fetch REF.TYPE of NGROUP)))))) - (SETQ NODELST (CONS (MAKE.MOTHER.NODE) - NODELST))))) - -(GET.TONODES - (LAMBDA (MOTHER-GROUP WINDOW) (* ss: " 2-Apr-86 16:31") - (fetch (GRAPHNODE TONODES) of (FIND.NODE MOTHER-GROUP WINDOW)))) - -(FIND.NODE - (LAMBDA (NID WINDOW) (* ss: " 3-Apr-86 18:26") - (CADR (GETHASH NID (TSP.GET.NGROUP.ARRAY WINDOW))))) -) - (* * Other unsorted functions) - -(DEFINEQ - -(INSERT.NGROUP - (LAMBDA (NODE GRAPHW) (* fsg "13-Jan-87 16:21") - (AND NODE (LET* ((TWINDOW (WINDOWPROP GRAPHW 'TWINDOW)) - (TSTREAM (WINDOWPROP GRAPHW 'TSTREAM)) - (LABEL (fetch (GRAPHNODE NODELABEL) of NODE)) - (TEMPLATE (fetch (NUMBEROBJ TEMPLATE) - of (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW))))) - (OLDLOOKS (fetch CARETLOOKS of (TEXTOBJ TSTREAM))) - (NEWLOOKS (NGROUP.GETFONT LABEL TWINDOW))) - (SELECTQ LABEL - (NEW.NGROUP (COND - ((ADD.NUMBER.GROUP TWINDOW TSTREAM) - (CLOSEW GRAPHW) - (GRAPHMENU TSTREAM TWINDOW)) - (T NIL))) - (AND (VERIFY.NGROUP.ORDER TWINDOW TSTREAM LABEL) - (PROGN (TEDIT.CARETLOOKS TSTREAM NEWLOOKS) - (LET ((NEWOBJ (NUMBEROBJ 'NGROUP - TEMPLATE - (CONCAT "[" LABEL "]") - NIL LABEL NEWLOOKS))) - (AND (TOC.ENABLED? TWINDOW) - (GET.TOC.TEXTSTRING NEWOBJ TSTREAM - LABEL)) - (IMAGEOBJPROP NEWOBJ 'TWINDOW - TWINDOW) - (TEDIT.INSERT.OBJECT NEWOBJ TSTREAM)) - (TEDIT.CARETLOOKS TSTREAM OLDLOOKS) - (AND (UPDATE? TWINDOW) - (UPDATE.NUMBEROBJS TWINDOW - 'NUMBEROBJP))))))))) - -(VERIFY.NGROUP.ORDER - (LAMBDA (WINDOW STREAM LABEL) (* fsg "15-Dec-86 15:46") - - (* * Verify the NGroup order before inserting a new NGroup. The order is valid if the new NGroup is a top level  - node or the previous NGroup is the same as or the mother of this new NGroup. Note that the "previous NGroup" must  - be a member of this NGroup`s tree branch.) - - - (OR (EQ (GET.FROMNODES LABEL WINDOW) - 'NEW.NGROUP) - (LET* ((ANCESTORS (LIST.ANCESTORS LABEL NIL WINDOW)) - (MOTHER (CAR (LAST ANCESTORS))) - (SELECTION (TEDIT.GETSEL STREAM)) - (CH# (SELECTQ (fetch POINT of SELECTION) - (LEFT (fetch CH# of SELECTION)) - (ADD1 (fetch CH# of SELECTION)))) - PREV.NGROUP) - (NCONC1 ANCESTORS LABEL) - (SETQ PREV.NGROUP (for OBJ in (REVERSE (TSP.LIST.OF.OBJECTS (TEXTOBJ - WINDOW) - ' - NGROUP.NUMBEROBJP)) - bind REF.TYPE - do (COND - ((AND (IGREATERP CH# (CADR OBJ)) - (MEMB (SETQ REF.TYPE - (fetch (NUMBEROBJ REF.TYPE) - of (fetch OBJECTDATUM - of (CAR OBJ)))) - ANCESTORS)) - (RETURN REF.TYPE)) - (T NIL)))) - (COND - ((OR (EQ PREV.NGROUP LABEL) - (EQ PREV.NGROUP MOTHER)) - T) - (T (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL - "%" not inserted, no preceding %"" - MOTHER "%" NGroup.") - T) - NIL)))))) - -(ADD.NUMBER.GROUP - (LAMBDA (TWINDOW STREAM) (* fsg "14-Jan-87 11:30") - (OR (TSP.NGROUP.GRAPHP TWINDOW) - (PROGN (FM.CHANGESTATE (FM.ITEMFROMID (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW) - 'NGroup% Menu) - (WINDOWPROP TWINDOW 'IMAGEOBJ.MENUW)) - (GRAPHMENU STREAM TWINDOW))) - (LET* ((PREV.ITEMS (COLLECT.NGROUPS TWINDOW)) - (NEW.GROUPID (MKATOM (TSP.LEGALID NIL (CONS 'NEW.NGROUP - PREV.ITEMS) - STREAM))) - TEMPLATE DEPENDENT.CLASS NEW.NODE) - (COND - (NEW.GROUPID (SETQ DEPENDENT.CLASS - (MKATOM (AND PREV.ITEMS (MENU (create MENU - TITLE _ - "Select Parent Group OR none" - ITEMS _(SORT PREV.ITEMS - 'UALPHORDER))) - ))) - (SETQ TEMPLATE (OR TEMPLATE (create NGTEMPLATE - NG.CHARTYPE _ 'Number - NG.DELIMIT _ "." - NG.START _ 1 - NG.ADDTOTOC _ T))) - (SETQ NEW.NODE (NODECREATE NEW.GROUPID NEW.GROUPID NIL NIL - (LIST (OR DEPENDENT.CLASS - 'NEW.NGROUP)))) - (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))))) - -(ADD.NGROUP.TO.DBASE - (LAMBDA (NEW.GROUPID TEMPLATE DEPENDENT.CLASS FONT NGROUP.NODE TWINDOW) - (* ss: "24-Apr-86 14:19") - (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) (* ss: " 6-Feb-86 16:12") - (AND FONTDES (LIST (FONTPROP FONTDES 'FAMILY) - (FONTPROP FONTDES 'SIZE) - (FONTPROP FONTDES 'FACE))))) - -(MAP.NGROUP.LOOKS - (LAMBDA (LABEL NEWFDESC TWINDOW) (* ss: " 2-Apr-86 18:04") - (TEDIT.PROMPTPRINT (TEXTSTREAM TWINDOW) - (CONCAT "Updating looks for " LABEL " numbers...") - T) - (for NOTE/CH# in (TSP.LIST.OF.OBJECTS (TEXTOBJ TWINDOW) - (BQUOTE (LAMBDA (OBJ) - (AND (IMAGEOBJP OBJ) - (EQ (FETCH REF.TYPE - OF OBJ:OBJECTDATUM) - , - (KWOTE LABEL)))))) - do (TEDIT.LOOKS (TEXTSTREAM TWINDOW) - NEWFDESC - (CADR NOTE/CH#) - 1)) - (TEDIT.PROMPTPRINT (TEXTSTREAM TWINDOW) - "done."))) - -(NGROUP.GETFONT - (LAMBDA (NGROUP.NAME WINDOW) (* ss: " 3-Apr-86 18:26") - (fetch (NUMBEROBJ FONT) of (CAR (GETHASH NGROUP.NAME (TSP.GET.NGROUP.ARRAY WINDOW))))) -) - -(CHANGE.NGROUP - (LAMBDA (NODE GRAPHW) (* fsg "13-Jan-87 15:11") - - (* * Here when number group node is middle buttoned. Allow user to change the font and/or format of the ngroup.) - - - (AND NODE (OR (EQ 'NEW.NGROUP - (fetch (GRAPHNODE NODELABEL) of NODE)) - (LET ((LABEL (fetch NODELABEL of NODE)) - (ITEM.TO.CHANGE (MENU (create MENU - TITLE _ "Item to change" - CENTERFLG _ T - ITEMS _ '(Font Format))))) - (SELECTQ ITEM.TO.CHANGE - (Font (CHANGE.NGROUP.FONT LABEL GRAPHW)) - (Format (CHANGE.NGROUP.FORMAT LABEL GRAPHW)) - NIL)))))) - -(CHANGE.NGROUP.FONT - (LAMBDA (LABEL GRAPHW) (* fsg "13-Jan-87 15:13") - - (* * Change the font of a number group.) - - - (LET* ((TSTREAM (WINDOWPROP GRAPHW 'TSTREAM)) - (TWINDOW (WINDOWPROP GRAPHW 'TWINDOW)) - (NBROBJ (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW)))) - (OLD.FONT (fetch (NUMBEROBJ FONT) of NBROBJ)) - NEW.FONT) - (TEDIT.PROMPTPRINT TSTREAM (CONCAT "%"" LABEL "%" font is " (LIST (ABBREVIATE.FONT - OLD.FONT)) - ", change to...") - T) - (SETQ NEW.FONT (FONTCREATE (GET.TSP.FONT TWINDOW OLD.FONT))) - (COND - ((NEQ OLD.FONT NEW.FONT) - (replace (NUMBEROBJ FONT) of NBROBJ with NEW.FONT) - (MAP.NGROUP.LOOKS LABEL NEW.FONT TWINDOW)) - (T NIL)) - (TEDIT.PROMPTPRINT TSTREAM "" T)))) - -(CHANGE.NGROUP.FORMAT - (LAMBDA (LABEL GRAPHW) (* fsg "14-Jan-87 11:40") - - (* * Change the format of a number group. The format is three element record; the character type, the delimiter,  - and starting value.) - - - (LET* ((TSTREAM (WINDOWPROP GRAPHW 'TSTREAM)) - (TWINDOW (WINDOWPROP GRAPHW 'TWINDOW)) - (NBROBJ (CAR (GETHASH LABEL (TSP.GET.NGROUP.ARRAY TWINDOW)))) - (OLD.TEMPLATE (fetch (NUMBEROBJ TEMPLATE) of NBROBJ)) - NEW.CHARTYPE NEW.DELIMIT NEW.START NEW.ADDTOTOC) - (AND (SETQ NEW.CHARTYPE (CHANGE.NGROUP.CHARTYPE OLD.TEMPLATE LABEL TSTREAM)) - (replace (NGTEMPLATE NG.CHARTYPE) of OLD.TEMPLATE with NEW.CHARTYPE)) - (AND (SETQ NEW.DELIMIT (CHANGE.NGROUP.DELIMIT OLD.TEMPLATE LABEL TSTREAM)) - (replace (NGTEMPLATE NG.DELIMIT) of OLD.TEMPLATE with NEW.DELIMIT)) - (AND (SETQ NEW.START (CHANGE.NGROUP.START OLD.TEMPLATE LABEL TSTREAM)) - (replace (NGTEMPLATE NG.START) of OLD.TEMPLATE with NEW.START)) - (AND (SETQ NEW.ADDTOTOC (CHANGE.NGROUP.ADDTOTOC OLD.TEMPLATE LABEL TSTREAM)) - (replace (NGTEMPLATE NG.ADDTOTOC) of OLD.TEMPLATE with (CDR NEW.ADDTOTOC))) - (COND - ((OR NEW.CHARTYPE NEW.DELIMIT NEW.START) - (MAP.NGROUP.LOOKS LABEL (fetch (NUMBEROBJ FONT) of NBROBJ) - TWINDOW)) - (T (TEDIT.PROMPTPRINT TSTREAM "" T)))))) - -(CHANGE.NGROUP.CHARTYPE - (LAMBDA (TEMPLATE LABEL STREAM) (* fsg "13-Jan-87 14:52") - - (* * Show this NGroup's display type and return a possibly new display type.) - - - (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL "%" displayed as " (fetch (NGTEMPLATE - NG.CHARTYPE) - of TEMPLATE) - ", change to...") - T) - (MENU (create MENU - TITLE _ "NGroup Types" - CENTERFLG _ T - ITEMS _ '(Number Null% String Uppercase% Letter Lowercase% Letter - Uppercase% Roman Lowercase% Roman))))) - -(CHANGE.NGROUP.DELIMIT - (LAMBDA (TEMPLATE LABEL STREAM) (* fsg "13-Jan-87 14:38") - - (* * Show the delimiter following this NGroup and return a possibly new delimiter.) - - - (TEDIT.PROMPTPRINT STREAM (CONCAT "Delimiter following %"" LABEL "%" is %"" - (fetch (NGTEMPLATE NG.DELIMIT) of TEMPLATE) - "%", change to...") - T) - (LET ((NEW.DELIMIT (MENU (create MENU - TITLE _ "NGroup Delimiters" - CENTERFLG _ T - ITEMS _ '((Dot ".") - (Dash "-") - (Null% String "") - Other))))) - (COND - ((EQ NEW.DELIMIT 'Other) - (MKSTRING (TEDIT.GETINPUT STREAM (CONCAT "Specify delimiter following " LABEL ":")) - )) - (T NEW.DELIMIT))))) - -(CHANGE.NGROUP.START - (LAMBDA (TEMPLATE LABEL STREAM) (* fsg "13-Jan-87 15:09") - - (* * Show this NGroup's starting value and return a possibly new starting value.) - - - (TEDIT.PROMPTPRINT STREAM (CONCAT "Starting value of %"" LABEL "%" is " - (fetch (NGTEMPLATE NG.START) of TEMPLATE) - ", change it?") - T) - (MENU (create MENU - TITLE _ "Change start?" - CENTERFLG _ T - ITEMS _ '(YES NO) - WHENSELECTEDFN _(FUNCTION (LAMBDA (ITEM) - (COND - ((EQ ITEM 'YES) - (NUMBERPAD.READ (CREATE.NUMBERPAD.READER "Starting NGroup Value" - NIL NIL NIL T))) - (T NIL)))))))) - -(CHANGE.NGROUP.ADDTOTOC - (LAMBDA (TEMPLATE LABEL STREAM) (* fsg "14-Jan-87 13:17") - - (* * Say if this NGroup will/won't be included in the TOC, if any and retrun a possibly new ADD-TO-TOC flag.) - - - (TEDIT.PROMPTPRINT STREAM (CONCAT "%"" LABEL "%" is " (COND - ((fetch (NGTEMPLATE NG.ADDTOTOC) of TEMPLATE) - "") - (T "NOT ")) - "included in TOC. Do you want it included?") - T) - (MENU (create MENU - TITLE _ "Include in TOC?" - CENTERFLG _ T - ITEMS _ '(YES NO) - WHENSELECTEDFN _(FUNCTION (LAMBDA (ITEM) - (CONS ITEM (COND - ((EQ ITEM 'YES) - T) - (T NIL))))))))) - -(TSP.GET.NGROUP.ARRAY - (LAMBDA (W) (* ss: " 3-Apr-86 18:25") - (WINDOWPROP W 'TSP.NGROUP.ARRAY))) - -(TSP.LEGALID - (LAMBDA (NAME NGROUPS STREAM) (* ss: "31-Mar-86 14:23") - (LET ((LEGAL T) - (ID (OR NAME (MKATOM (TEDIT.GETINPUT STREAM "Group name>"))))) - (COND - ((MEMBER ID NGROUPS) - (TSP.LEGALID (MKATOM (TEDIT.GETINPUT STREAM "Illegal name... Group name>")) - NGROUPS STREAM)) - (T ID))))) -) - (* * Number counting functions) - -(DEFINEQ - -(UPDATE.NUMBEROBJS - (LAMBDA (WINDOW TESTFN TESTFNARG) (* fsg " 3-Feb-87 10:30") - (LET* ((TEXTOBJ (TEXTOBJ WINDOW)) - (STREAM (TEXTSTREAM WINDOW)) - (NBROBJ.LIST (TSP.LIST.OF.OBJECTS TEXTOBJ TESTFN TESTFNARG))) - (TEDIT.PROMPTPRINT STREAM "Updating Number Group ImageObjects..." T) - (for NUMBEROBJ in NBROBJ.LIST - do (LET* ((OBJECTDATUM (fetch OBJECTDATUM of (CAR NUMBEROBJ))) - (REF.TYPE (fetch REF.TYPE of OBJECTDATUM)) - (NUMSTRING (MKATOM (fetch NUMSTRING of OBJECTDATUM))) - (USE (fetch USE of OBJECTDATUM)) - (TEMPLATE (SELECTQ USE - (NGROUP (fetch TEMPLATE of OBJECTDATUM)) - NIL)) - (DEPENDENT.CLASS (GET.MOTHER.GROUP REF.TYPE WINDOW)) - NEW.COUNT) - (RESET.DEPENDENT.CLASSES WINDOW USE REF.TYPE) - (SETQ NEW.COUNT (GET.NCOUNTER WINDOW USE REF.TYPE DEPENDENT.CLASS - TEMPLATE)) - (COND - ((EQ NEW.COUNT NUMSTRING)) - (T (replace NUMSTRING of OBJECTDATUM with NEW.COUNT) - (TEDIT.OBJECT.CHANGED STREAM (CAR NUMBEROBJ))))) - 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) (* fsg "17-Dec-86 16:33") - (LET ((COUNTER (NCOUNTER? WINDOW USE REF.TYPE TEMPLATE))) - (COND - (COUNTER (PROGN (replace NCOUNT of COUNTER with (ADD1 (fetch NCOUNT - of COUNTER))) - (COND - (MOTHER.CLASS (FLATTEN.TREE.TO.STRING WINDOW USE REF.TYPE)) - (T (fetch NCOUNT of COUNTER))))) - (T NIL))))) - -(NCOUNTER? - (LAMBDA (WINDOW USE REF.TYPE TEMPLATE) (* fsg "23-Dec-86 09:13") - - (* * Return the record for this number counter. If the record doesn't exist, we create one based on the USE value.) - - - (LET ((COUNTER.ID (MKATOM (CONCAT (SELECTQ USE - (NGROUP REF.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)))))) - -(LIST.ANCESTORS - (LAMBDA (NID ANCESTORS WINDOW) (* ss: " 2-Apr-86 16:32") - (LET* ((NODE (FIND.NODE NID WINDOW)) - (MOTHER (AND NODE (CAR (fetch (GRAPHNODE FROMNODES) of NODE))))) - (COND - ((AND MOTHER (NEQ MOTHER 'NEW.NGROUP)) - (LIST.ANCESTORS MOTHER (CONS MOTHER ANCESTORS) - WINDOW)) - (T ANCESTORS))))) - -(FLATTEN.TREE.TO.STRING - (LAMBDA (WINDOW USE REF.TYPE) (* fsg "17-Dec-86 16:45") - (LET ((NCOUNTER (NCOUNTER? WINDOW USE REF.TYPE)) - (FLAT.TREE "")) - (COND - ((fetch ANCESTRY of NCOUNTER) - (for (ANCESTOR ANCESTOR.NCOUNT) in (REVERSE (fetch ANCESTRY of NCOUNTER)) - do (SETQ ANCESTOR.NCOUNT (fetch NCOUNT of (NCOUNTER? WINDOW USE ANCESTOR))) - (SETQ FLAT.TREE (CONCAT (SELECTQ USE - (NGROUP (NGROUP.CHARTYPE WINDOW - ANCESTOR - ANCESTOR.NCOUNT T)) - (CONCAT ANCESTOR.NCOUNT '-)) - FLAT.TREE)) - finally (SETQ FLAT.TREE - (MKATOM (CONCAT FLAT.TREE - (SELECTQ USE - (NGROUP (NGROUP.CHARTYPE WINDOW REF.TYPE - (fetch NCOUNT - of - NCOUNTER) - NIL)) - (fetch NCOUNT of NCOUNTER))))))) - (T (SETQ FLAT.TREE (SELECTQ USE - (NGROUP (NGROUP.CHARTYPE WINDOW REF.TYPE - (fetch NCOUNT of NCOUNTER) - NIL)) - (fetch NCOUNT of NCOUNTER))))) - FLAT.TREE))) - -(NGROUP.CHARTYPE - (LAMBDA (WINDOW REF.TYPE NCOUNT MORE.FIELDS?) (* fsg "13-Jan-87 15:26") - - (* * Convert the number NCOUNT to the format specified in TEMPLATE.) - - - (LET* ((NBROBJ (CAR (GETHASH REF.TYPE (TSP.GET.NGROUP.ARRAY WINDOW)))) - (TEMPLATE (fetch (NUMBEROBJ TEMPLATE) of NBROBJ)) - (CHARTYPE (fetch (NGTEMPLATE NG.CHARTYPE) of TEMPLATE))) - (CONCAT (COND - ((OR (NOT (NUMBERP NCOUNT)) - (ILEQ NCOUNT 0)) - "?") - (T (SELECTQ CHARTYPE - (Number (MKSTRING NCOUNT)) - (Uppercase% Letter (NUMBER.TO.LETTER NCOUNT T)) - (Lowercase% Letter (NUMBER.TO.LETTER NCOUNT)) - (Uppercase% Roman (ROMANNUMERALS NCOUNT T)) - (Lowercase% Roman (ROMANNUMERALS NCOUNT)) - (Null% String "") - NIL))) - (COND - ((OR MORE.FIELDS? (EQ (GET.FROMNODES REF.TYPE WINDOW) - 'NEW.NGROUP)) - (fetch (NGTEMPLATE NG.DELIMIT) of TEMPLATE)) - (T "")))))) - -(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)))) -) - (* * Table-of-Contents functions) - -(DEFINEQ - -(TOC.ENABLED? - (LAMBDA (WINDOW) (* fsg "10-Dec-86 15:40") - (WINDOWPROP WINDOW 'ENABLETOC))) - -(GET.TOC.TEXTSTRING - (LAMBDA (NBROBJ STREAM LABEL) (* fsg "14-Jan-87 09:35") - - (* * Here if TOC is enabled to get the Table-Of-Contents text string for this NGroup. Because the WRITE.TOC.FILE  - function uses a tab to align the page numbers, any tabs in the TOC string are converted to spaces.) - - - (LET ((TOC.STRING (TEDIT.GETINPUT STREAM (CONCAT "Text for " LABEL ": ")))) - (AND TOC.STRING (replace (NUMBEROBJ NUMBER.TEXT) of (fetch OBJECTDATUM of NBROBJ) - with (CONCAT " " - (MKSTRING - (PACK (for TOC.CHAR in (UNPACK TOC.STRING) - collect - (COND - ((EQ TOC.CHAR - (CHARACTER (CHARCODE TAB))) - (CHARACTER (CHARCODE SPACE))) - (T TOC.CHAR))))))))))) - -(CREATE.TOC.FILE - (LAMBDA (STREAM WINDOW) (* fsg "27-Jan-87 09:32") - - (* * Here to print the Table Of 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) - 'NGROUP.NUMBEROBJP)) - (TOC.FILE (GET.TOC.FILE (WINDOWPROP WINDOW 'IMAGEOBJ.MENUW))) - (TOC.TABSTOP (LIST 'PARALOOKS - (LIST 'TABS - (LIST NIL (CONS (FIXR (ITIMES 72.27 5.5)) - 'DOTTEDLEFT))))) - (TOC.STREAM (AND TOC.FILE (OPENTEXTSTREAM NIL NIL NIL NIL TOC.TABSTOP)))) - (COND - ((AND TOC.LIST TOC.FILE) - (TEDIT.PROMPTPRINT STREAM (CONCAT "Putting Table-Of-Contents in " TOC.FILE "...") - T) - (WRITE.TOC.FILE TOC.STREAM TOC.LIST WINDOW) - (TEDIT.PROMPTPRINT STREAM "done") - (TEDIT.PUT TOC.STREAM 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 in this document." T) - NIL))))) - -(VIEW.TOC.FILE - (LAMBDA (STREAM WINDOW) (* fsg "15-Dec-86 13:48") - - (* * 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)) - (TOC.FILEW (WINDOWPROP WINDOW 'TOC.WINDOW))) - (AND TOC.FILE (COND - ((WINDOWP TOC.FILEW) - (COND - ((OPENWP TOC.FILEW) - (TEDIT.GET (TEXTOBJ TOC.FILEW) - TOC.FILE)) - ((OPENW TOC.FILEW) - (TEDIT TOC.FILE TOC.FILEW)))) - (T (WINDOWPROP WINDOW 'TOC.WINDOW - (SETQ TOC.FILEW (CREATEW NIL (CONCAT "Viewing TOC file: " - TOC.FILE)))) - (TEDIT TOC.FILE TOC.FILEW))))))) - -(GET.TOC.FILE - (LAMBDA (MENUW) (* fsg "11-Dec-86 10:27") - - (* * Return the user specified Table-Of-Contents file name.) - - - (LET* ((ITEM (FM.ITEMFROMID MENUW 'TOC.FILE)) - (TOC.FILENAME (FM.ITEMPROP ITEM 'LABEL))) - (COND - ((NOT (STREQUAL TOC.FILENAME "")) - (MKATOM TOC.FILENAME)) - (T NIL))))) - -(WRITE.TOC.FILE - (LAMBDA (TOC.STREAM TOC.LIST WINDOW) (* fsg "28-Jan-87 13:27") - - (* * Here to do the actual output to the TOC file.) - - - (DSPFONT (FONTCREATE '(HELVETICA 14 BRR)) - TOC.STREAM) - (PRINTOUT TOC.STREAM "Table of Contents" T) - (for (TOC.ITEM OBJECTDATUM ITEM.LEVEL) in TOC.LIST - when (fetch (NGTEMPLATE NG.ADDTOTOC) of (fetch (NUMBEROBJ TEMPLATE) - of (fetch OBJECTDATUM - of (CAR TOC.ITEM)))) - do (SETQ OBJECTDATUM (fetch OBJECTDATUM of (CAR TOC.ITEM))) - (DSPFONT (fetch (NUMBEROBJ FONT) of OBJECTDATUM) - TOC.STREAM) - (SETQ ITEM.LEVEL (LENGTH (LIST.ANCESTORS (fetch (NUMBEROBJ REF.TYPE) - of OBJECTDATUM) - NIL WINDOW))) - (COND - ((ZEROP ITEM.LEVEL) - (PRINTOUT TOC.STREAM T T)) - (T (RPTQ ITEM.LEVEL (PRINTOUT TOC.STREAM " ")))) - (PRINTOUT TOC.STREAM (CONCAT (fetch (NUMBEROBJ NUMSTRING) of OBJECTDATUM) - (OR (fetch (NUMBEROBJ NUMBER.TEXT) of OBJECTDATUM) - ""))) - (DSPFONT GP.DefaultFont TOC.STREAM) - (PRINTOUT TOC.STREAM (CHARACTER (CHARCODE TAB)) - (fetch (NUMBEROBJ PAGE.NUMBER) of OBJECTDATUM) - T) - (AND (ZEROP ITEM.LEVEL) - (PRINTOUT TOC.STREAM T))))) -) -[DECLARE: EVAL@COMPILE - -(RECORD NGCOUNTER (NCOUNT . ANCESTRY)) - -(RECORD NGTEMPLATE (NG.CHARTYPE NG.DELIMIT NG.START NG.ADDTOTOC)) - -(RECORD NUMBEROBJ (REF.TYPE NUMSTRING USE NGROUP.MOTHER TEMPLATE LINK.TO NUMBER.TEXT PAGE.NUMBER - FONT)) -] -(PUTPROPS NGROUP COPYRIGHT ("Leland Stanford Junior University" 1987)) -(DECLARE: DONTCOPY - (FILEMAP ((10049) (1916 NIL (NUMBEROBJ 1926 . 2911) (NUMBEROBJP 2913 . 3283) (NGROUP.NUMBEROBJP 3285 - . 3616) (NUMBER.DISPLAYFN 3618 . 5633) (NUMBER.IMAGEBOXFN 5635 . 7099) (NUMBER.PUTFN 7101 . 8230) ( -NUMBER.GETFN 8232 . 10048))))) -STOP -TONEVENTINFN 10294 . 10801)) (10806 11877 ( -NGROUP.BUTTONEVENTINFN 10818 . 11322) (NGROUP.WHENSELECTEDFN 11326 . 11874)) (11922 18225 (GRAPHMENU -11934 . 13037) (TSP.NGROUP.GRAPHP 13041 . 13313) (INITIAL.NGROUP.GRAPH 13317 . 13924) (TSPGRAPHREGION -13928 . 14408) (ADD.NGROUP.TO.MOTHER.NODE 14412 . 14788) (ADD.NODE.TO.GRAPH 14792 . 15593) ( -COLLECT.HASHARRAY 15597 . 15845) (CREATE.NGROUP.NODE 15849 . 16377) (GET.FROMNODES 16381 . 16577) ( -GET.MOTHER.GROUP 16581 . 16785) (MAKE.MOTHER.NODE 16789 . 17307) (MAKE.NGROUP.NODELST 17311 . 17848) ( -GET.TONODES 17852 . 18042) (FIND.NODE 18046 . 18222)) (18266 31833 (INSERT.NGROUP 18278 . 19721) ( -VERIFY.NGROUP.ORDER 19725 . 21385) (ADD.NUMBER.GROUP 21389 . 22799) (ADD.NGROUP.TO.DBASE 22803 . 23454 -) (COLLECT.NGROUPS 23458 . 23884) (LIST.FONT.PROPS 23888 . 24139) (MAP.NGROUP.LOOKS 24143 . 24833) ( -NGROUP.GETFONT 24837 . 25067) (CHANGE.NGROUP 25071 . 25812) (CHANGE.NGROUP.FONT 25816 . 26765) ( -CHANGE.NGROUP.FORMAT 26769 . 28318) (CHANGE.NGROUP.CHARTYPE 28322 . 28949) (CHANGE.NGROUP.DELIMIT -28953 . 29755) (CHANGE.NGROUP.START 29759 . 30503) (CHANGE.NGROUP.ADDTOTOC 30507 . 31267) ( -TSP.GET.NGROUP.ARRAY 31271 . 31432) (TSP.LEGALID 31436 . 31830)) (31875 39290 (UPDATE.NUMBEROBJS 31887 - . 33206) (RESET.DEPENDENT.CLASSES 33210 . 33563) (RESET.NCOUNTER 33567 . 34089) (GET.NCOUNTER 34093 - . 34583) (NCOUNTER? 34587 . 35516) (LIST.ANCESTORS 35520 . 35938) (FLATTEN.TREE.TO.STRING 35942 . -37182) (NGROUP.CHARTYPE 37186 . 38274) (NUMBER.TO.LETTER 38278 . 38989) (REMOVE.ALL.COUNTERS 38993 . -39287)) (39334 44416 (TOC.ENABLED? 39346 . 39497) (GET.TOC.TEXTSTRING 39501 . 40412) (CREATE.TOC.FILE -40416 . 41696) (VIEW.TOC.FILE 41700 . 42519) (GET.TOC.FILE 42523 . 42942) (WRITE.TOC.FILE 42946 . -44413))))) -STOP diff --git a/obsolete/lispusers/NOTECARDS-4045XLPPATCH b/obsolete/lispusers/NOTECARDS-4045XLPPATCH deleted file mode 100644 index 3e0b02b2..00000000 --- a/obsolete/lispusers/NOTECARDS-4045XLPPATCH +++ /dev/null @@ -1,47 +0,0 @@ -(FILECREATED "15-Dec-86 16:30:35" {DANTE}4045>V1.4>NOTECARDS-4045XLPPATCH.;2 1578 - - changes to: (FNS 4045XLP.NoteCardsAdvice) - - previous date: "26-Sep-86 14:20:43" {DANTE}4045>V1.4>NOTECARDS-4045XLPPATCH.;1) - - -(* Copyright (c) 1986 by Xerox Corporation and Will Snow. All rights reserved.) - -(PRETTYCOMPRINT NOTECARDS-4045XLPPATCHCOMS) - -(RPAQQ NOTECARDS-4045XLPPATCHCOMS ((FNS 4045XLP.NoteCardsAdvice) - (P (4045XLP.NoteCardsAdvice)))) -(DEFINEQ - -(4045XLP.NoteCardsAdvice - [LAMBDA NIL (* edited: "15-Dec-86 16:29") - [ADVISE (QUOTE NC.LinkIconDisplayFn) - (QUOTE BEFORE) - NIL - (QUOTE (COND ((OR (NULL STREAMTYPE) - (EQ STREAMTYPE (QUOTE 4045XLP))) - (SETQ STREAMTYPE (QUOTE DISPLAY] - (ADVISE (QUOTE (STRINGWIDTH IN NC.LinkIconImageBoxFn)) - (QUOTE AFTER) - NIL - (QUOTE (AND (EQ (IMAGESTREAMTYPE ImageStream) - (QUOTE 4045XLP)) - (RETURN (IQUOTIENT (STRINGWIDTH (CONCAT "nn" - (if Label - then - (CONCAT "<" - Label ">") - else "") - (if (AND Label - Title) - then " " - else "") - (OR Title "")) - ImageStream) - Scale]) -) -(4045XLP.NoteCardsAdvice) -(PUTPROPS NOTECARDS-4045XLPPATCH COPYRIGHT ("Xerox Corporation and Will Snow" 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (478 1445 (4045XLP.NoteCardsAdvice 488 . 1443))))) -STOP diff --git a/obsolete/lispusers/NSALLOCATION b/obsolete/lispusers/NSALLOCATION deleted file mode 100644 index a312c196..00000000 --- a/obsolete/lispusers/NSALLOCATION +++ /dev/null @@ -1,106 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "19-Feb-88 19:27:57" {QV}LISP>NSALLOCATION.\;3 6361 - - |changes| |to:| (FNS NSALLOCATION.STATS NSALLOCATION) - - |previous| |date:| "19-Feb-88 18:05:54" {QV}LISP>NSALLOCATION.\;1) - - -; Copyright (c) 1988 by Xerox Corporation. All rights reserved. - -(PRETTYCOMPRINT NSALLOCATIONCOMS) - -(RPAQQ NSALLOCATIONCOMS ((FNS NSALLOCATION NSALLOCATION.STATS))) -(DEFINEQ - -(NSALLOCATION - (LAMBDA (|FileServers| |ReportFile| |Filter|) (* \; "Edited 19-Feb-88 18:10 by bbb") - - (LET ((|NSDiskSizeInPages| 433907) - |ReportFileStream|) - (CL:WITH-OPEN-FILE (|ReportFileStream| |ReportFile| :DIRECTION :OUTPUT) - (|if| |Filter| - |then| (|printout| |ReportFileStream| "Using Filter " |Filter| T T)) - (|printout| |ReportFileStream| .FONT '(TERMINAL 12) "File Service" .TAB 20 - "# Pages Used" .TAB 35 "as %" .TAB 45 "# Pages Used" .TAB 60 "as %" .TAB 70 - "# Pages" .TAB 80 "as %" .TAB 90 "Total % Used" T) - (|printout| |ReportFileStream| "Name" .TAB 20 "Unrestricted" .TAB 35 "of disk" .TAB - 45 "Restricted" .TAB 60 "of alloc" .TAB 70 "alloc" .TAB 80 "of disk" .TAB 90 - "of disk" T) - (|printout| |ReportFileStream| "----------------" .TAB 20 "------------" .TAB 35 - "-------" .TAB 45 "------------" .TAB 60 "--------" .TAB 70 "-------" .TAB 80 - "-------" .TAB 90 "------------" T) - (|printout| |ReportFileStream| T) - (|for| |Server| |in| |FileServers| |bind| |Result| |PagesUnrestricted| - |PagesRestricted| |PagesAllocated| - |PercentUnrestricted| - |PercentRestrictedofAllocated| - |PercentAllocated| |TotalPercentUsed| - |when| (SETQ |Result| (NSALLOCATION.STATS |Server| |Filter|)) - |do| (SETQ |PagesUnrestricted| (CAR (NTH |Result| 1))) - (SETQ |PagesRestricted| (CAR (NTH |Result| 2))) - (SETQ |PagesAllocated| (CAR (NTH |Result| 3))) - (SETQ |PercentUnrestricted| (TIMES (FQUOTIENT |PagesUnrestricted| - |NSDiskSizeInPages|) - 100.0)) - (SETQ |PercentRestrictedofAllocated| (TIMES (FQUOTIENT |PagesRestricted| - |PagesAllocated|) - 100.0)) - (SETQ |PercentAllocated| (TIMES (FQUOTIENT |PagesAllocated| - |NSDiskSizeInPages|) - 100.0)) - (SETQ |TotalPercentUsed| (TIMES (FQUOTIENT (PLUS |PagesUnrestricted| - |PagesRestricted|) - |NSDiskSizeInPages|) - 100.0)) - (|printout| |ReportFileStream| |Server| .TAB 20 |.I12| |PagesUnrestricted| - .TAB 35 |.F7.1| |PercentUnrestricted| .TAB 45 |.I12| |PagesRestricted| - .TAB 60 |.F8.2| |PercentRestrictedofAllocated| .TAB 70 |.I7| - |PagesAllocated| .TAB 80 |.F7.1| |PercentAllocated| .TAB 90 |.F12.1| - |TotalPercentUsed| T)))))) - -(NSALLOCATION.STATS - (LAMBDA (|FileServiceName| |Filter|) (* \; "Edited 19-Feb-88 19:20 by bbb") - - (* |;;| - "Given a file service name the following three pieces of data are returned in a list: ") - - (* |;;| " 1) number of pages in use of unrestricted file drawers") - - (* |;;| " 2) number of pages in use in restricted file drawers") - - (* |;;| " 3) number of pages allocated to file drawers") - - (* |;;| "") - - (* |;;| " If Filter is NON-NIL then it is used as a file pattern for selecting directories") - - (LET* ((|FileServiceDirectories| (DIRECTORY (CONCAT "{" |FileServiceName| "}") - 'COLLECT)) - (|FileServiceDevice| (\\GETDEVICEFROMNAME |FileServiceName|)) - (|NumBytesUnrestricted| 0) - (|NumBytesRestricted| 0) - (|NumBytesAllocated| 0) - (|BytesPerPage| 512) - (|Filter| (|if| |Filter| - |then| (DIRECTORY.MATCH.SETUP |Filter|)))) - (|for| |Directory| |in| |FileServiceDirectories| |bind| |DirectoryAllocation| - |DirectoryUsed| - |when| (OR (NULL |Filter|) - (DIRECTORY.MATCH |Filter| |Directory|)) - |do| (SETQ |DirectoryAllocation| (\\NSFILING.GETFILEINFO |Directory| 'SUBTREE.SIZE.LIMIT - |FileServiceDevice|)) - (SETQ |DirectoryUsed| (\\NSFILING.GETFILEINFO |Directory| 'SUBTREE.SIZE - |FileServiceDevice|)) - (|if| (IGEQ |DirectoryAllocation| 0) - |then| (|add| |NumBytesAllocated| |DirectoryAllocation|) - (|add| |NumBytesRestricted| |DirectoryUsed|) - |else| (|add| |NumBytesUnrestricted| |DirectoryUsed|))) - (LIST (FQUOTIENT |NumBytesUnrestricted| |BytesPerPage|) - (FQUOTIENT |NumBytesRestricted| |BytesPerPage|) - (FQUOTIENT |NumBytesAllocated| |BytesPerPage|))))) -) -(PUTPROPS NSALLOCATION COPYRIGHT ("Xerox Corporation" 1988)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (457 6277 (NSALLOCATION 467 . 3985) (NSALLOCATION.STATS 3987 . 6275))))) -STOP diff --git a/obsolete/lispusers/NSCOPYFILE b/obsolete/lispusers/NSCOPYFILE deleted file mode 100644 index 8c4f0ab1..00000000 --- a/obsolete/lispusers/NSCOPYFILE +++ /dev/null @@ -1,37 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "10-Dec-87 11:40:53" {ERIS}LISP>NSCOPYFILE.;3 2187 - - changes to%: (FNS NSCOPYFILE) - - previous date%: " 9-Oct-87 17:35:59" {ERIS}LISP>NSCOPYFILE.;2) - - -(* " -Copyright (c) 1987 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT NSCOPYFILECOMS) - -(RPAQQ NSCOPYFILECOMS ((FNS NSCOPYFILE) (PROP FILETYPE NSCOPYFILE) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE COPYFILE) (QUOTE \GENERIC.COPYFILE)) (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) (AND (CCODEP (QUOTE \NSFILING.COPYFILE)) (CCODEP (QUOTE NSCOPYFILE)) (MOVD (QUOTE NSCOPYFILE) (QUOTE COPYFILE) NIL T))))) -) -(DEFINEQ - -(NSCOPYFILE -(LAMBDA (FROMFILE TOFILE DESTPARAMETERS) (* ; "Edited 10-Dec-87 11:40 by bvm:") (* ;; "Special version of COPYFILE that lets NS servers do efficient or information-preserving copy. Perhaps COPYFILE will be a device method some day.") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FROMDEV TODEV) (if (AND (NULL DESTPARAMETERS) (NOT (NULL TOFILE)) (NEQ TOFILE T) (SETQ FROMDEV (\GETDEVICEFROMNAME (SETQ FROMFILE (\ADD.CONNECTED.DIR (if (TYPEP FROMFILE (QUOTE PATHNAME)) then (\CONVERT-PATHNAME FROMFILE) else FROMFILE))))) (EQ (fetch (FDEV OPENFILE) of FROMDEV) (FUNCTION \NSFILING.OPENFILE)) (SETQ TODEV (\GETDEVICEFROMNAME (SETQ TOFILE (\ADD.CONNECTED.DIR (if (TYPEP TOFILE (QUOTE PATHNAME)) then (\CONVERT-PATHNAME TOFILE) else TOFILE))))) (EQ (fetch (FDEV OPENFILE) of TODEV) (FUNCTION \NSFILING.OPENFILE))) then (* ; "Both source and destination are NS servers.") (\NSFILING.COPYFILE FROMDEV FROMFILE TODEV TOFILE) else (\GENERIC.COPYFILE FROMFILE TOFILE DESTPARAMETERS)))) -) -) - -(PUTPROPS NSCOPYFILE FILETYPE :COMPILE-FILE) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(LOCALVARS . T) -) -(DECLARE%: DONTEVAL@LOAD DOCOPY -(MOVD? (QUOTE COPYFILE) (QUOTE \GENERIC.COPYFILE)) -(AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) -(AND (CCODEP (QUOTE \NSFILING.COPYFILE)) (CCODEP (QUOTE NSCOPYFILE)) (MOVD (QUOTE NSCOPYFILE) (QUOTE COPYFILE) NIL T)) -) -(PUTPROPS NSCOPYFILE COPYRIGHT ("Xerox Corporation" 1987)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (738 1735 (NSCOPYFILE 748 . 1733))))) -STOP diff --git a/obsolete/lispusers/NSCOPYFILE.LCOM b/obsolete/lispusers/NSCOPYFILE.LCOM deleted file mode 100644 index dd322f14..00000000 Binary files a/obsolete/lispusers/NSCOPYFILE.LCOM and /dev/null differ diff --git a/obsolete/lispusers/NSCOPYFILE.TEDIT b/obsolete/lispusers/NSCOPYFILE.TEDIT deleted file mode 100644 index 95bc9dd9..00000000 Binary files a/obsolete/lispusers/NSCOPYFILE.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/NSREADERPATCH b/obsolete/lispusers/NSREADERPATCH deleted file mode 100644 index 092afe8c..00000000 --- a/obsolete/lispusers/NSREADERPATCH +++ /dev/null @@ -1,19 +0,0 @@ -(FILECREATED "18-Jun-86 16:14:22" {ERIS}LISPCORE>NSREADERPATCH.;1 577 - - changes to: (VARS NSREADERPATCHCOMS)) - - -(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT NSREADERPATCHCOMS) - -(RPAQQ NSREADERPATCHCOMS [(ADDVARS (FILEINFOTYPES (READER 11)) - (\LISP.TO.NSFILING.ATTRIBUTES (READER READ.BY]) - -(ADDTOVAR FILEINFOTYPES (READER 11)) - -(ADDTOVAR \LISP.TO.NSFILING.ATTRIBUTES (READER READ.BY)) -(PUTPROPS NSREADERPATCH COPYRIGHT ("Xerox Corporation" 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/lispusers/NSROUTINGHASH b/obsolete/lispusers/NSROUTINGHASH deleted file mode 100644 index fcbb9d36..00000000 --- a/obsolete/lispusers/NSROUTINGHASH +++ /dev/null @@ -1,206 +0,0 @@ -(FILECREATED " 7-Feb-89 23:16:44" {ERINYES}KOTO>NSROUTINGHASH.;2 13641 - - changes to: (RECORDS NSROUTINGINFO) (VARS NSROUTINGHASHCOMS) - - previous date: "11-Jan-88 21:27:31" {ERINYES}KOTO>NSROUTINGHASH.;1) - - -(* Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT NSROUTINGHASHCOMS) - -(RPAQQ NSROUTINGHASHCOMS ((FNS \AGE.ROUTING.TABLE.HASH \HANDLE.NS.ROUTING.INFO.NEW -\HANDLE.RAW.XIP.NEW \LOCATE.NSNET.NEW \FLUSHNDBS.NEW \MAP.ROUTING.TABLE.NEW \NSGATELISTENER.NEW -\NSROUTING.HASHBITSFN \NSROUTING.EQUIVFN PRINTROUTINGTABLE) (GLOBALVARS \NS.ROUTING.TABLE) (* * -LOADCOMP LLNS *before* loading this module so that this record declaration is in effect) (RECORDS -NSROUTINGINFO) (FNS INSTALL UNINSTALL) (* installation utilities) (COMS (* debugging tools) (FNS -ROUTINGPROBE)) (DECLARE: DONTEVAL@LOAD DOCOPY (P (UNINTERRUPTABLY (INSTALL (QUOTE \FLUSHNDBS)) ( -INSTALL (QUOTE \MAP.ROUTING.TABLE)) (INSTALL (QUOTE \HANDLE.NS.ROUTING.INFO)) (INSTALL (QUOTE -\LOCATE.NSNET)) (INSTALL (QUOTE \HANDLE.RAW.XIP)) (INSTALL (QUOTE \NSGATELISTENER)) (RESTART.ETHER) ( -\LOCATE.NSNET -1)))))) -(DEFINEQ - -(\AGE.ROUTING.TABLE.HASH -(LAMBDA (TABLE) (* ; "Edited 21-Jun-87 23:23 by BRIGGS") (MAPHASH TABLE (FUNCTION (LAMBDA (ENTRY KEY) -(if (if (AND (NEQ (fetch RTHOPCOUNT of ENTRY) 0) (TIMEREXPIRED? (fetch RTTIMER of ENTRY))) then (COND -((fetch RTRECENT of ENTRY) (* New entry, make it old) (replace RTRECENT of ENTRY with NIL) (SETUPTIMER - \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY)) NIL) (T \RT.PURGEFLG))) then (PUTHASH KEY NIL TABLE)))) -))) - -(\HANDLE.NS.ROUTING.INFO.NEW -(LAMBDA (XIP) (* edited: "11-Jan-88 20:48") (* ; "Edited 21-Jun-87 23:11 by BRIGGS") (* Processes a -routing info XIP) (COND ((EQ (fetch XIPFIRSTDATAWORD of XIP) \XROUTINGINFO.OP.RESPONSE) (* Unless -we're a gateway, we only handle responses) (PROG ((HOST (fetch XIPSOURCEHOST of XIP)) (NDB (fetch -EPNETWORK of XIP)) (LENGTH (SUB1 (FOLDLO (IDIFFERENCE (fetch XIPLENGTH of XIP) \XIPOVLEN) BYTESPERWORD -))) (BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) ENTRY NET HOPS NETHASH) (COND ((NEQ (fetch NETTYPE -of NDB) 10) (OR (SETQ HOST (\TRANSLATE.10TO3 HOST NDB)) (RETURN)))) (SETQ \NSROUTER.PROBECOUNT 0) ( -while (IGEQ LENGTH \NS.ROUTINGINFO.WORDS) do (SETQ HOPS (fetch (NSROUTINGINFO #HOPS) of BASE)) (COND ( -(OR (SETQ ENTRY (GETHASH BASE \NS.ROUTING.TABLE)) (COND ((ILEQ HOPS \NS.ROUTING.TABLE.RADIUS) (SETQ -NET (fetch (NSROUTINGINFO NET#) of BASE)) (PUTHASH NET (SETQ ENTRY (create ROUTING RTNET# _ NET -RTTIMER _ (SETUPTIMER 0))) \NS.ROUTING.TABLE) T))) (* Update the entry if this entry not for directly -connected net and - current entry timed out, or - new gateway same as old, or - new route has fewer -hops than old) (COND ((AND (NEQ (fetch RTHOPCOUNT of ENTRY) 0) (OR (NOT (fetch RTRECENT of ENTRY)) ( -AND (EQUAL HOST (fetch RTGATEWAY# of ENTRY)) (EQ NDB (fetch RTNDB of ENTRY))) (ILESSP HOPS (fetch -RTHOPCOUNT of ENTRY)))) (replace RTGATEWAY# of ENTRY with HOST) (replace RTNDB of ENTRY with NDB) ( -replace RTHOPCOUNT of ENTRY with HOPS) (COND ((ILESSP HOPS \RT.INFINITY) (replace RTRECENT of ENTRY -with T) (SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY)))))))) (SETQ LENGTH (IDIFFERENCE -LENGTH \NS.ROUTINGINFO.WORDS)) (SETQ BASE (\ADDBASE BASE \NS.ROUTINGINFO.WORDS)))))) ( -\RELEASE.ETHERPACKET XIP))) - -(\HANDLE.RAW.XIP.NEW -(LAMBDA (XIP TYPE) (* edited: "11-Jan-88 20:47") (* N.H.Briggs "21-Jun-87 23:53") (* Handles the -arrival of a raw XIP. If it is destined for a local socket that has room for it, we queue it up, else -release it) (COND ((EQ TYPE \EPT.XIP) (PROG (NSOC CSUM NDB DESTNET MYNET) (COND ((NULL \NS.READY) ( -RETURN (RELEASE.XIP XIP)))) (COND ((AND (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) -\MY.NSHOSTNUMBER)) (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) BROADCASTNSHOSTNUMBER))) (* Not for - us) (RETURN (\FORWARD.XIP XIP)))) (SETQ NDB (fetch EPNETWORK of XIP)) (COND ((AND (NOT (IEQP (SETQ -DESTNET (fetch XIPDESTNET of XIP)) (SETQ MYNET (fetch NDBNSNET# of NDB)))) (NEQ MYNET 0) (NEQ DESTNET -0)) (* explicitly for a net other than us) (RETURN (\FORWARD.XIP XIP)))) (COND ((NULL (SETQ NSOC ( -\NSOCKET.FROM# (fetch XIPDESTSOCKET of XIP)))) (* Packets addressed to non-active sockets are just -ignored.) (COND (XIPTRACEFLG (PRIN1 (QUOTE '&) XIPTRACEFILE))) (PROG (XIPBASE) (COND ((AND (EQ (fetch -XIPTYPE of XIP) \XIPT.ECHO) (EQ (fetch XIPDESTSOCKET of XIP) \NS.WKS.Echo) (EQ (\GETBASE (SETQ XIPBASE - (fetch XIPCONTENTS of XIP)) 0) \XECHO.OP.REQUEST)) (* Play echo server) (COND ((AND (NEQ (SETQ CSUM ( -fetch XIPCHECKSUM of XIP)) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 ( -FOLDHI (fetch XIPLENGTH of XIP) BYTESPERWORD))))) (\XIPERROR XIP \XIPE.CHECKSUM)) (T (\PUTBASE XIPBASE - 0 \XECHO.OP.REPLY) (SWAPXIPADDRESSES XIP) (replace EPREQUEUE of XIP with (QUOTE FREE)) (SENDXIP NIL -XIP)))) (T (\XIPERROR XIP \XIPE.NOSOCKET))))) ((IGEQ (fetch (NSOCKET INQUEUELENGTH) of NSOC) (fetch ( -NSOCKET NSOC#ALLOCATION) of NSOC)) (* Note that packets are just "dropped" when the queue overflows.) -(\XIPERROR XIP \XIPE.SOCKETFULL)) ((AND \NS.CHECKSUMFLG (NEQ (SETQ CSUM (fetch XIPCHECKSUM of XIP)) -MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (FOLDHI (fetch XIPLENGTH of XIP -) BYTESPERWORD))))) (\XIPERROR XIP \XIPE.CHECKSUM)) (T (COND ((EQ DESTNET 0) (* Fill in unspecified -destination net (possibly redundantly with zero)) (replace XIPDESTNET of XIP with MYNET)) ((EQ MYNET 0 -) (* Packet of specific destination net has arrived on a socket that we listen to. If we don't know -our own net number, assume sender is telling the truth) (replace NDBNSNET# of NDB with DESTNET) ( -replace NSNET of \MY.NSADDRESS with (SETQ \MY.NSNETNUMBER DESTNET)) (PROG ((ENTRY (\LOCATE.NSNET -DESTNET T))) (OR ENTRY (PUTHASH DESTNET (SETQ ENTRY (create ROUTING RTNET# _ DESTNET)) -\NS.ROUTING.TABLE)) (replace RTHOPCOUNT of ENTRY with 0) (replace RTGATEWAY# of ENTRY with NIL) ( -replace RTNDB of ENTRY with NDB) (replace RTRECENT of ENTRY with T)))) (UNINTERRUPTABLY (\ENQUEUE ( -fetch (NSOCKET INQUEUE) of NSOC) XIP) (add (fetch (NSOCKET INQUEUELENGTH) of NSOC) 1) (NOTIFY.EVENT ( -fetch NSOCEVENT of NSOC)))))) T)))) - -(\LOCATE.NSNET.NEW -(LAMBDA (NET DONTPROBE) (* edited: "11-Jan-88 20:49") (* N.H.Briggs "21-Jun-87 23:54") (LET ((DATA ( -GETHASH NET \NS.ROUTING.TABLE))) (if DATA then (AND (ILESSP (fetch RTHOPCOUNT of DATA) \RT.INFINITY) -DATA) elseif (NOT DONTPROBE) then (PUTHASH NET (create ROUTING RTNET# _ NET RTHOPCOUNT _ \RT.INFINITY -RTTIMER _ (SETUPTIMER 30000)) \NS.ROUTING.TABLE) (* Insert an entry for the net, to be purged in 30 -sec if router process hasn't filled it by then) (SETQ \NSROUTER.PROBECOUNT 5) (SETQ -\NSROUTER.PROBETIMER (SETUPTIMER 0 \NSROUTER.PROBETIMER)) (WAKE.PROCESS (QUOTE \NSGATELISTENER)) ( -BLOCK) (* ;; "return NIL in this case to indicate we didn't find it yet.") NIL)))) - -(\FLUSHNDBS.NEW -(LAMBDA (EVENT) (* edited: "11-Jan-88 21:20") (* bvm: " 4-AUG-83 22:51") (bind NDB QUEUE while (SETQ -NDB \LOCALNDBS) do (SETQ \LOCALNDBS (fetch NDBNEXT of NDB)) (replace NDBNEXT of NDB with NIL) (COND (( -EQ EVENT (QUOTE RESTART)) (APPLY* (fetch NDBETHERFLUSHER of NDB) NDB))) (DEL.PROCESS (fetch NDBWATCHER - of NDB)) (replace NDBWATCHER of NDB with (replace NDBTRANSLATIONS of NDB with NIL)) (COND ((SETQ -QUEUE (fetch NDBTQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT (QUOTE OUTPUT)) (* Don't do this just yet, -because of possible race in \PUPGATELISTENER - (replace NDBTQ of NDB with NIL)))) (COND ((SETQ QUEUE ( -fetch NDBIQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT (QUOTE INPUT)) (replace NDBIQ of NDB with NIL)))) ( -SETQ \PUP.ROUTING.TABLE (CONS)) (SETQ \NS.ROUTING.TABLE (HASHARRAY 100 50 (FUNCTION -\NSROUTING.HASHBITSFN) (FUNCTION \NSROUTING.EQUIVFN))))) - -(\MAP.ROUTING.TABLE.NEW -(LAMBDA (TABLE MAPFN) (* edited: "11-Jan-88 20:53") (* bvm: "22-SEP-83 14:21") (if (HARRAYP TABLE) -then (MAPHASH TABLE MAPFN) else (for ENTRY in (APPEND (CDR (OR TABLE \PUP.ROUTING.TABLE))) do (APPLY* -MAPFN ENTRY))))) - -(\NSGATELISTENER.NEW -(LAMBDA NIL (* edited: "11-Jan-88 20:47") (* ; "Edited 16-Jun-87 15:32 by BRIGGS") (PROG ((NSOC ( -OPENNSOCKET \NS.WKS.RoutingInformation T)) (TIMER (SETUPTIMER 0)) EVENT XIP BASE) (SETQ EVENT (fetch -NSOCEVENT of NSOC)) LP (COND ((SETQ XIP (GETXIP NSOC)) (\HANDLE.NS.ROUTING.INFO XIP) (BLOCK)) ((EQ ( -AWAIT.EVENT EVENT (COND ((IGREATERP \NSROUTER.PROBECOUNT 0) \NSROUTER.PROBETIMER) (T TIMER)) T) EVENT) - (GO LP))) (COND ((TIMEREXPIRED? TIMER) (\AGE.ROUTING.TABLE.HASH \NS.ROUTING.TABLE) (SETUPTIMER -\RT.AGEINTERVAL TIMER))) (COND ((AND (IGREATERP \NSROUTER.PROBECOUNT 0) (TIMEREXPIRED? -\NSROUTER.PROBETIMER)) (* Routing info desired. Broadcast a routing request on each directly-connected - net) (SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0 -(IPLUS \XIPOVLEN BYTESPERWORD (UNFOLD \NS.ROUTINGINFO.WORDS BYTESPERWORD)))) (replace XIPFIRSTDATAWORD - of XIP with \XROUTINGINFO.OP.REQUEST) (SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace ( -NSROUTINGINFO NET#) of BASE with -1) (replace (NSROUTINGINFO #HOPS) of BASE with \RT.INFINITY) ( -SENDXIP NSOC XIP) (SETUPTIMER \NSROUTER.PROBEINTERVAL \NSROUTER.PROBETIMER) (SETQ \NSROUTER.PROBECOUNT - (SUB1 \NSROUTER.PROBECOUNT)))) (GO LP)))) - -(\NSROUTING.HASHBITSFN -(LAMBDA (OBJECT) (* ; "Edited 21-Jun-87 23:08 by BRIGGS") (SELECTQ (TYPENAME OBJECT) (ETHERPACKET (* ; - "a piece of a routing table packet") (LOGXOR (fetch (NSROUTINGINFO NET#-HI) of OBJECT) (fetch ( -NSROUTINGINFO NET#-LO) of OBJECT))) (SMALLP (* ; "a net as a small number") OBJECT) (FIXP (* ; -"a net as a number") (LOGXOR (\GETBASE OBJECT 0) (\GETBASE OBJECT 1))) (ERROR -"Illegal arg (neither FIXP, SMALLP, nor ETHERPACKET)" OBJECT)))) - -(\NSROUTING.EQUIVFN -(LAMBDA (X Y) (* N.H.Briggs "22-Jun-87 14:34") (SELECTQ (TYPENAME X) (ETHERPACKET (SELECTQ (TYPENAME Y -) (SMALLP (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) 0) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) Y) -)) (FIXP (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) (\GETBASE Y 0)) (EQ (fetch (NSROUTINGINFO -NET#-LO) of X) (\GETBASE Y 1)))) (ETHERPACKET (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) (fetch ( -NSROUTINGINFO NET#-HI) of Y)) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) (fetch (NSROUTINGINFO NET#-LO) -of Y)))) NIL)) (SMALLP (SELECTQ (TYPENAME Y) (SMALLP (EQ X Y)) (FIXP (EQUAL X Y)) (ETHERPACKET (AND ( -EQ (fetch (NSROUTINGINFO NET#-HI) of Y) 0) (EQ (fetch (NSROUTINGINFO NET#-LO) of Y) X))) NIL)) (FIXP ( -SELECTQ (TYPENAME Y) ((SMALLP FIXP) (EQUAL X Y)) (ETHERPACKET (AND (EQ (fetch (NSROUTINGINFO NET#-HI) -of Y) (\GETBASE X 0)) (EQ (fetch (NSROUTINGINFO NET#-LO) of Y) (\GETBASE X 1)))) NIL)) NIL))) - -(PRINTROUTINGTABLE -(LAMBDA (TABLE SORT? FILE) (* edited: "11-Jan-88 21:25") (* N.H.Briggs "14-Dec-87 12:17") (PROG ( -HASHENTRIES) (SELECTQ TABLE (NS (MAPHASH \NS.ROUTING.TABLE (FUNCTION (LAMBDA (X) (push HASHENTRIES X)) -)) (SETQ TABLE (CONS NIL HASHENTRIES))) ((NIL PUP) (SETQ TABLE \PUP.ROUTING.TABLE)) NIL) (RESETFORM ( -RADIX 8) (printout FILE " Net# Gateway #Hops Recent?" T) (for ENTRY in (COND (SORT? ( -SORT (APPEND (CDR TABLE)) (if (EQ SORT? (QUOTE HOPS)) then (FUNCTION (LAMBDA (X Y) (ILESSP (fetch -RTHOPCOUNT of X) (fetch RTHOPCOUNT of Y)))) else T))) (T (CDR TABLE))) bind GATE do (printout FILE -.I6.8 (fetch RTNET# of ENTRY)) (COND ((NOT (SETQ GATE (fetch RTGATEWAY# of ENTRY))) (PRIN1 -" --- " FILE)) ((FIXP GATE) (printout FILE .I9.8 GATE)) (T (SPACES 2 FILE) (PRINTNSHOSTNUMBER -GATE FILE))) (printout FILE 30 .I2 (fetch RTHOPCOUNT of ENTRY) (COND ((fetch RTRECENT of ENTRY) -" Yes") ((TIMEREXPIRED? (fetch RTTIMER of ENTRY)) " timed out") (T " No")) T)) (TERPRI FILE)) -))) -) -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \NS.ROUTING.TABLE) -) - (* * LOADCOMP LLNS *before* loading this module so that this record declaration is in effect) - -[DECLARE: EVAL@COMPILE - -(BLOCKRECORD NSROUTINGINFO ((* Format of each entry in a routing info packet, the hashing code relys - on the fact that the net number comes first.) (NET#-HI WORD) (NET#-LO WORD) (#HOPS WORD)) (ACCESSFNS -((NET# (\GETBASEFIXP DATUM 0) (\PUTBASEFIXP DATUM 0 NEWVALUE))))) -] -(DEFINEQ - -(INSTALL -(LAMBDA (FN) (* ; "Edited 21-Jun-87 22:08 by BRIGGS") (if (NOT (GETD (MKATOM (CONCAT FN ".OLD")))) -then (MOVD FN (MKATOM (CONCAT FN ".OLD")) NIL T)) (MOVD (MKATOM (CONCAT FN ".NEW")) FN NIL T))) - -(UNINSTALL -(LAMBDA (FN) (* ; "Edited 21-Jun-87 22:08 by BRIGGS") (if (GETD (MKATOM (CONCAT FN ".OLD"))) then ( -MOVD (MKATOM (CONCAT FN ".OLD")) FN NIL T)))) -) - - - -(* installation utilities) - - - - -(* debugging tools) - -(DEFINEQ - -(ROUTINGPROBE -(LAMBDA NIL (* ; "Edited 17-Jun-87 18:16 by BRIGGS") (LET ((NSOC (OPENNSOCKET -\NS.WKS.RoutingInformation T)) XIP BASE) (SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC -BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0 (IPLUS \XIPOVLEN BYTESPERWORD (UNFOLD -\NS.ROUTINGINFO.WORDS BYTESPERWORD)))) (replace XIPFIRSTDATAWORD of XIP with \XROUTINGINFO.OP.REQUEST) - (SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace (NSROUTINGINFO NET#) of BASE with -1) ( -replace (NSROUTINGINFO #HOPS) of BASE with \RT.INFINITY) (SENDXIP NSOC XIP)))) -) -(DECLARE: DONTEVAL@LOAD DOCOPY -(UNINTERRUPTABLY (INSTALL (QUOTE \FLUSHNDBS)) (INSTALL (QUOTE \MAP.ROUTING.TABLE)) (INSTALL (QUOTE -\HANDLE.NS.ROUTING.INFO)) (INSTALL (QUOTE \LOCATE.NSNET)) (INSTALL (QUOTE \HANDLE.RAW.XIP)) (INSTALL ( -QUOTE \NSGATELISTENER)) (RESTART.ETHER) (\LOCATE.NSNET -1)) -) -(PUTPROPS NSROUTINGHASH COPYRIGHT ("Xerox Corporation" 1987 1988 1989)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (1158 11765 (\AGE.ROUTING.TABLE.HASH 1168 . 1612) (\HANDLE.NS.ROUTING.INFO.NEW 1614 . -3371) (\HANDLE.RAW.XIP.NEW 3373 . 6241) (\LOCATE.NSNET.NEW 6243 . 6939) (\FLUSHNDBS.NEW 6941 . 7817) ( -\MAP.ROUTING.TABLE.NEW 7819 . 8066) (\NSGATELISTENER.NEW 8068 . 9335) (\NSROUTING.HASHBITSFN 9337 . -9803) (\NSROUTING.EQUIVFN 9805 . 10738) (PRINTROUTINGTABLE 10740 . 11763)) (12235 12617 (INSTALL 12245 - . 12453) (UNINSTALL 12455 . 12615)) (12681 13250 (ROUTINGPROBE 12691 . 13248))))) -STOP diff --git a/obsolete/lispusers/NSTHASIZE b/obsolete/lispusers/NSTHASIZE deleted file mode 100644 index d282cebf..00000000 --- a/obsolete/lispusers/NSTHASIZE +++ /dev/null @@ -1,256 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 3-Mar-89 18:17:39" {ERINYES}MEDLEY>NSTHASIZE.;1 13450 - - changes to%: (FNS NSTHASIZE) - (VARS NSTHASIZECOMS) - - previous date%: " 8-Apr-86 09:09:30" {DSK}/usr/local/koto/lispusers/nsthasize.;1) - - -(* " -Copyright (c) 1986, 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT NSTHASIZECOMS) - -(RPAQQ NSTHASIZECOMS ((INITVARS (GV.TO.NS.REG)) - (FNS CONVERT.GV.TO.NS GV.READFORWARDING READ-GV-NS-MAPPING NSTHASIZE - \GETSTRING \GV.COLLECT.ENTRY \GV.COLLECT.ENTRY.1 - \GV.COLLECT.ENTRY.LIST) - (FILES (LOADCOMP) - MAINTAIN))) - -(RPAQ? GV.TO.NS.REG ) -(DEFINEQ - -(CONVERT.GV.TO.NS - [LAMBDA (X) (* lmm " 7-Apr-86 16:23") - (COND - ((SETQ X (\CHECKNAME X)) - (PROG ([REG (MKATOM (U-CASE (CDR X] - NSREG) - (RETURN (if (EQ REG 'NS) - then (OR (CH.LOOKUP.OBJECT (SUBSTRING (CAR X) - 2 -2)) - (PROGN (PRINTOUT T "[Unable to check " X - " in clearinghouse, assuming correct]") - (SUBSTRING (CAR X) - 2 -2))) - else (OR (SETQ NSREG (ASSOC REG GV.TO.NS.REG)) - (RETURN)) - (LET (NAME) - (OR [CH.LOOKUP.OBJECT (SETQ NAME (CONCAT (CAR X) - ":" - (CDR NSREG] - (PROGN (PRINTOUT T "[Unable to check " NAME - " in clearinghouse, assuming correct]") - NAME]) - -(GV.READFORWARDING - [LAMBDA (X) (* lmm "19-Nov-85 11:20") - (CDR (ASSOC 'Forwarding (GV.READENTRY X NIL '\GV.COLLECT.ENTRY]) - -(READ-GV-NS-MAPPING - [LAMBDA NIL (* lmm " 4-Apr-86 16:56") - (SETQ GV.TO.NS.REG - (RESETLST - (PROG ((STREAM (OPENSTREAM '{INDIGO}GV>GV-NS-MAPPING.TXT 'INPUT 'OLD)) - (RT (COPYREADTABLE 'ORIG)) - LINES) - RESTART - (RESETSAVE NIL (LIST 'CLOSEF? STREAM)) - (SETSEPR NIL NIL RT) - (SETBRK (CHARCODE (CR)) - NIL RT) - (OR (FFILEPOS "GV-to-NS Mappings:" STREAM 0 NIL NIL T) - (ERROR "Couldn't find string GV-to-NS Mappings in " (FULLNAME STREAM))) - (FILEPOS " " STREAM) - [RETURN - (do (SELCHARQ (BIN STREAM) - (TAB) - (CR (RETURN LINES)) - (%. [LET ((LINE (RSTRING STREAM RT))) - (PRINTOUT T LINE T) - (push LINES (LET ((POS (STRPOS " -> " LINE))) - (OR POS (GO BADFORMAT)) - (CONS [MKATOM (U-CASE (SUBSTRING - LINE 1 (SUB1 POS] - (SUBSTRING LINE (PLUS POS 4) - -1] - (BIN STREAM)) - (GO BADFORMAT] - BADFORMAT - (ERROR "bad format on {INDIGO}GV>GV-NS-MAPPING.TXT")))]) - -(NSTHASIZE - [LAMBDA (GVDL NSDL NODELETE) (* ; "Edited 3-Mar-89 18:16 by masinter") - (OR GV.TO.NS.REG (PROGN (PRIN1 "Reading gv to ns mapping ...") - (READ-GV-NS-MAPPING))) (* lmm " 8-Apr-86 09:03") - (SETQ GVDL (OR (\CHECKNAME GVDL) - (ERROR "Invalid grapevine group" GVDL))) - (SETQ NSDL (OR (CH.LOOKUP.OBJECT NSDL) - (ERROR "Invalid NS distribution list" NSDL))) - (LET - (FORWARDING NSADDRESS) - (for X in (CDR (GV.READMEMBERS GVDL)) - do (if (OR (COND - ((SETQ NSADDRESS (CONVERT.GV.TO.NS X)) - (PRINTOUT T X) - T)) - (AND (SETQ FORWARDING (GV.READFORWARDING X)) - (PROGN (PRINTOUT T X " => " FORWARDING) - (if (CDR FORWARDING) - then (PRINTOUT T " -- more than one address." T) - NIL - else T)) - (if [NOT (SETQ NSADDRESS (CONVERT.GV.TO.NS (CAR FORWARDING] - then (PRINTOUT T " not an NS equivalent address." T) - NIL - else T))) - then (PRINTOUT T " => " NSADDRESS "...") - (PROG (VALUE) - LP (if (OR (type? NSNAME (SETQ VALUE (CH.ADD.MEMBER NSDL - 'MEMBERS NSADDRESS))) - (MATCH VALUE WITH (%'ERROR %'UPDATE.ERROR %'NoChange - --))) - then (if (AND NODELETE (OR (NEQ NODELETE 'FIRST) - (NLISTP VALUE))) - then (PRINTOUT T "ok." T) - else (PRINTOUT T "ok, delete: " (GV.REMOVEMEMBER - GVDL X) - T)) - elseif (COND - ((AND (EQ (CAR VALUE) - 'ERROR) - (SELECTQ (CAR (CDR VALUE)) - (CALL.ERROR (SELECTQ (CADDR VALUE) - (TooBusy (PRINTOUT T - " error:" - VALUE - " ... retrying" - " ...")) - (AccessRightsInsufficient - (PRINTOUT T " error:" - VALUE - " will not move..." - T) - (RETURN)) - (HELP VALUE)) - (GO LP)) - (HELP VALUE))) - T)) - then (TERPRI T) - NIL - else (HELP VALUE]) - -(\GETSTRING - [LAMBDA (STREAM LENGTH) (* lmm "19-Nov-85 10:21") - (COND - ((IGREATERP LENGTH \MAXGVSTRING) - (ERROR "stream must be confused - string too long" LENGTH)) - (T (LET ((STRING (ALLOCSTRING LENGTH))) - (AIN STRING 1 LENGTH STREAM) - (COND - ((ODDP LENGTH) - (BIN STREAM))) - STRING]) - -(\GV.COLLECT.ENTRY - [LAMBDA (INSTREAM) (* lmm " 4-Apr-86 16:53") - - (* * Called by GV.READENTRY to parse and display some of what Grapevine sends - back as "the entire database entry" for NAME. - The contents are different for groups, individuals, and dead folk) - - (LET (NAMETYPE (RESULTS)) - (\RECEIVESTAMP INSTREAM T) (* Skip stamp) - (BIN16 INSTREAM) (* Skip component count) - - (* First component is the "prefix" %, which contains, among other things, the - name's type and its "official" name) - - (BIN16 INSTREAM) (* Length of this component) - (\RECEIVESTAMP INSTREAM T) (* Skip stamp) - (SETQ NAMETYPE (BIN16 INSTREAM)) - (\RECEIVERNAME INSTREAM) - (SELECTC NAMETYPE - (\NAMETYPE.INDIVIDUAL - (\SKIPCOMPONENT INSTREAM) (* Skip password) - (SETQ RESULTS (\GV.COLLECT.ENTRY.1 INSTREAM 'ConnectSite RESULTS)) - (SETQ RESULTS (\GV.COLLECT.ENTRY.LIST INSTREAM 'Forwarding RESULTS)) - (SETQ RESULTS (\GV.COLLECT.ENTRY.LIST INSTREAM 'MailboxSites RESULTS))) - (\NAMETYPE.GROUP - (\GV.COLLECT.ENTRY.1 INSTREAM 'Remark RESULTS) - (\MT.SKIPSTRINGLIST INSTREAM) - (\SKIPCOMPONENT INSTREAM) (* Skip stamp list) - (\SKIPCOMPONENT INSTREAM) (* Skip DelMembers) - (\SKIPCOMPONENT INSTREAM) (* Skip stamp list) - (PROGN (* owners) - (\MT.SKIPSTRINGLIST INSTREAM) - (\SKIPCOMPONENT INSTREAM) - (\SKIPCOMPONENT INSTREAM) - (\SKIPCOMPONENT INSTREAM)) - (PROGN (* friends) - (\MT.SKIPSTRINGLIST INSTREAM) - (\SKIPCOMPONENT INSTREAM) - (\SKIPCOMPONENT INSTREAM) - (\SKIPCOMPONENT INSTREAM)) - '((GROUP . T))) - (\NAMETYPE.DEAD - '((DEAD . T))) - NIL]) - -(\GV.COLLECT.ENTRY.1 - [LAMBDA (INSTREAM HEADING RESULTS) (* lmm " 2-Apr-86 12:51") - (COND - ((EQ (BIN16 INSTREAM) - 0) - RESULTS) - (T (CONS (CONS HEADING (LET [(STRLEN (PROGN (\RECEIVESTAMP INSTREAM T) - (* Skip stamp) - (BIN16 INSTREAM] - (LET ((STRING (ALLOCSTRING STRLEN))) - (AIN STRING 1 STRLEN INSTREAM) - (COND - ((ODDP STRLEN) - (BIN INSTREAM))) - STRING))) - RESULTS]) - -(\GV.COLLECT.ENTRY.LIST - [LAMBDA (INSTREAM HEADING RESULTS) (* lmm " 2-Apr-86 12:52") - - (* * return a component consisting of an RList, a stamp list, a "removal" RList - (not interesting) and another stamp list) - - (PROG1 (PROG ((CNT 0) - (NWORDS (BIN16 INSTREAM)) - STRLEN RMAR VAL) - (COND - ((EQ NWORDS 0) - (RETURN RESULTS))) - [do (add CNT 1) - (SETQ STRLEN (BIN16 INSTREAM)) - (BIN16 INSTREAM) (* ignore maxLength) - (push VAL (\GETSTRING INSTREAM STRLEN)) - (SETQ NWORDS (IDIFFERENCE NWORDS (IPLUS (QUOTIENT (ADD1 STRLEN) - 2) - 2))) - (COND - ((ILEQ NWORDS 0) - (RETURN] - (RETURN (CONS (CONS HEADING VAL) - RESULTS))) - (\SKIPCOMPONENT INSTREAM) - (\SKIPCOMPONENT INSTREAM) - (\SKIPCOMPONENT INSTREAM))]) -) - -(FILESLOAD (LOADCOMP) - MAINTAIN) -(PUTPROPS NSTHASIZE COPYRIGHT ("Xerox Corporation" 1986 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (830 13324 (CONVERT.GV.TO.NS 840 . 2194) (GV.READFORWARDING 2196 . 2378) ( -READ-GV-NS-MAPPING 2380 . 4071) (NSTHASIZE 4073 . 8385) (\GETSTRING 8387 . 8814) (\GV.COLLECT.ENTRY -8816 . 11260) (\GV.COLLECT.ENTRY.1 11262 . 12058) (\GV.COLLECT.ENTRY.LIST 12060 . 13322))))) -STOP diff --git a/obsolete/lispusers/OSS-LYRIC-PATCHES b/obsolete/lispusers/OSS-LYRIC-PATCHES deleted file mode 100644 index ad21906f..00000000 --- a/obsolete/lispusers/OSS-LYRIC-PATCHES +++ /dev/null @@ -1,31 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(filecreated "24-Mar-88 18:01:18" {eris}oss>lyric>oss-lyric-patches.\;1 2853 - - |changes| |to:| (vars oss-lyric-patchescoms) - - |previous| |date:| "24-Mar-88 16:56:45" {eris}oss>lyric>lyric-do-patch.\;1) - - -; Copyright (c) 1988 by Xerox Corporation. All rights reserved. - -(prettycomprint oss-lyric-patchescoms) - -(rpaqq oss-lyric-patchescoms ((* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.") (fns (* |;;| "from CMLSPECIALFORMS") \\do.translate) (functions (* |;;| "from CMLLIST") cl::%mapcar-multiple cl::%fill-slice-from-lists)) -) - - - -(* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.") - -(defineq - -(\\do.translate -(lambda (vars end-test body sequentialp env) (* \; "Edited 24-Mar-88 16:40 by drc:") (let ((vars-and-initial-values (mapcar vars (function (lambda (x) (cond ((nlistp x) (list x nil)) (t (list (car x) (cadr x)))))))) (subsequent-values (mapcar vars (function (lambda (x) (and (listp x) (cddr x) (list (car x) (caddr x))))))) (tag (gensym))) (and (setq subsequent-values (remove nil subsequent-values)) (setq subsequent-values (cons (cond (sequentialp (quote cl:setq)) (t (quote cl:psetq))) (apply (function append) subsequent-values)))) (cl:multiple-value-bind (body decls) (parse-body body env) (bquote ((\\\, (cond (sequentialp (quote prog*)) (t (quote prog)))) (\\\, vars-and-initial-values) (\\\,@ decls) (\\\, tag) (cond ((\\\, (car end-test)) (return (progn (\\\,@ (cdr end-test)))))) (\\\,@ body) (\\\, subsequent-values) (go (\\\, tag))))))) -) -) -(cl:defun cl::%mapcar-multiple (cl::fn cl::lists) (let ((cl::arg-slice (cl:make-list (length cl::lists)))) (cl:do ((cl::result nil) (cl::result-tail nil) (cl::current-slice cl::arg-slice) cl::element) ((null cl::current-slice) cl::result) (cl:setq cl::current-slice (cl::%fill-slice-from-lists cl::lists cl::arg-slice (car cl::arg-tail))) (cond (cl::current-slice (* \; "There is really more work to do.") (cl:setq cl::element (cl:apply cl::fn cl::current-slice)) (cl::%list-collect cl::result cl::result-tail (list cl::element))))))) -(defmacro cl::%fill-slice-from-lists (cl::lists cl::arg-slice cl::arg-tail-form) (bquote (cl:do ((cl::subslice (\\\, cl::arg-slice) (cdr cl::subslice)) (cl::sublist (\\\, cl::lists) (cdr cl::sublist)) (cl::some-list-empty nil) list) ((null cl::sublist) (cond (cl::some-list-empty (* \; "Ran out of entries in a list.") nil) (t (* \; "still work to do; return it.") (\\\, cl::arg-slice)))) (cl:setq list (car cl::sublist)) (cl:setq cl::some-list-empty (or cl::some-list-empty (null list))) (rplaca cl::subslice (prog1 (\\\, (cl:subst (quote list) (quote cl::arg-tail) cl::arg-tail-form)) (rplaca cl::sublist (cdr list))))))) -(putprops oss-lyric-patches copyright ("Xerox Corporation" 1988)) -(declare\: dontcopy - (filemap (nil (723 1605 (\\do.translate 733 . 1603))))) -stop diff --git a/obsolete/lispusers/PACKED-STRUCTURE b/obsolete/lispusers/PACKED-STRUCTURE deleted file mode 100644 index fc2753bd..00000000 --- a/obsolete/lispusers/PACKED-STRUCTURE +++ /dev/null @@ -1,24 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") -(il:filecreated "19-Oct-87 14:53:33" il:{erinyes}lyric>packed-structure.\;1 4305 - - il:|changes| il:|to:| (il:setfs logbitp) (il:functions def-packed-structure signed-ldb) - - il:|previous| il:|date:| "29-Sep-87 18:13:33" -il:|{IE:PARC:XEROX}LYRIC>LISPUSERS>PACKED-STRUCTURE.;1|) - - -; Copyright (c) 1987 by Xerox Corporation. All rights reserved. - -(il:prettycomprint il:packed-structurecoms) - -(il:rpaqq il:packed-structurecoms ((il:functions def-packed-structure signed-ldb) (il:setfs logbitp) (il:prop il:makefile-environment il:packed-structure)) -) -(defdefiner def-packed-structure il:structures (name &rest slots) (let* ((*package* (symbol-package name)) (count 0) (max-count 0) (locations)) (labels ((slot-name (slot) (car slot)) (slot-type (slot) (let ((type (getf (cddr slot) (quote :type) t))) (cond ((subtypep type (quote (member nil t))) (quote :boolean)) (t (il:* il:\; " punt for now, this should really coerce other things into stuff that looks like signed or unsigned byte ") type)))) (infix (x y) (intern (format nil "~A-~A" (string x) (string y)))) (slot-location (slot) (cdr (assoc (slot-name slot) locations))) (slot-supplied-p (slot) (infix (slot-name slot) "SUPPLIED-P")) (slot-signed (slot) (and (listp (slot-type slot)) (eq (car (slot-type slot)) (quote signed-byte)))) (slot-size (slot) (let ((type (slot-type slot))) (case type (:boolean 1) (t (ecase (car type) ((unsigned-byte signed-byte) (second type)))))))) (mapc (function (lambda (slot) (when (getf (cddr slot) (quote :overlay)) (setq count 0)) (push (cons (slot-name slot) count) locations) (incf count (slot-size slot)) (setq max-count (max max-count count)))) slots) (il:bquote (progn (deftype (il:\\\, name) nil (quote (unsigned-byte (il:\\\, count)))) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (defmacro (il:\\\, (infix name (slot-name s))) (x) (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logbitp (il:\\\, (quote (il:\\\, (slot-location s)))) (il:\\\, x))))) (t (il:bquote (il:bquote ((il:\\\, (quote (il:\\\, (if (slot-signed s) (quote signed-ldb) (quote ldb))))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, x))))))))))) slots)) (defmacro (il:\\\, (infix "MAKE" name)) (&key (il:\\\,@ (mapcar (function (lambda (s) (list (slot-name s) (second s) (slot-supplied-p s)))) slots)) &aux (value 0)) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (when (il:\\\, (slot-supplied-p s)) (setq value (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logior (if (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (ash 1 (slot-location s))))) 0) (il:\\\, value))))) ((slot-signed s) (il:bquote (il:bquote (dpb (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, value))))) (t (il:bquote (il:bquote (logior (ash (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (slot-location s))))) (il:\\\, value)))))))))))) slots)) value)))))) -(defun signed-ldb (bytespec integer) (flet ((sign-extend (number position) (if (logbitp (1- position) number) (dpb number (byte position 0) -1) number))) (sign-extend (ldb bytespec integer) (byte-size bytespec)))) -(define-setf-method logbitp (index integer) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method integer) (il:* il:\; "get SETF method for integer.") (let ((btemp (il:gensym)) (il:* il:\; "Temp var for index") (store (il:gensym)) (il:* il:\; "Temp var for new value") (stemp (first stores)) (il:* il:\; "Temp var for int to store.")) (values (cons btemp temps) (il:* il:\; "Temporary variables.") (cons index vals) (il:* il:\; "Value forms.") (list store) (il:* il:\; "Store variables.") (il:bquote (let (((il:\\\, stemp) (if (il:\\\, store) (logior (il:\\\, access-form) (ash 1 (il:\\\, btemp))) (logandc2 (il:\\\, access-form) (ash 1 (il:\\\, btemp)))))) (il:\\\, store-form) (il:\\\, store))) (il:* il:\; "Storing form") (il:bquote (logbitp (il:\\\, btemp) (il:\\\, access-form))))))) - -(il:putprops il:packed-structure il:makefile-environment (:readtable "XCL" :package "XCL-USER")) -(il:putprops il:packed-structure il:copyright ("Xerox Corporation" 1987)) -(il:declare\: il:dontcopy - (il:filemap (nil))) -il:stop diff --git a/obsolete/lispusers/PACKED-STRUCTURE.LCOM b/obsolete/lispusers/PACKED-STRUCTURE.LCOM deleted file mode 100644 index 2acdf075..00000000 --- a/obsolete/lispusers/PACKED-STRUCTURE.LCOM +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (IL:FILECREATED " 9-Sep-94 14:12:09" ("compiled on " IL:|{DSK}lispusers>PACKED-STRUCTURE.;1| ) "28-Jul-94 17:28:46" IL:|bcompl'd| IL:|in| "Medley 25-Aug-94 ..." IL:|dated| "25-Aug-94 10:02:49") (IL:FILECREATED "19-Oct-87 14:53:33" IL:{ERINYES}LYRIC>PACKED-STRUCTURE.\;1 4305 IL:|changes| IL:|to:| (IL:SETFS LOGBITP) (IL:FUNCTIONS DEF-PACKED-STRUCTURE SIGNED-LDB) IL:|previous| IL:|date:| "29-Sep-87 18:13:33" IL:|{IE:PARC:XEROX}LYRIC>LISPUSERS>PACKED-STRUCTURE.;1|) (IL:PRETTYCOMPRINT IL:PACKED-STRUCTURECOMS) (IL:RPAQQ IL:PACKED-STRUCTURECOMS ((IL:FUNCTIONS DEF-PACKED-STRUCTURE SIGNED-LDB) (IL:SETFS LOGBITP) ( IL:PROP IL:MAKEFILE-ENVIRONMENT IL:PACKED-STRUCTURE))) (DEFDEFINER DEF-PACKED-STRUCTURE IL:STRUCTURES (NAME &REST SLOTS) (LET* ((*PACKAGE* (SYMBOL-PACKAGE NAME)) (COUNT 0) (MAX-COUNT 0) (LOCATIONS)) (LABELS ((SLOT-NAME (SLOT) (CAR SLOT)) (SLOT-TYPE (SLOT) ( LET ((TYPE (GETF (CDDR SLOT) (QUOTE :TYPE) T))) (COND ((SUBTYPEP TYPE (QUOTE (MEMBER NIL T))) (QUOTE :BOOLEAN)) (T (IL:* IL:\; " punt for now, this should really coerce other things into stuff that looks like signed or unsigned byte " ) TYPE)))) (INFIX (X Y) (INTERN (FORMAT NIL "~A-~A" (STRING X) (STRING Y)))) (SLOT-LOCATION (SLOT) ( CDR (ASSOC (SLOT-NAME SLOT) LOCATIONS))) (SLOT-SUPPLIED-P (SLOT) (INFIX (SLOT-NAME SLOT) "SUPPLIED-P") ) (SLOT-SIGNED (SLOT) (AND (LISTP (SLOT-TYPE SLOT)) (EQ (CAR (SLOT-TYPE SLOT)) (QUOTE SIGNED-BYTE)))) (SLOT-SIZE (SLOT) (LET ((TYPE (SLOT-TYPE SLOT))) (CASE TYPE (:BOOLEAN 1) (T (ECASE (CAR TYPE) (( UNSIGNED-BYTE SIGNED-BYTE) (SECOND TYPE)))))))) (MAPC (FUNCTION (LAMBDA (SLOT) (WHEN (GETF (CDDR SLOT) (QUOTE :OVERLAY)) (SETQ COUNT 0)) (PUSH (CONS (SLOT-NAME SLOT) COUNT) LOCATIONS) (INCF COUNT ( SLOT-SIZE SLOT)) (SETQ MAX-COUNT (MAX MAX-COUNT COUNT)))) SLOTS) (IL:BQUOTE (PROGN (DEFTYPE (IL:\\\, NAME) NIL (QUOTE (UNSIGNED-BYTE (IL:\\\, COUNT)))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (S) (IL:BQUOTE (DEFMACRO (IL:\\\, (INFIX NAME (SLOT-NAME S))) (X) (IL:\\\, (COND ((EQ (SLOT-TYPE S) (QUOTE :BOOLEAN)) (IL:BQUOTE (IL:BQUOTE (LOGBITP (IL:\\\, (QUOTE (IL:\\\, (SLOT-LOCATION S)))) (IL:\\\, X))))) (T ( IL:BQUOTE (IL:BQUOTE ((IL:\\\, (QUOTE (IL:\\\, (IF (SLOT-SIGNED S) (QUOTE SIGNED-LDB) (QUOTE LDB))))) (IL:\\\, (QUOTE (IL:\\\, (BYTE (SLOT-SIZE S) (SLOT-LOCATION S))))) (IL:\\\, X))))))))))) SLOTS)) ( DEFMACRO (IL:\\\, (INFIX "MAKE" NAME)) (&KEY (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (S) (LIST (SLOT-NAME S) (SECOND S) (SLOT-SUPPLIED-P S)))) SLOTS)) &AUX (VALUE 0)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (S) ( IL:BQUOTE (WHEN (IL:\\\, (SLOT-SUPPLIED-P S)) (SETQ VALUE (IL:\\\, (COND ((EQ (SLOT-TYPE S) (QUOTE :BOOLEAN)) (IL:BQUOTE (IL:BQUOTE (LOGIOR (IF (IL:\\\, (IL:\\\, (SLOT-NAME S))) (IL:\\\, (QUOTE (IL:\\\, (ASH 1 (SLOT-LOCATION S))))) 0) (IL:\\\, VALUE))))) ((SLOT-SIGNED S) (IL:BQUOTE (IL:BQUOTE (DPB ( IL:\\\, (IL:\\\, (SLOT-NAME S))) (IL:\\\, (QUOTE (IL:\\\, (BYTE (SLOT-SIZE S) (SLOT-LOCATION S))))) ( IL:\\\, VALUE))))) (T (IL:BQUOTE (IL:BQUOTE (LOGIOR (ASH (IL:\\\, (IL:\\\, (SLOT-NAME S))) (IL:\\\, ( QUOTE (IL:\\\, (SLOT-LOCATION S))))) (IL:\\\, VALUE)))))))))))) SLOTS)) VALUE)))))) (DEFUN SIGNED-LDB (BYTESPEC INTEGER) (FLET ((SIGN-EXTEND (NUMBER POSITION) (IF (LOGBITP (1- POSITION) NUMBER) (DPB NUMBER (BYTE POSITION 0) -1) NUMBER))) (SIGN-EXTEND (LDB BYTESPEC INTEGER) (BYTE-SIZE BYTESPEC)))) (DEFINE-SETF-METHOD LOGBITP (INDEX INTEGER) (MULTIPLE-VALUE-BIND (TEMPS VALS STORES STORE-FORM ACCESS-FORM) (GET-SETF-METHOD INTEGER) (IL:* IL:\; "get SETF method for integer.") (LET ((BTEMP ( IL:GENSYM)) (IL:* IL:\; "Temp var for index") (STORE (IL:GENSYM)) (IL:* IL:\; "Temp var for new value" ) (STEMP (FIRST STORES)) (IL:* IL:\; "Temp var for int to store.")) (VALUES (CONS BTEMP TEMPS) (IL:* IL:\; "Temporary variables.") (CONS INDEX VALS) (IL:* IL:\; "Value forms.") (LIST STORE) (IL:* IL:\; "Store variables.") (IL:BQUOTE (LET (((IL:\\\, STEMP) (IF (IL:\\\, STORE) (LOGIOR (IL:\\\, ACCESS-FORM ) (ASH 1 (IL:\\\, BTEMP))) (LOGANDC2 (IL:\\\, ACCESS-FORM) (ASH 1 (IL:\\\, BTEMP)))))) (IL:\\\, STORE-FORM) (IL:\\\, STORE))) (IL:* IL:\; "Storing form") (IL:BQUOTE (LOGBITP (IL:\\\, BTEMP) (IL:\\\, ACCESS-FORM))))))) (IL:PUTPROPS IL:PACKED-STRUCTURE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL-USER")) (IL:PUTPROPS IL:PACKED-STRUCTURE IL:COPYRIGHT ("Xerox Corporation" 1987)) NIL \ No newline at end of file diff --git a/obsolete/lispusers/PATCH-LARGEIPBITMAP b/obsolete/lispusers/PATCH-LARGEIPBITMAP deleted file mode 100644 index 498042aa..00000000 --- a/obsolete/lispusers/PATCH-LARGEIPBITMAP +++ /dev/null @@ -1,111 +0,0 @@ -(FILECREATED "25-Aug-87 14:23:20" {ERINYES}KOTO>PATCH-LARGEIPBITMAP.;1 5638 - - changes to: (VARS PATCH-LARGEIPBITMAPCOMS) - (FNS SHOWBITMAP1.IP)) - - -(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT PATCH-LARGEIPBITMAPCOMS) - -(RPAQQ PATCH-LARGEIPBITMAPCOMS ((* * Fix problem of SHOWBITMAP1.IP in Koto placing the parts of a - large bitmap in the wrong order) - (FNS SHOWBITMAP1.IP))) - (* * Fix problem of SHOWBITMAP1.IP in Koto placing the parts of a large bitmap in the wrong -order) - -(DEFINEQ - -(SHOWBITMAP1.IP - [LAMBDA (IPSTREAM BITMAP LEFT FIRSTROW XPIXELS YPIXELS SCALEFACTOR ROTATION HEIGHT XBYTES - REGIONBOTTOM) (* N.H.Briggs "25-Aug-87 14:06") - (* jds "13-Jan-86 18:13") - (* ;; -"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) - (SELECTQ (IMOD (OR ROTATION 0) - 360) - (0 (* ;  -  -"Bitmaps are really shown on their sides, hanging from the upper left corner (I think--JDS)") - (ROTATE.IP IPSTREAM -90) - (TRANSLATE.IP IPSTREAM 0 (IPLUS FIRSTROW YPIXELS)) - (* ;;  -  -"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." -) - (CONCAT.IP IPSTREAM)) - (90 (* ; "need nop") - (TRANSLATE.IP IPSTREAM (IDIFFERENCE HEIGHT (IPLUS FIRSTROW YPIXELS)) - 0) (* ;;  -  -"Push this segment up to its 'true' bottom -- i.e., The first segment gets pushed up to bitmapHeight-HeightOfSegment (since it's the top of the bitmap), the next segment gets pushed up HEIGHT-RowsIn1stSeg-RowsThisSeg (to account for the first segment), and so on." -) - ) - (180 (* ;;  -  -"The translation for this hasn't been tested yet. It may well be the inverse of the rotation-0 correction") - (ROTATE.IP IPSTREAM 90) - (TRANSLATE.IP IPSTREAM 0 (IPLUS FIRSTROW YPIXELS)) - (CONCAT.IP IPSTREAM)) - (270 (* ;;  -  -"The translation for this hasn't been tested yet. It may well be the inverse of the rotation-90 correction") - (ROTATE.IP IPSTREAM 180) - (TRANSLATE.IP IPSTREAM (IDIFFERENCE HEIGHT (IPLUS FIRSTROW YPIXELS)) - 0) - (CONCAT.IP IPSTREAM)) - (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 put 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 (QUOTE INPUT) - (QUOTE REPLACE)) - (\BOUTS IPSTREAM (fetch (BITMAP BITMAPBASE) of SCRATCHBM) - 0 - (CEIL XBYTES BYTESPERCELL))) - (APPENDOP.IP IPSTREAM MAKEPIXELARRAY) - (APPENDOP.IP IPSTREAM MASKPIXEL) - (APPENDOP.IP IPSTREAM }]) -) -(PUTPROPS PATCH-LARGEIPBITMAP COPYRIGHT ("Xerox Corporation" 1987)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (565 5548 (SHOWBITMAP1.IP 575 . 5546))))) -STOP diff --git a/obsolete/lispusers/PATCH-TWOSIDED b/obsolete/lispusers/PATCH-TWOSIDED deleted file mode 100644 index 265a7bc2..00000000 --- a/obsolete/lispusers/PATCH-TWOSIDED +++ /dev/null @@ -1,169 +0,0 @@ -(FILECREATED " 1-Sep-87 11:23:23" {ERINYES}KOTO>PATCH-TWOSIDED.;1 6479 - - previous date: "15-Oct-86 12:20:47" {QV}LISP>PATCH-TWOSIDED.;1) - - -(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT PATCH-TWOSIDEDCOMS) - -(RPAQQ PATCH-TWOSIDEDCOMS ((FNS \NSPRINT.INTERNAL) - (DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP) - NSPRINT)))) -(DEFINEQ - -(\NSPRINT.INTERNAL - [LAMBDA (PRINTER OPTIONS TRANSFERFN) (* N.H.Briggs "27-Sep-86 16:31") - - (* * Calls the PRINT program for PRINTER, interpreting OPTIONS as a plist of print options. - TRANSFERFN is a function applied to the transfer stream to actually send the Interpress master) - - - (PROG ((MEDIUM (OR (LISTGET OPTIONS (QUOTE MEDIUM)) - NSPRINT.DEFAULT.MEDIUM)) - (STAPLE? (LISTGET OPTIONS (QUOTE STAPLE?))) - (TWO.SIDED? (EQ 2 (OR (LISTGET OPTIONS (QUOTE #SIDES)) - EMPRESS#SIDES))) - (SENDER.NAME (OR (LISTGET OPTIONS (QUOTE SENDER.NAME)) - (USERNAME NIL NIL T))) - (DOCNAME (OR (LISTGET OPTIONS (QUOTE DOCUMENT.NAME)) - "Document")) - PROPERTIES ATTRIBUTES COURIERSTREAM VALUE PRINTOPTIONS STATUS) - [SETQ ATTRIBUTES (BQUOTE ((PRINT.OBJECT.NAME , DOCNAME) - (PRINT.OBJECT.CREATE.DATE , (OR (LISTGET OPTIONS - (QUOTE - - DOCUMENT.CREATION.DATE)) - (IDATE))) - (SENDER.NAME , SENDER.NAME] - [SETQ PRINTOPTIONS (BQUOTE ((COPY.COUNT , (FIX (OR (LISTGET OPTIONS - (QUOTE #COPIES)) - 1] - (* This "option" seems to be required) - [COND - ((SETQ VALUE (LISTGET OPTIONS (QUOTE RECIPIENT.NAME))) - (push PRINTOPTIONS (LIST (QUOTE RECIPIENT.NAME) - (OR (STRINGP VALUE) - (MKSTRING VALUE] - [COND - ((SETQ VALUE (LISTGET OPTIONS (QUOTE PRIORITY))) - (push PRINTOPTIONS (LIST (QUOTE PRIORITY.HINT) - (SELECTQ VALUE - ((HOLD LOW NORMAL HIGH) - VALUE) - (\ILLEGAL.ARG VALUE] - [COND - ((SETQ VALUE (LISTGET OPTIONS (QUOTE MESSAGE))) - (push PRINTOPTIONS (LIST (QUOTE MESSAGE) - (OR (STRINGP VALUE) - (MKSTRING VALUE] - [COND - ((SETQ VALUE (LISTGET OPTIONS (QUOTE PAGES.TO.PRINT))) - (* A page range to print, (first# last#)) - (COND - ((AND (LISTP VALUE) - (LISTP (CDR VALUE)) - (NULL (CDDR VALUE)) - (SMALLPOSP (CAR VALUE)) - (SMALLPOSP (CADR VALUE))) - (push PRINTOPTIONS (LIST (QUOTE PAGES.TO.PRINT) - VALUE))) - (T (\ILLEGAL.ARG VALUE] - RETRY - (COND - ((NOT (SETQ COURIERSTREAM (\NSPRINT.COURIER.OPEN PRINTER))) - (printout PROMPTWINDOW .TAB0 0 "No response from printer " (fetch NSPRINTERNAME - of PRINTER)) - (DISMISS 5000) - (GO RETRY))) - (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) - COURIERSTREAM)) (* Check the status of the printer.) - (bind (LASTSTATUS _ 0) - do (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING) - (QUOTE GET.PRINTER.STATUS) - (QUOTE RETURNERRORS))) - [COND - ((EQ (CAR STATUS) - (QUOTE ERROR)) - (COND - ((NOT (EQUAL STATUS LASTSTATUS)) - (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER) - " Error: " - (SUBSTRING (CDR STATUS) - 2 -2) - "; will retry]"))) (* Wait longer for this problem) - (DISMISS 30000)) - ((NEQ (SETQ STATUS (CADR (ASSOC (QUOTE SPOOLER) - STATUS))) - LASTSTATUS) - (SELECTQ STATUS - (Available (RETURN)) - (Busy (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME - of PRINTER) - " Status: Spooler busy; will retry]")) - (ERROR "Printer spooler" STATUS] - (SETQ LASTSTATUS STATUS) - (DISMISS 5000)) - [COND - ((OR MEDIUM STAPLE? TWO.SIDED?) (* Check that the printer supports these options.) - (SETQ PROPERTIES (COURIER.CALL COURIERSTREAM (QUOTE PRINTING) - (QUOTE GET.PRINTER.PROPERTIES) - (QUOTE RETURNERRORS))) - (COND - ((EQ (CAR PROPERTIES) - (QUOTE ERROR)) - (SETQ STATUS PROPERTIES) - (GO HANDLE.ERROR))) - [COND - (MEDIUM (COND - ((SETQ VALUE (\NSPRINT.MEDIUM.CHECK MEDIUM - (CADR (ASSOC (QUOTE MEDIA) - PROPERTIES)) - PRINTER)) - (push PRINTOPTIONS (LIST (QUOTE MEDIUM.HINT) - VALUE)) - (SETQ MEDIUM] - [COND - (STAPLE? (COND - ((CADR (ASSOC (QUOTE STAPLE) - PROPERTIES)) - (push PRINTOPTIONS (LIST (QUOTE STAPLE) - T)) - (SETQ STAPLE?)) - (T (printout PROMPTWINDOW .TAB0 0 - "[Printer does not support stapled copies]"] - (COND - (TWO.SIDED? (COND - ((CADR (ASSOC (QUOTE TWO.SIDED) - PROPERTIES)) - (push PRINTOPTIONS (QUOTE (TWO.SIDED T))) - (SETQ TWO.SIDED?)) - (T (printout PROMPTWINDOW .TAB0 0 - "Printer does not support two-sided copies"] - - (* * Finally, send the print document) - - - (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING) - (QUOTE PRINT) - TRANSFERFN ATTRIBUTES PRINTOPTIONS (QUOTE RETURNERRORS))) - (COND - ((NEQ (CAR STATUS) - (QUOTE ERROR)) - (RETURN STATUS))) - HANDLE.ERROR - (ERROR (CONCAT "Unexpected error from " (fetch NSPRINTERNAME of PRINTER) - " attempting to print " DOCNAME " -RETURN to try again.") - (CDR STATUS)) - (CLOSEF COURIERSTREAM) - (GO RETRY]) -) -(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY -(FILESLOAD (LOADCOMP) - NSPRINT) -) -(PUTPROPS PATCH-TWOSIDED COPYRIGHT ("Xerox Corporation" 1986 1987)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (433 6305 (\NSPRINT.INTERNAL 443 . 6303))))) -STOP diff --git a/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT b/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT deleted file mode 100644 index 169d3161..00000000 --- a/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") (FILECREATED "30-Mar-89 09:18:42" {ERINYES}MEDLEY>POSTSCRIPT>POSTSCRIPT.;6 109842 changes to%: (FNS POSTSCRIPT.INIT \BITBLT.PSC) previous date%: "22-Feb-89 15:28:19" {ERINYES}MEDLEY>POSTSCRIPT>POSTSCRIPT.;5) (* " Copyright (c) 1986, 1987, 1988, 1989 by Beckman Instruments, Inc. All rights reserved. ") (PRETTYCOMPRINT POSTSCRIPTCOMS) (RPAQQ POSTSCRIPTCOMS [(RECORDS BRUSH FONTID ARRAYP PSCFONT \POSTSCRIPTDATA) (FNS CLOSEPOSTSCRIPTSTREAM OPENPOSTSCRIPTSTREAM POSTSCRIPT.BITMAPSCALE POSTSCRIPT.CLOSESTRING POSTSCRIPT.FONTCREATE POSTSCRIPT.FONTSAVAILABLE POSTSCRIPT.GETFONTID POSTSCRIPT.HARDCOPYW POSTSCRIPT.INIT POSTSCRIPT.OUTSTR POSTSCRIPT.PUTBITMAPBYTES POSTSCRIPT.PUTCOMMAND POSTSCRIPT.SHOWACCUM POSTSCRIPT.STARTPAGE POSTSCRIPT.TEDIT POSTSCRIPT.TEXT POSTSCRIPTFILEP PSCFONT.READFONT PSCFONT.SPELLFILE PSCFONT.WRITEFONT READ-AFM-FILE \BITBLT.PSC \BLTSHADE.PSC \CHARWIDTH.PSC \DRAWARC.PSC \DRAWCIRCLE.PSC \DRAWCURVE.PSC \DRAWELLIPSE.PSC \DRAWLINE.PSC \DRAWPOLYGON.PSC \DSPBOTTOMMARGIN.PSC \DSPCLIPPINGREGION.PSC \DSPFONT.PSC \DSPLEFTMARGIN.PSC \DSPLINEFEED.PSC \DSPRESET.PSC \DSPRIGHTMARGIN.PSC \DSPSCALE.PSC \DSPSPACEFACTOR.PSC \DSPTOPMARGIN.PSC \DSPXPOSITION.PSC \DSPYPOSITION.PSC \FILLCIRCLE.PSC \FILLPOLYGON.PSC \MOVETO.PSC \NEWPAGE.PSC \POSTSCRIPT.OUTCHARFN \POSTSCRIPT.PUTCHAR \STRINGWIDTH.PSC \TERPRI.PSC \DSPROTATE.PSC \DSPTRANSLATE.PSC \DRAWPOINT.PSC) (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)) PS.BITMAPARRAY \POSTSCRIPT.JOB.SETUP SlopeMenuItems WeightMenuItems) (CONSTANTS (GOLDEN.RATIO 1.618034)) (INITVARS (POSTSCRIPT.BITMAP.SCALE 1) (POSTSCRIPT.IMAGESIZEFACTOR 1.0) (POSTSCRIPT.PREFER.LANDSCAPE NIL) (POSTSCRIPT.TEXTFILE.LANDSCAPE NIL) (POSTSCRIPT.TEXTURE.SCALE 4) (POSTSCRIPTFONTDIRECTORIES '("{DSK}FONTS>PSC>")) (\POSTSCRIPT.LONGEDGE.SHIFT 0) (\POSTSCRIPT.SHORTEDGE.SHIFT 0) (\POSTSCRIPT.LONGEDGE.PTS (+ (TIMES 72 10.92) \POSTSCRIPT.SHORTEDGE.SHIFT)) (\POSTSCRIPT.SHORTEDGE.PTS (+ (TIMES 72 8.0) \POSTSCRIPT.LONGEDGE.SHIFT)) (\POSTSCRIPT.MAX.WILD.FONTSIZE 72)) [ADDVARS (POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) (TIMESROMAN . TIMES) (TIMESROMAND . TIMES) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . TIMES) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA)) [PRINTERTYPES ((POSTSCRIPT) (CANPRINT (POSTSCRIPT)) (STATUS TRUE) (PROPERTIES NILL) (SEND POSTSCRIPT.SEND) (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION TITLE] [PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) (EXTENSION (PS PSC)) (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT] (IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) (CREATECHARSET NILL] (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.FONT.ALIST POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.LONGEDGE.PTS \POSTSCRIPT.LONGEDGE.SHIFT \POSTSCRIPT.MAX.WILD.FONTSIZE \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPT.SHORTEDGE.PTS \POSTSCRIPT.SHORTEDGE.SHIFT \POSTSCRIPTIMAGEOPS) (FILES PS-SEND) (P (POSTSCRIPT.INIT)) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) POSTSCRIPT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA POSTSCRIPT.PUTCOMMAND ]) (DECLARE%: EVAL@COMPILE (RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1) (RECORD FONTID (FONTIDNAME FONTXFACTOR FONTOBLIQUEFACTOR)) (DATATYPE ARRAYP ((ORIG BITS 1) (NIL BITS 1) (READONLY FLAG) (* ; "probably no READONLY arrays now") (NIL BITS 1) (TYP BITS 4) (BASE POINTER) (LENGTH WORD) (OFFST WORD)) (* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}") ) (RECORD PSCFONT (FID IL-FONTID FIRSTCHAR LASTCHAR ASCENT DESCENT WIDTHS)) (DATATYPE \POSTSCRIPTDATA (POSTSCRIPTFONT (* ;  "The fontdescriptor of the current font") POSTSCRIPTX POSTSCRIPTY POSTSCRIPTLEFTMARGIN POSTSCRIPTRIGHTMARGIN POSTSCRIPTBOTTOMMARGIN POSTSCRIPTTOPMARGIN POSTSCRIPTLINESPACING POSTSCRIPTCOLOR POSTSCRIPTSCALE POSTSCRIPTOPERATION POSTSCRIPTCLIPPINGREGION POSTSCRIPTPAGENUM POSTSCRIPTHEADING POSTSCRIPTHEADINGFONT POSTSCRIPTSPACEFACTOR (* ;  "The expansion factor for spaces (see DSPSPACEFACTOR)") POSTSCRIPTLANDSCAPE (* ;  "T means that the paper is in 'landscape' mode") POSTSCRIPTCHARSTOSHOW (* ;  "T means that the string of chars has already been started") ) POSTSCRIPTSPACEFACTOR _ 1 POSTSCRIPTPAGENUM _ 0) ) (/DECLAREDATATYPE 'ARRAYP '((BITS 1) (BITS 1) FLAG (BITS 1) (BITS 4) POINTER WORD WORD) '((ARRAYP 0 (BITS . 0)) (ARRAYP 0 (BITS . 16)) (ARRAYP 0 (FLAGBITS . 32)) (ARRAYP 0 (BITS . 48)) (ARRAYP 0 (BITS . 67)) (ARRAYP 0 POINTER) (ARRAYP 2 (BITS . 15)) (ARRAYP 3 (BITS . 15))) '4) (/DECLAREDATATYPE '\POSTSCRIPTDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((\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)) '36) (DEFINEQ (CLOSEPOSTSCRIPTSTREAM [LAMBDA (VSTREAM) (* ; "Edited 20-Jan-88 17:43 by Matt Heffron") (POSTSCRIPT.PUTCOMMAND VSTREAM " savepage restore showpage %%%%Trailer "]) (OPENPOSTSCRIPTSTREAM [LAMBDA (FILE OPTIONS) (* ; "Edited 20-Oct-88 14:45 by Matt Heffron") (LET ([FP (OPENSTREAM (if (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'EXTENSION) "") (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'HOST) "LPT")) then (PACKFILENAME.STRING 'HOST "LPT" 'NAME (UNPACKFILENAME.STRING FILE 'NAME) 'EXTENSION "PS") else FILE) 'OUTPUT NIL '((TYPE POSTSCRIPT) (SEQUENTIAL T] (IMAGEDATA (create \POSTSCRIPTDATA)) LANDSCAPE? FONT IMAGESIZEFACTOR SHORTEDGE LONGEDGE TEMP) (SETFILEINFO FP 'EOL 'CR) (replace (STREAM OUTCHARFN) of FP with '\FILEOUTCHARFN) (printout FP "%%!PS-Adobe-2.0" T "%%%%Title: " (MKSTRING (OR (LISTGET OPTIONS 'DOCUMENT.NAME) FILE)) T "%%%%Creator: PostScript ImageStream Driver by Matt Heffron of Beckman Instruments" T "%%%%CreationDate: " (DATE) T "%%%%For: " (if (STRING-EQUAL INITIALS "Edited:") then (MKSTRING USERNAME) else INITIALS) T "%%%%EndComments" T) (for PJS in \POSTSCRIPT.JOB.SETUP do (PRIN1 PJS FP) (TERPRI FP)) [if (SETQ LANDSCAPE? (CL:GETF OPTIONS 'ROTATION 'DEFAULTNIL)) then (if (EQ LANDSCAPE? 'DEFAULTNIL) then (SETQ LANDSCAPE? (if (EQ POSTSCRIPT.PREFER.LANDSCAPE 'ASK) then (MENU \POSTSCRIPT.ORIENTATION.MENU) else POSTSCRIPT.PREFER.LANDSCAPE] (replace POSTSCRIPTLANDSCAPE of IMAGEDATA with LANDSCAPE?) (if (NOT (AND (SETQ IMAGESIZEFACTOR (LISTGET OPTIONS 'IMAGESIZEFACTOR)) (NUMBERP IMAGESIZEFACTOR) (CL:PLUSP IMAGESIZEFACTOR))) then (SETQ IMAGESIZEFACTOR 1.0)) (if (AND (NUMBERP POSTSCRIPT.IMAGESIZEFACTOR) (CL:PLUSP POSTSCRIPT.IMAGESIZEFACTOR)) then (SETQ IMAGESIZEFACTOR (TIMES IMAGESIZEFACTOR POSTSCRIPT.IMAGESIZEFACTOR))) (PRIN1 "/imagesizefactor " FP) (PRIN1 IMAGESIZEFACTOR FP) (PRIN1 " def" FP) (TERPRI FP) (PRIN1 "%%%%EndSetup" FP) (TERPRI FP) (replace POSTSCRIPTSCALE of IMAGEDATA with 100.0) (SETQ LONGEDGE (FQUOTIENT (FTIMES \POSTSCRIPT.LONGEDGE.PTS 100.0) IMAGESIZEFACTOR)) (SETQ SHORTEDGE (FQUOTIENT (FTIMES \POSTSCRIPT.SHORTEDGE.PTS 100.0) IMAGESIZEFACTOR)) (replace (STREAM IMAGEOPS) of FP with \POSTSCRIPTIMAGEOPS) (replace (STREAM IMAGEDATA) of FP with IMAGEDATA) (replace (STREAM LINELENGTH) of FP with MAX.SMALLP) (replace (STREAM CHARPOSITION) of FP with 0) (replace (STREAM OUTCHARFN) of FP with '\POSTSCRIPT.OUTCHARFN) (if LANDSCAPE? then (\DSPTOPMARGIN.PSC FP (FIXR SHORTEDGE)) (\DSPRIGHTMARGIN.PSC FP (FIXR LONGEDGE)) (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with (create REGION LEFT _ 0.0 BOTTOM _ 0.0 WIDTH _ LONGEDGE HEIGHT _ SHORTEDGE)) else (\DSPTOPMARGIN.PSC FP (FIXR LONGEDGE)) (\DSPRIGHTMARGIN.PSC FP (FIXR SHORTEDGE)) (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with (create REGION LEFT _ 0.0 BOTTOM _ 0.0 WIDTH _ SHORTEDGE HEIGHT _ LONGEDGE))) (SETQ FONT (FONTCREATE (OR [CAR (MKLIST (LISTGET OPTIONS 'FONTS] DEFAULTFONT) NIL NIL NIL FP)) (if (SETQ TEMP (LISTGET OPTIONS 'HEADING)) then (replace POSTSCRIPTHEADING of IMAGEDATA with TEMP) (replace POSTSCRIPTHEADINGFONT of IMAGEDATA with FONT)) (\DSPLEFTMARGIN.PSC FP 0) (\DSPBOTTOMMARGIN.PSC FP 0) (\DSPFONT.PSC FP FONT) (\DSPLINEFEED.PSC FP (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of FONT))) (POSTSCRIPT.STARTPAGE FP) FP]) (POSTSCRIPT.BITMAPSCALE [LAMBDA (WIDTH HEIGHT) (* ; "Edited 20-Oct-88 14:48 by Matt Heffron") (LET* ([MINDIMP (MIN (FQUOTIENT \POSTSCRIPT.LONGEDGE.PTS (SETQ HEIGHT (TIMES HEIGHT POSTSCRIPT.BITMAP.SCALE ))) (FQUOTIENT \POSTSCRIPT.SHORTEDGE.PTS (SETQ WIDTH (TIMES WIDTH POSTSCRIPT.BITMAP.SCALE ] (MINDIML (MIN (FQUOTIENT \POSTSCRIPT.SHORTEDGE.PTS HEIGHT) (FQUOTIENT \POSTSCRIPT.LONGEDGE.PTS 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 12-Jan-88 12:33 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (if (fetch POSTSCRIPTCHARSTOSHOW of IMAGEDATA) then (POSTSCRIPT.OUTSTR STREAM ") ") (replace POSTSCRIPTCHARSTOSHOW of IMAGEDATA with NIL) T else NIL]) (POSTSCRIPT.FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 12-Jan-88 12:36 by Matt Heffron") (LET (UNITFONT FULLNAME SCALEFONTP PSCFD ASCENT DESCENT FIXPWIDTHS CHARSETINFO0 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.") (if (EQ SIZE 1) then (* ;; "Since a 1 point font is rediculously 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") (if (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) then (SETQ FACECHANGED NIL) elseif (AND (NEQ EXPANSION 'REGULAR) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT SLOPE 'REGULAR) ROTATION DEVICE))) then (SETQ FACECHANGED T) elseif (AND (EQ SLOPE 'ITALIC) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR EXPANSION) ROTATION DEVICE))) then (SETQ FACECHANGED T) elseif (AND (NEQ EXPANSION 'REGULAR) (EQ SLOPE 'ITALIC) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST WEIGHT 'REGULAR 'REGULAR) ROTATION DEVICE))) then (SETQ FACECHANGED T) elseif (AND (NEQ WEIGHT 'MEDIUM) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE EXPANSION) ROTATION DEVICE))) then (SETQ FACECHANGED T) elseif (AND (NEQ WEIGHT 'MEDIUM) (NEQ EXPANSION 'REGULAR) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM SLOPE 'REGULAR) ROTATION DEVICE))) then (SETQ FACECHANGED T) elseif (AND (NEQ WEIGHT 'MEDIUM) (EQ SLOPE 'ITALIC) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR EXPANSION) ROTATION DEVICE))) then (SETQ FACECHANGED T) elseif (AND (NEQ WEIGHT 'MEDIUM) (NEQ EXPANSION 'REGULAR) (EQ SLOPE 'ITALIC) (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE (LIST 'MEDIUM 'REGULAR 'REGULAR) ROTATION DEVICE))) then (SETQ FACECHANGED T)) [if FULLNAME then (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) (SETQ ASCENT (FIXR (TIMES (fetch (PSCFONT ASCENT) of PSCFD) 0.1))) (SETQ DESCENT (FIXR (TIMES (fetch (PSCFONT DESCENT) of PSCFD) 0.1))) (if FACECHANGED then (replace (PSCFONT IL-FONTID) of PSCFD with (POSTSCRIPT.GETFONTID (fetch (PSCFONT FID) of PSCFD) WEIGHT SLOPE EXPANSION] elseif (SETQ UNITFONT (FONTCREATE FAMILY 1 FACE ROTATION DEVICE T)) then (SETQ PSCFD (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of UNITFONT)) (* ;; "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) else (* ;; "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.") (if (SETQ FULLNAME (PSCFONT.SPELLFILE FAMILY SIZE FACE ROTATION DEVICE)) then (SETQ PSCFD (PSCFONT.READFONT FULLNAME)) (SETQ ASCENT (fetch (PSCFONT ASCENT) of PSCFD)) (SETQ DESCENT (fetch (PSCFONT DESCENT) of PSCFD)) (SETQ SCALEFONTP NIL))) (if PSCFD then (SETQ FIXPWIDTHS (fetch (PSCFONT WIDTHS) of PSCFD)) (SETQ CHARSETINFO0 (create CHARSETINFO)) (SETQ WIDTHSBLOCK (fetch (CHARSETINFO WIDTHS) of CHARSETINFO0)) (SETQ FD (create FONTDESCRIPTOR FONTDEVICESPEC _ PSCFD FONTSCALE _ 100.0 FONTDEVICE _ DEVICE FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE ROTATION _ 0 \SFHeight _ (IPLUS ASCENT DESCENT) \SFAscent _ ASCENT \SFDescent _ DESCENT \SFRWidths _ WIDTHSBLOCK FONTIMAGEWIDTHS _ WIDTHSBLOCK)) (replace (CHARSETINFO IMAGEWIDTHS) of CHARSETINFO0 with WIDTHSBLOCK) (replace (CHARSETINFO CHARSETASCENT) of CHARSETINFO0 with ASCENT) (replace (CHARSETINFO CHARSETDESCENT) of CHARSETINFO0 with DESCENT) [if SCALEFONTP then [for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (FIXR (TIMES SIZE (ELT FIXPWIDTHS CH) 0.1] else (for CH from 0 to 255 do (\FSETWIDTH WIDTHSBLOCK CH (ELT FIXPWIDTHS CH] (\SETCHARSETINFO (fetch FONTCHARSETVECTOR of FD) 0 CHARSETINFO0) FD else NIL]) (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]) (POSTSCRIPT.GETFONTID [LAMBDA (FID WEIGHT SLOPE EXPANSION) (* ; "Edited 12-Jan-88 12:58 by Matt Heffron") (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 FONTOBLIQUEFACTOR of FONTID with (CONSTANT (TAN 7.0] (if (AND (NEQ (CADR FID) WEIGHT) (EQ WEIGHT 'BOLD)) then (* ; "Fake bold by slight expansion.") (replace FONTXFACTOR of FONTID with 1.1)) [if (NEQ EXPANSION 'REGULAR) then (replace FONTXFACTOR of FONTID with (TIMES (fetch FONTXFACTOR of FONTID) (if (EQ EXPANSION 'COMPRESSED) then (CONSTANT (QUOTIENT 1.0 GOLDEN.RATIO)) else GOLDEN.RATIO] FONTID]) (POSTSCRIPT.HARDCOPYW [LAMBDA (FILE BITMAP SCALEFACTOR REGION Landscape? TITLE) (* ; "Edited 4-Feb-88 13:18 by Matt Heffron") (SPAWN.MOUSE) (* ;  "(SETQ Landscape? T) ;Must be landscape to prevent printer hang??") (LET ((STREAM (OPENPOSTSCRIPTSTREAM FILE (LIST 'DOCUMENT.NAME TITLE 'ROTATION Landscape? 'IMAGESIZEFACTOR SCALEFACTOR))) SCLIP W H SCALE) [SETQ W (fetch (REGION WIDTH) of (SETQ SCLIP (DSPCLIPPINGREGION NIL STREAM] (SETQ H (fetch (REGION HEIGHT) of SCLIP)) [if REGION then (SETQ REGION (COPY REGION)) (* ; "In case we need to change it.") [if (< (BITMAPWIDTH BITMAP) (+ (fetch (REGION LEFT) of REGION) (fetch (REGION WIDTH) of REGION))) then (replace (REGION WIDTH) of REGION with (- (BITMAPWIDTH BITMAP) (fetch (REGION LEFT) of REGION] [if (< (BITMAPHEIGHT BITMAP) (+ (fetch (REGION BOTTOM) of REGION) (fetch (REGION HEIGHT) of REGION))) then (replace (REGION HEIGHT) of REGION with (- (BITMAPHEIGHT BITMAP) (fetch (REGION BOTTOM) of REGION] else (SETQ REGION (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (BITMAPWIDTH BITMAP) HEIGHT _ (BITMAPHEIGHT BITMAP] (SETQ SCALE (TIMES POSTSCRIPT.BITMAP.SCALE (DSPSCALE NIL STREAM))) (BITBLT BITMAP (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) STREAM (QUOTIENT (DIFFERENCE W (TIMES SCALE (fetch (REGION WIDTH) of REGION))) 2) (QUOTIENT (DIFFERENCE H (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.INIT [LAMBDA NIL (* ; "Edited 29-Mar-89 11:21 by snow") [MAPC [CL:REMOVE-DUPLICATES (NCONC (for FD in FONTDEFS join (for FP in (CDR (ASSOC 'FONTPROFILE (CDR FD))) collect (CAR FP))) '(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 'FONTCLASS) then (SETQ COPYFD (OR (fetch (FONTCLASS PRESSFD) of CLASS) (fetch (FONTCLASS INTERPRESSFD) of CLASS) (fetch (FONTCLASS DISPLAYFD) of CLASS))) (if (SETQ OLDPSCFD (ASSOC '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 'POSTSCRIPT (if (LISTP COPYFD) then COPYFD else (FONTUNPARSE COPYFD] (SETQ \POSTSCRIPTIMAGEOPS (create IMAGEOPS IMAGETYPE _ '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) IMNEWPAGE _ (FUNCTION \NEWPAGE.PSC) IMSCALE _ (FUNCTION \DSPSCALE.PSC) IMTERPRI _ (FUNCTION \TERPRI.PSC) IMTOPMARGIN _ (FUNCTION \DSPTOPMARGIN.PSC) IMBOTTOMMARGIN _ (FUNCTION \DSPBOTTOMMARGIN.PSC) IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.PSC) IMFONTCREATE _ '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) IMSCALEDBITBLT _ (FUNCTION \BITBLT.PSC]) (POSTSCRIPT.OUTSTR [LAMBDA (STREAM STRING) (* ; "Edited 13-Apr-88 16:33 by Matt Heffron") (if (OR (LITATOM STRING) (STRINGP STRING) (AND (ZEROP STRING) (SETQ STRING "0.0"))) then [for CI from 1 to (NCHARS STRING) do (BOUT STREAM (LOGAND 255 (NTHCHARCODE STRING CI] else (for CC in (CHCON STRING) do (BOUT STREAM (LOGAND 255 CC]) (POSTSCRIPT.PUTBITMAPBYTES [LAMBDA (STREAM BITMAP DELIMFLG) (DECLARE (GLOBALVARS PS.BITMAPARRAY) (LOCALVARS . T)) (* ; "Edited 27-Jan-89 11:16 by Matt Heffron") (LET ((BMBASE (fetch BITMAPBASE of BITMAP)) (BYTESPERROW (LRSH (IPLUS (fetch BITMAPWIDTH of BITMAP) 7) 3)) (BYTEOFFSETPERROW (LSH (fetch BITMAPRASTERWIDTH of BITMAP) 1)) (HEIGHT (fetch BITMAPHEIGHT of BITMAP)) (POS 0) (BYTE) (PS.BITMAPARRAYBASE (fetch (ARRAYP BASE) of PS.BITMAPARRAY))) (* ;; "PS.BITMAPARRAY code speedup by Will Snow @ Envos") (if DELIMFLG then (POSTSCRIPT.OUTSTR STREAM " < ")) (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 (if (IGEQ POS 254) then (\BUFFERED.BOUT STREAM (CHARCODE EOL)) (SETQ POS 0)) (SETQ BYTE (\GETBASEBYTE BMBASE BYTEOFFSET)) [\BUFFERED.BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 (LRSH BYTE 4] (\BUFFERED.BOUT STREAM (\GETBASEBYTE PS.BITMAPARRAYBASE (LOGAND 15 BYTE))) (SETQ POS (IPLUS POS 2))) (\BUFFERED.BOUT STREAM (CHARCODE EOL)) (SETQ POS 0)) (if DELIMFLG then (POSTSCRIPT.OUTSTR STREAM "> "]) (POSTSCRIPT.PUTCOMMAND [LAMBDA S.STRS (* ; "Edited 12-Jan-88 13:01 by Matt Heffron") (LET ((STREAM (ARG S.STRS 1))) (POSTSCRIPT.SHOWACCUM STREAM) (for STR# from 2 to S.STRS do (POSTSCRIPT.OUTSTR STREAM (ARG S.STRS STR# ]) (POSTSCRIPT.SHOWACCUM [LAMBDA (STREAM) (* ; "Edited 12-Jan-88 16:06 by Matt Heffron") (if (POSTSCRIPT.CLOSESTRING STREAM) then (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (SPACEFACTOR (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA)) WIDTH) (if (EQP SPACEFACTOR 1) then (POSTSCRIPT.OUTSTR STREAM "show ") else (replace POSTSCRIPTSPACEFACTOR of IMAGEDATA with 1) (SETQ WIDTH (\CHARWIDTH.PSC STREAM (CHARCODE SPACE))) (replace POSTSCRIPTSPACEFACTOR of IMAGEDATA with SPACEFACTOR) (POSTSCRIPT.OUTSTR STREAM (TIMES WIDTH (DIFFERENCE SPACEFACTOR 1)) ) (POSTSCRIPT.OUTSTR STREAM " 0 ") (POSTSCRIPT.OUTSTR STREAM (CHARCODE SPACE)) (POSTSCRIPT.OUTSTR STREAM " 4 -1 roll widthshow "]) (POSTSCRIPT.STARTPAGE [LAMBDA (STREAM) (* ; "Edited 9-Sep-88 10:48 by Matt Heffron") (LET* ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM)) (CLIPREGN (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)) (CFONT (fetch POSTSCRIPTFONT of IMAGEDATA)) LEFT BOTTOM WIDTH HEIGHT) (POSTSCRIPT.PUTCOMMAND STREAM " %%%%BeginPageSetup ") (if (fetch POSTSCRIPTLANDSCAPE of IMAGEDATA) then (POSTSCRIPT.PUTCOMMAND STREAM "xmax ymin translate 90 rotate ") (if (OR (NOT (ZEROP \POSTSCRIPT.SHORTEDGE.SHIFT)) (NOT (ZEROP \POSTSCRIPT.LONGEDGE.SHIFT))) then (POSTSCRIPT.PUTCOMMAND STREAM \POSTSCRIPT.SHORTEDGE.SHIFT " " (MINUS \POSTSCRIPT.LONGEDGE.SHIFT) " translate ")) else (if (AND (ZEROP \POSTSCRIPT.LONGEDGE.SHIFT) (ZEROP \POSTSCRIPT.SHORTEDGE.SHIFT)) then (POSTSCRIPT.PUTCOMMAND STREAM "xmin ymin translate ") else (POSTSCRIPT.PUTCOMMAND STREAM "xmin " \POSTSCRIPT.LONGEDGE.SHIFT " add ymin " \POSTSCRIPT.SHORTEDGE.SHIFT " add translate "))) (POSTSCRIPT.PUTCOMMAND STREAM "0.01 imagesizefactor mul 0.01 imagesizefactor mul scale %%%%EndPageSetup /savepage save def") (* ;; "Since the clipping region is per page in Postscript by virtue of the savepage ..., reset the current clipping region for this page.") (SETQ LEFT (fetch LEFT of CLIPREGN)) (SETQ BOTTOM (fetch BOTTOM of CLIPREGN)) (SETQ WIDTH (fetch (REGION WIDTH) of CLIPREGN)) (SETQ HEIGHT (fetch (REGION HEIGHT) of CLIPREGN)) (POSTSCRIPT.PUTCOMMAND STREAM " newpath " LEFT " " BOTTOM " mto " WIDTH " 0 rlineto 0 " HEIGHT " rlineto " (IMINUS WIDTH) " 0 rlineto closepath clip newpath ") (* ;; "It seems that Lisp depends on the current font being carried over from page to page, so reset it explicitly here.") (replace POSTSCRIPTFONT of IMAGEDATA with NIL) (* ;  "There is no FONT at the beginning of a page.") (if (fetch POSTSCRIPTHEADING of IMAGEDATA) then (* ;; "Here we handle headings. This imitates the INTERPRESS code.") (\DSPFONT.PSC STREAM (fetch POSTSCRIPTHEADINGFONT of IMAGEDATA)) (\DSPRESET.PSC STREAM) (PRIN3 (fetch POSTSCRIPTHEADING of IMAGEDATA) STREAM) (RELMOVETO 7200 0 STREAM) (* ; "Skip an inch before page number") (PRIN3 "Page " STREAM) (PRIN3 (CL:INCF (fetch POSTSCRIPTPAGENUM of IMAGEDATA)) STREAM) (\TERPRI.PSC STREAM) (* ; "Skip 2 lines") (\TERPRI.PSC STREAM) (\DSPFONT.PSC STREAM CFONT) else (\DSPFONT.PSC STREAM CFONT) (\DSPRESET.PSC STREAM]) (POSTSCRIPT.TEDIT [LAMBDA (FILE PFILE) (* ; "Edited 12-Jan-88 13:03 by Matt Heffron") (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 12-Jan-88 13:03 by Matt Heffron") (TEXTTOIMAGEFILE FILE PSCFILE 'POSTSCRIPT FONTS HEADING TABS (if POSTSCRIPT.TEXTFILE.LANDSCAPE then '(ROTATION T) else NIL]) (POSTSCRIPTFILEP [LAMBDA (FILE) (* ; "Edited 4-Apr-88 16:31 by Matt Heffron") (OR (CL:MEMBER (UNPACKFILENAME.STRING FILE 'EXTENSION) '("PS" "PSC") :TEST (FUNCTION STRING-EQUAL)) (CL:UNWIND-PROTECT [PROGN (SETQ FILE (OPENSTREAM FILE 'INPUT)) (AND (EQ (BIN FILE) (CHARCODE %%)) (EQ (BIN FILE) (CHARCODE !] (CLOSEF? FILE))]) (PSCFONT.READFONT [LAMBDA (FONTFILENAME) (* ; "Edited 15-Oct-87 11:10 by Matt Heffron") (LET ((PF (create PSCFONT)) [S (OPENSTREAM FONTFILENAME 'INPUT NIL '((SEQUENTIAL T] FID W) [replace (PSCFONT FID) of PF with (SETQ FID (READ S (FIND-READTABLE "INTERLISP"] (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) PF]) (PSCFONT.SPELLFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 12-Jan-88 13:04 by Matt Heffron") (SETQ FAMILY (OR (CDR (ASSOC FAMILY POSTSCRIPT.FONT.ALIST)) FAMILY)) (bind FULLNAME for PATH in POSTSCRIPTFONTDIRECTORIES thereis [SETQ FULLNAME (INFILEP (CONCAT PATH (\FONTFILENAME FAMILY SIZE FACE '.PSCFONT] finally (RETURN FULLNAME]) (PSCFONT.WRITEFONT [LAMBDA (FONTFILENAME PF) (* ; "Edited 15-Oct-87 11:12 by Matt Heffron") (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) (* ; "Edited 20-Jan-88 17:22 by Matt Heffron") (LET ((IFILE (OPENSTREAM FILE 'INPUT)) (PSCFONT (create PSCFONT)) (FCHAR 1000) (LCHAR 0) (W (ARRAY 256 'SMALLPOSP 0 0)) TOKEN WEIGHT SLOPE CMCOUNT FBBOX) (with PSCFONT PSCFONT (repeatuntil (STRING-EQUAL "FontName" (RSTRING IFILE)) do (READCCODE IFILE)) (repeatwhile (STRING-EQUAL "" (SETQ TOKEN (RSTRING IFILE))) do (READCCODE IFILE)) [if (NOT (AND (BOUNDP 'WeightMenu) (type? MENU WeightMenu))) then (SETQ WeightMenu (create MENU ITEMS _ WeightMenuItems MENUFONT _ (FONTCREATE 'HELVETICA 12] [if (NOT (AND (BOUNDP 'SlopeMenu) (type? MENU SlopeMenu))) then (SETQ SlopeMenu (create MENU ITEMS _ SlopeMenuItems MENUFONT _ (FONTCREATE 'HELVETICA 12] (printout T T "Font WEIGHT for " PSCFONT ": " (SETQ WEIGHT (MENU WeightMenu)) T) (printout T T "Font SLOPE for " PSCFONT ": " (SETQ SLOPE (MENU SlopeMenu)) T) (SETQ FID (LIST TOKEN WEIGHT SLOPE 'REGULAR)) [SETQ IL-FONTID (if (AND (EQ SLOPE 'REGULAR) (EQ WEIGHT 'MEDIUM)) then TOKEN else (POSTSCRIPT.GETFONTID FID WEIGHT SLOPE 'REGULAR] (repeatuntil (STRING-EQUAL "StartCharMetrics" TOKEN) do (SETQ TOKEN (RSTRING IFILE)) (if (STRING-EQUAL "FontBBox" TOKEN) then (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.") (SETQ DESCENT (IABS (CADR FBBOX))) (SETQ ASCENT (CADDDR FBBOX)) else (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)) (if (CL:PLUSP CCODE) then (if (ILESSP CCODE FCHAR) then (SETQ FCHAR CCODE)) (if (IGREATERP CCODE LCHAR) then (SETQ LCHAR CCODE)) (RATOMS 'WX IFILE) (SETA W CCODE (READ IFILE))) (repeatuntil (EQ (CHARCODE EOL) (READCCODE IFILE)) do))) (SETQ FIRSTCHAR FCHAR) (SETQ LASTCHAR LCHAR)) (CLOSEF IFILE) PSCFONT]) (\BITBLT.PSC [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM SCALEFACTOR) (* ; "Edited 29-Mar-89 18:31 by snow") (* ;;  "Added SCALEFACTOR so this can be used by both IMBITBLT and IMSCALEDBITBLT. --was 29-Mar-89") (* ;; "Postscript can only handle OPERATION REPLACE and PAINT. SOURCETYPE = TEXTURE is converted to BLTSHADE before getting here (so the TEXTURE argument can be ignored) (What are the CLIPPEDSOURCELEFT & CLIPPEDSOURCEBOTTOM arguments? They are not documented)") (LET (RGN LEFT BOTTOM TEMPBM (SCALE (DSPSCALE NIL STREAM))) (* ;; "scaledbitblt may pass nil as DESTINATIONLEFT or DESTINATIONBOTTOM, which means print this at the current position.") (SETQ DESTINATIONLEFT (OR DESTINATIONLEFT (DSPXPOSITION NIL STREAM))) (SETQ DESTINATIONBOTTOM (OR DESTINATIONBOTTOM (DSPYPOSITION NIL STREAM))) (SETQ RGN (create REGION LEFT _ (QUOTIENT DESTINATIONLEFT SCALE) BOTTOM _ (QUOTIENT DESTINATIONBOTTOM SCALE) WIDTH _ WIDTH HEIGHT _ HEIGHT)) (if CLIPPINGREGION then (SETQ RGN (INTERSECTREGIONS CLIPPINGREGION RGN)) (SETQ LEFT (TIMES (fetch (REGION LEFT) of RGN) SCALE)) (SETQ BOTTOM (TIMES (fetch (REGION BOTTOM) of RGN) SCALE)) (SETQ WIDTH (fetch (REGION WIDTH) of RGN)) (SETQ HEIGHT (fetch (REGION HEIGHT) of RGN)) else (SETQ LEFT DESTINATIONLEFT) (SETQ BOTTOM DESTINATIONBOTTOM)) (if RGN then (SETQ TEMPBM (BITMAPCREATE WIDTH HEIGHT 1)) (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM TEMPBM 0 0 WIDTH HEIGHT SOURCETYPE 'REPLACE) (SETQ SCALE (TIMES SCALE (OR (AND (BOUNDP 'POSTSCRIPT.BITMAP.SCALE) (NUMBERP POSTSCRIPT.BITMAP.SCALE)) 1) (OR SCALEFACTOR 1))) (POSTSCRIPT.PUTCOMMAND STREAM " /bitbltsave save def " LEFT " " BOTTOM " translate " (TIMES SCALE WIDTH) " " (TIMES SCALE HEIGHT) " scale " WIDTH " " HEIGHT (if (EQ OPERATION 'PAINT) then " true" else " false") " thebitimage ") (POSTSCRIPT.PUTBITMAPBYTES STREAM TEMPBM NIL) (POSTSCRIPT.OUTSTR STREAM " bitbltsave restore ") (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) T else NIL]) (\BLTSHADE.PSC [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 9-Sep-88 10:56 by Matt Heffron") (* ;; "Maybe we should do something with OPERATION") (LET (TEXTUREBM TEXTUREWIDTH LEFT BOTTOM RGN) (if CLIPPINGREGION then (SETQ RGN (INTERSECTREGIONS CLIPPINGREGION (create REGION LEFT _ DESTINATIONLEFT BOTTOM _ DESTINATIONBOTTOM WIDTH _ WIDTH HEIGHT _ HEIGHT))) (SETQ LEFT (fetch (REGION LEFT) of RGN)) (SETQ BOTTOM (fetch (REGION BOTTOM) of RGN)) (SETQ WIDTH (fetch (REGION WIDTH) of RGN)) (SETQ HEIGHT (fetch (REGION HEIGHT) of RGN)) else (SETQ RGN T) (SETQ LEFT DESTINATIONLEFT) (SETQ BOTTOM DESTINATIONBOTTOM)) (if RGN then (POSTSCRIPT.PUTCOMMAND STREAM " 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)) (if TEXTUREBM then (POSTSCRIPT.PUTCOMMAND STREAM "100 100 scale " (QUOTIENT LEFT 100.0) " " (QUOTIENT BOTTOM 100.0) " mto " (SETQ WIDTH (QUOTIENT WIDTH 100.0)) " 0 rlineto 0 " (QUOTIENT HEIGHT 100.0) " rlineto " (MINUS WIDTH) " 0 rlineto closepath ") (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 grestore ") else (POSTSCRIPT.PUTCOMMAND STREAM LEFT " " BOTTOM " mto " WIDTH " 0 rlineto 0 " HEIGHT " rlineto " (MINUS WIDTH) " 0 rlineto closepath eofill grestore ")) (\MOVETO.PSC STREAM DESTINATIONLEFT DESTINATIONBOTTOM) T else NIL]) (\CHARWIDTH.PSC [LAMBDA (STREAM CHARCODE) (* ; "Edited 12-Jan-88 15:54 by Matt Heffron") (* ;; "no NS character set treatment yet") (LET (WID SPACEFACTOR (IMAGEDATA (fetch IMAGEDATA of STREAM))) (SETQ WID (\FGETWIDTH (fetch FONTIMAGEWIDTHS of (fetch POSTSCRIPTFONT of IMAGEDATA)) (LOGAND CHARCODE 255))) (if (AND (EQ CHARCODE (CHARCODE SPACE)) (NOT (EQP (SETQ SPACEFACTOR (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA)) 1))) then (FIXR (TIMES WID SPACEFACTOR)) else WID]) (\DRAWARC.PSC [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* ; "Edited 9-Sep-88 10:59 by Matt Heffron") (LET (WIDTH COLOR) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) elseif (LISTP BRUSH) then (if (NEQ (fetch BRUSHSHAPE of BRUSH) 'ROUND) then (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)) else (* ;  "If FUNCTIONAL BRUSH big trouble!") (printout T T "[In \DRAWARC.PSC: Functional BRUSH not supported.] [Using ROUND 1 point BRUSH]" T) (SETQ WIDTH (DSPSCALE NIL STREAM))) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM " gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;  "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.OUTSTR STREAM "] 0 setdash ") (* ;  "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 grestore")) (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWCIRCLE.PSC [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* ; "Edited 9-Sep-88 10:59 by Matt Heffron") (LET (WIDTH COLOR) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) elseif (LISTP BRUSH) then (if (NEQ (fetch BRUSHSHAPE of BRUSH) 'ROUND) then (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)) else (* ;  "If FUNCTIONAL BRUSH big trouble!") (printout T T "[In \DRAWCIRCLE.PSC: Functional BRUSH not supported.] [Using (ROUND 1) BRUSH]" T) (SETQ WIDTH 1)) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM " gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;  "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.OUTSTR STREAM "] 0 setdash ") (* ;  "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 grestore")) (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWCURVE.PSC [LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 9-Sep-88 10:56 by Matt Heffron") (LET (WIDTH SHAPE COLOR PSPLINE XA YA DXA DYA N PREVX PREVY PREV-DX3 PREV-DY3) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) (SETQ SHAPE 'ROUND) elseif (LISTP BRUSH) then (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) (SETQ COLOR (fetch BRUSHCOLOR of BRUSH)) else (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") (printout T T "[In \DRAWCURVE.PSC: Functional BRUSH not supported.] [Using (ROUND 1) BRUSH]" T) (SETQ WIDTH (DSPSCALE NIL STREAM)) (SETQ SHAPE 'ROUND)) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM " gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.OUTSTR STREAM "] 0 setdash ") (* ;;  "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") ) (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)) " mto ") (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 ")) (POSTSCRIPT.PUTCOMMAND STREAM "stroke grestore")) (\MOVETO.PSC STREAM PREVX PREVY)) NIL]) (\DRAWELLIPSE.PSC [LAMBDA (STREAM CENTERX CENTERY MINORRADIUS MAJORRADIUS ORIENTATION BRUSH DASHING) (* ; "Edited 9-Sep-88 10:59 by Matt Heffron") (LET (WIDTH COLOR) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) elseif (LISTP BRUSH) then (if (NEQ (fetch BRUSHSHAPE of BRUSH) 'ROUND) then (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)) else (* ;  "If FUNCTIONAL BRUSH, big trouble!") (printout T T "[In \DRAWELLIPSE.PSC: Functional BRUSH not supported.] [Using (ROUND 1) BRUSH]" T) (SETQ WIDTH 1)) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM " gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;  "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.OUTSTR STREAM "] 0 setdash ") (* ;  "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 " " MAJORRADIUS " " MINORRADIUS " " ORIENTATION " 0 360 ellipse stroke grestore")) (\MOVETO.PSC STREAM CENTERX CENTERY]) (\DRAWLINE.PSC [LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 22-Feb-89 11:26 by snow") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (if (NOT (NUMBERP WIDTH)) then (* ;; "The WIDTH = NIL should have been handled before here, but just in case!") (SETQ WIDTH (DSPSCALE NIL STREAM))) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM " gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.OUTSTR STREAM "] 0 setdash ") (* ;;  "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") ) (POSTSCRIPT.PUTCOMMAND STREAM WIDTH " setlinewidth 0 setlinecap " X1 " " Y1 " mto " X2 " " Y2 " lineto stroke grestore " X2 " " Y2 " mto ")) (replace POSTSCRIPTX of IMAGEDATA with X2) (replace POSTSCRIPTY of IMAGEDATA with Y2]) (\DRAWPOLYGON.PSC [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING) (* ; "Edited 9-Sep-88 11:00 by Matt Heffron") (LET ((LASTPOINT (CAR (LAST POINTS))) WIDTH SHAPE COLOR) (if (NUMBERP BRUSH) then (SETQ WIDTH BRUSH) (SETQ SHAPE 'ROUND) elseif (LISTP BRUSH) then (SETQ WIDTH (fetch BRUSHSIZE of BRUSH)) (SETQ SHAPE (fetch BRUSHSHAPE of BRUSH)) (SETQ COLOR (fetch BRUSHCOLOR of BRUSH)) else (* ;; "If FUNCTIONAL BRUSH then BIG trouble!") (printout T T "[In \DRAWPOLYGON.PSC: Functional BRUSH not supported.] [Using (ROUND 1) BRUSH]" T) (SETQ WIDTH (DSPSCALE NIL STREAM)) (SETQ SHAPE 'ROUND)) (if (NOT (ZEROP WIDTH)) then (POSTSCRIPT.PUTCOMMAND STREAM " gsave newpath ") (if (FLOATP COLOR) then (POSTSCRIPT.PUTCOMMAND STREAM COLOR " setgray ") (* ;; "COLOR is specified in POSTSCRIPT setgray notation.") ) (if (LISTP DASHING) then (POSTSCRIPT.OUTSTR STREAM " [") (for D in DASHING do (POSTSCRIPT.PUTCOMMAND STREAM (TIMES D WIDTH) " ")) (POSTSCRIPT.OUTSTR STREAM "] 0 setdash ") (* ;  "Since Interlisp DASHING are in terms of BRUSH units, we must multiply by the brush size.") ) (POSTSCRIPT.PUTCOMMAND STREAM (SELECTQ SHAPE (ROUND " 1 setlinecap 1 setlinejoin ") (SQUARE " 2 setlinecap 0 setlinejoin ") " 0 setlinecap 0 setlinejoin ") WIDTH " setlinewidth " (fetch XCOORD of (CAR POINTS)) " " (fetch YCOORD of (CAR POINTS)) " mto ") (for P in (CDR POINTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD of P) " " (fetch YCOORD of P) " lineto ")) (if CLOSED then (POSTSCRIPT.PUTCOMMAND STREAM " closepath")) (POSTSCRIPT.PUTCOMMAND STREAM " stroke grestore")) (\MOVETO.PSC STREAM (fetch XCOORD of LASTPOINT) (fetch YCOORD of LASTPOINT]) (\DSPBOTTOMMARGIN.PSC [LAMBDA (STREAM YPOSITION) (* ; "Edited 12-Jan-88 13:14 by Matt Heffron") (PROG1 (fetch POSTSCRIPTBOTTOMMARGIN of (fetch IMAGEDATA of STREAM)) (if YPOSITION then (replace POSTSCRIPTBOTTOMMARGIN of (fetch IMAGEDATA of STREAM) with YPOSITION)))]) (\DSPCLIPPINGREGION.PSC [LAMBDA (STREAM REGION) (* ; "Edited 12-Jan-88 13:15 by Matt Heffron") (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (CURRGN (fetch POSTSCRIPTCLIPPINGREGION of IMAGEDATA)) (SCALE (fetch POSTSCRIPTSCALE of IMAGEDATA)) (LONGEDGE (TIMES \POSTSCRIPT.LONGEDGE.PTS (QUOTIENT 10000 SCALE))) (SHORTEDGE (TIMES \POSTSCRIPT.SHORTEDGE.PTS (QUOTIENT 10000 SCALE))) RGN WIDTH DEFREGION) (SETQ DEFREGION (if (fetch POSTSCRIPTLANDSCAPE of IMAGEDATA) then (create REGION LEFT _ 0.0 BOTTOM _ 0.0 WIDTH _ LONGEDGE HEIGHT _ SHORTEDGE) else (create REGION LEFT _ 0.0 BOTTOM _ 0.0 WIDTH _ SHORTEDGE HEIGHT _ LONGEDGE))) (if REGION then (SETQ RGN (INTERSECTREGIONS REGION DEFREGION)) (* ;; "If the new clipping region doesn't intersect with the default for the appropriate page orientation, just ignore this and reset to the default.") (if RGN then (replace POSTSCRIPTCLIPPINGREGION of IMAGEDATA with RGN) (SETQ WIDTH (fetch (REGION WIDTH) of RGN)) (POSTSCRIPT.PUTCOMMAND STREAM " initclip newpath " (fetch LEFT of RGN) " " (fetch BOTTOM of RGN) " moveto " WIDTH " 0 rlineto 0 " (fetch (REGION HEIGHT) of RGN) " rlineto " (IMINUS WIDTH) " 0 rlineto closepath clip newpath") else DEFREGION)) CURRGN]) (\DSPFONT.PSC [LAMBDA (STREAM FONT) (* ; "Edited 9-Sep-88 10:57 by Matt Heffron") (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) FONTID) (PROG1 (fetch POSTSCRIPTFONT of IMAGEDATA) [if FONT then (SETQ FONT (SELECTQ (TYPENAME FONT) (FONTDESCRIPTOR FONT) (FONTCLASS (FONTCREATE FONT NIL NIL NIL STREAM)) (SHOULDNT "arg not FONT descriptor or class"))) (if (NEQ (IMAGESTREAMTYPE STREAM) (fetch FONTDEVICE of FONT)) then (SETQ FONT (with FONTDESCRIPTOR FONT (FONTCREATE FONTFAMILY FONTSIZE FONTFACE NIL STREAM] [if (AND FONT (NEQ FONT (fetch POSTSCRIPTFONT of IMAGEDATA))) then (SETQ FONTID (fetch (PSCFONT IL-FONTID) of (fetch ( FONTDESCRIPTOR FONTDEVICESPEC ) of FONT))) (if (LISTP FONTID) then (POSTSCRIPT.PUTCOMMAND STREAM " /" (fetch FONTIDNAME of FONTID) " findfont [" (TIMES (fetch FONTXFACTOR of FONTID) (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) 100) " 0 " (TIMES (fetch FONTOBLIQUEFACTOR of FONTID) (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) 100) " " (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) 100) " 0 0] makefont setfont ") else (POSTSCRIPT.PUTCOMMAND STREAM " /" FONTID " findfont " (TIMES (fetch (FONTDESCRIPTOR FONTSIZE) of FONT) 100) " scalefont setfont ")) (replace POSTSCRIPTFONT of IMAGEDATA with FONT) (\DSPLINEFEED.PSC STREAM (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of FONT])]) (\DSPLEFTMARGIN.PSC [LAMBDA (STREAM XPOSITION) (* ; "Edited 12-Jan-88 13:15 by Matt Heffron") (PROG1 (fetch POSTSCRIPTLEFTMARGIN of (fetch IMAGEDATA of STREAM)) (if XPOSITION then (replace POSTSCRIPTLEFTMARGIN of (fetch IMAGEDATA of STREAM) with XPOSITION)))]) (\DSPLINEFEED.PSC [LAMBDA (STREAM LINELEADING) (* ; "Edited 12-Jan-88 13:16 by Matt Heffron") (PROG1 (fetch POSTSCRIPTLINESPACING of (fetch IMAGEDATA of STREAM)) (if LINELEADING then (replace POSTSCRIPTLINESPACING of (fetch IMAGEDATA of STREAM) with LINELEADING)))]) (\DSPRESET.PSC [LAMBDA (STREAM) (* ; "Edited 9-Sep-88 11:00 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (\MOVETO.PSC STREAM (fetch POSTSCRIPTLEFTMARGIN of IMAGEDATA) (DIFFERENCE (fetch POSTSCRIPTTOPMARGIN of IMAGEDATA) (FONTPROP (fetch POSTSCRIPTFONT of IMAGEDATA) 'ASCENT]) (\DSPRIGHTMARGIN.PSC [LAMBDA (STREAM XPOSITION) (* ; "Edited 12-Jan-88 13:16 by Matt Heffron") (PROG1 (fetch POSTSCRIPTRIGHTMARGIN of (fetch IMAGEDATA of STREAM)) (if XPOSITION then (replace POSTSCRIPTRIGHTMARGIN of (fetch IMAGEDATA of STREAM) with XPOSITION)))]) (\DSPSCALE.PSC [LAMBDA (STREAM SCALE) (* ; "Edited 28-Sep-87 13:30 by Matt Heffron") (LET* ((IMAGEDATA (fetch IMAGEDATA of STREAM)) (OSCALE (fetch POSTSCRIPTSCALE of IMAGEDATA)) NSCALE) (if (AND NIL (* ;; "Changing SCALE is not implemented. According to IRM.") (NUMBERP SCALE) (CL:PLUSP SCALE)) then (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") (replace POSTSCRIPTSCALE of IMAGEDATA with SCALE)) OSCALE]) (\DSPSPACEFACTOR.PSC [LAMBDA (STREAM FACTOR) (* ; "Edited 12-Jan-88 13:49 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (PROG1 (fetch POSTSCRIPTSPACEFACTOR of IMAGEDATA) (if FACTOR then (POSTSCRIPT.SHOWACCUM STREAM) (replace POSTSCRIPTSPACEFACTOR of IMAGEDATA with FACTOR)))]) (\DSPTOPMARGIN.PSC [LAMBDA (STREAM YPOSITION) (* ; "Edited 12-Jan-88 13:17 by Matt Heffron") (PROG1 (fetch POSTSCRIPTTOPMARGIN of (fetch IMAGEDATA of STREAM)) (if YPOSITION then (replace POSTSCRIPTTOPMARGIN of (fetch IMAGEDATA of STREAM) with YPOSITION)))]) (\DSPXPOSITION.PSC [LAMBDA (STREAM XPOSITION) (* ; "Edited 9-Sep-88 10:58 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)) OLDX) (PROG1 (SETQ OLDX (fetch POSTSCRIPTX of IMAGEDATA)) (if (AND XPOSITION (NOT (EQUAL XPOSITION OLDX))) then (\MOVETO.PSC STREAM XPOSITION (fetch POSTSCRIPTY of IMAGEDATA)) ))]) (\DSPYPOSITION.PSC [LAMBDA (STREAM YPOSITION) (* ; "Edited 9-Sep-88 10:58 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM)) OLDY) (PROG1 (SETQ OLDY (fetch POSTSCRIPTY of IMAGEDATA)) (if (AND YPOSITION (NOT (EQUAL YPOSITION OLDY))) then (\MOVETO.PSC STREAM (fetch POSTSCRIPTX of IMAGEDATA) YPOSITION)))]) (\FILLCIRCLE.PSC [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE) (* ; "Edited 9-Sep-88 11:00 by Matt Heffron") (LET (TEXTUREBM TEXTUREWIDTH) (POSTSCRIPT.PUTCOMMAND STREAM " 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 ") (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 grestore ") else (POSTSCRIPT.PUTCOMMAND STREAM " eofill grestore ")) (\MOVETO.PSC STREAM CENTERX CENTERY]) (\FILLPOLYGON.PSC [LAMBDA (STREAM KNOTS TEXTURE OPERATION WINDNUMBER) (* ; "Edited 9-Sep-88 11:01 by Matt Heffron") (DECLARE (SPECVARS FILL.WRULE)) (* ;; "OPERATION is ignored here") (LET ((LASTPOINT (CAR (LAST KNOTS))) TEXTUREBM TEXTUREWIDTH) (POSTSCRIPT.PUTCOMMAND STREAM " 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 XCOORD of (CAR KNOTS)) " " (fetch YCOORD of (CAR KNOTS)) " mto ") (for K in (CDR KNOTS) do (POSTSCRIPT.PUTCOMMAND STREAM (fetch XCOORD of K) " " (fetch YCOORD of K) " lineto ")) (POSTSCRIPT.PUTCOMMAND STREAM " closepath ") (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 grestore " else " eofill grestore ")) (\MOVETO.PSC STREAM (fetch XCOORD of LASTPOINT) (fetch YCOORD of LASTPOINT]) (\MOVETO.PSC [LAMBDA (STREAM X Y) (* ; "Edited 12-Jan-88 13:18 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (POSTSCRIPT.PUTCOMMAND STREAM " " X " " Y " mto ") (with \POSTSCRIPTDATA IMAGEDATA (SETQ POSTSCRIPTX X) (SETQ POSTSCRIPTY Y]) (\NEWPAGE.PSC [LAMBDA (STREAM) (* ; "Edited 20-Jan-88 17:36 by Matt Heffron") (POSTSCRIPT.PUTCOMMAND STREAM " savepage restore showpage") (POSTSCRIPT.STARTPAGE STREAM]) (\POSTSCRIPT.OUTCHARFN [LAMBDA (STREAM CHAR) (* ; "Edited 9-Sep-88 11:02 by Matt Heffron") (LET* ((POSTSCRIPTDATA (fetch IMAGEDATA of STREAM))) (SELCHARQ CHAR ((CR LF TENEXEOL) (\TERPRI.PSC STREAM)) (FF (\NEWPAGE.PSC STREAM)) (PROGN (if (NOT (fetch POSTSCRIPTCHARSTOSHOW of POSTSCRIPTDATA)) then (POSTSCRIPT.OUTSTR STREAM " (") (replace POSTSCRIPTCHARSTOSHOW of POSTSCRIPTDATA with T)) (\POSTSCRIPT.PUTCHAR STREAM CHAR]) (\POSTSCRIPT.PUTCHAR [LAMBDA (STREAM CHAR) (* ; "Edited 5-Feb-88 10:29 by Matt Heffron") (LET* ((POSTSCRIPTDATA (fetch IMAGEDATA of STREAM)) (FONT (fetch POSTSCRIPTFONT of POSTSCRIPTDATA)) TEMP) (SETQ CHAR (LOGAND CHAR 255)) (* ;  "no NS character set treatment yet") (if (EQ CHAR (CHARCODE TAB)) then (RPTQ 8 (\POSTSCRIPT.PUTCHAR STREAM (CHARCODE SPACE))) (* ; "wimpy, but no better way yet.") else (if (FMEMB CHAR (CHARCODE (%( %) \))) then (BOUT STREAM (CHARCODE \)) (BOUT STREAM CHAR) elseif (NOT (<= (CHARCODE SPACE) CHAR 126)) then (BOUT STREAM (CHARCODE \)) (SETQ TEMP (CHCON (OCTALSTRING CHAR))) (if (< (LENGTH TEMP) 3) then (SETQ TEMP (APPEND [if (CDR TEMP) then (CONSTANT (CHARCODE (0))) else (CONSTANT (CHARCODE (0 0] TEMP))) (for CC in TEMP do (BOUT STREAM CC)) else (BOUT STREAM CHAR)) (add (fetch POSTSCRIPTX of POSTSCRIPTDATA) (\FGETWIDTH (fetch FONTIMAGEWIDTHS of FONT) CHAR))) CHAR]) (\STRINGWIDTH.PSC [LAMBDA (STREAM STR RDTBL) (* DECLARATIONS%: INTEGER) (* ;  "Edited 12-Jan-88 13:27 by Matt Heffron") (LET* [(FNT (DSPFONT NIL STREAM)) (SPACEFACTOR (fetch POSTSCRIPTSPACEFACTOR of (fetch (STREAM IMAGEDATA) of STREAM))) (WA (fetch (PSCFONT WIDTHS) of (fetch (FONTDESCRIPTOR FONTDEVICESPEC) of FNT))) (W (for CI from 1 to (NCHARS STR) sum (LET* ((CC (LOGAND 255 (NTHCHARCODE STR CI NIL RDTBL))) (WID (ELT WA CC))) (if (EQ CC (CHARCODE SPACE)) then (TIMES WID SPACEFACTOR) else WID] (FIXR (TIMES W (fetch (FONTDESCRIPTOR FONTSIZE) of FNT) 0.1]) (\TERPRI.PSC [LAMBDA (STREAM) (* ; "Edited 9-Sep-88 11:02 by Matt Heffron") (LET ((IMAGEDATA (fetch IMAGEDATA of STREAM))) (with \POSTSCRIPTDATA IMAGEDATA (SETQ POSTSCRIPTX POSTSCRIPTLEFTMARGIN) (SETQ POSTSCRIPTY (IPLUS POSTSCRIPTY POSTSCRIPTLINESPACING)) (* ;; "IPLUS because POSTSCRIPTLINESPACING is -ve if correct.") (if (LESSP POSTSCRIPTY (IPLUS (fetch (FONTDESCRIPTOR \SFDescent) of POSTSCRIPTFONT ) POSTSCRIPTBOTTOMMARGIN)) then (\NEWPAGE.PSC STREAM) else (\MOVETO.PSC STREAM POSTSCRIPTX POSTSCRIPTY]) (\DSPROTATE.PSC [LAMBDA (STREAM ROTATION) (* ; "Edited 22-Feb-89 13:47 by snow") (* ;; "rotate the postscript stream by ROTATION") (* ;; "we only know 90 degrees of rotation for now.") (LET ((IMAGEDATA (fetch (STREAM IMAGEDATA) of STREAM))) (replace POSTSCRIPTLANDSCAPE of IMAGEDATA with (IF (EQ ROTATION 0) THEN NIL ELSE T)) (\NEWPAGE.PSC STREAM)) 1]) (\DSPTRANSLATE.PSC [LAMBDA (STREAM TX TY) (* ; "Edited 22-Feb-89 11:40 by snow") (* ;; "the translation happens automatically when we do a rotate. This isn't really a translate function, but it works for the simple rotate by 90 case that occurs most often.") 1]) (\DRAWPOINT.PSC [LAMBDA (STREAM X Y BRUSH OPERATION) (* ; "Edited 22-Feb-89 15:24 by snow") (* ;; "draw a point on the stream ") (IF (BITMAPP BRUSH) THEN (LET ((WIDTH (BITMAPWIDTH BRUSH)) (HEIGHT (BITMAPHEIGHT 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]) ) (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 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 ("/s /show load def" "/mto /moveto load def" "/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 } bind def" "/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" " } bind def" "/resmatrix matrix def" "/findresolution" " {72 0 resmatrix defaultmatrix dtransform" " /yres exch def /xres exch def" " xres dup mul yres dup mul add sqrt" " } bind def" "/thebitimage" " {/maskp exch def" " /bihgt exch def" " /biwid exch def" " /strbuf biwid 8 div ceiling cvi string def" " {1 exch sub} currenttransfer concatprocs settransfer" " biwid bihgt" " maskp { false } { 1 } ifelse" " [biwid 0 0 bihgt 0 0]" " { currentfile strbuf readhexstring pop }" " maskp { imagemask } { image } ifelse" " } bind def" "/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" " } bind def" "/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" " } bind def" "end" "/bitpatternspotfunction" " {setpatterndict begin" " /y exch def /x exch def" " /xindex x 1 add 2 div bpside mul cvi def" " /yindex y 1 add 2 div bpside mul cvi def" " xindex yindex bitison" " {/onbits onbits 1 add def 1}" " {/offbits offbits 1 add def 0} ifelse" " end" " } bind def" "/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" " } bind def" "%%%%EndProlog" "%%%%BeginSetup" "clippath pathbbox" "/ymax exch def /xmax exch def /ymin exch def /xmin exch def")) (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"))) (DECLARE%: EVAL@COMPILE (RPAQQ GOLDEN.RATIO 1.618034) (CONSTANTS (GOLDEN.RATIO 1.618034)) ) (RPAQ? POSTSCRIPT.BITMAP.SCALE 1) (RPAQ? POSTSCRIPT.IMAGESIZEFACTOR 1.0) (RPAQ? POSTSCRIPT.PREFER.LANDSCAPE NIL) (RPAQ? POSTSCRIPT.TEXTFILE.LANDSCAPE NIL) (RPAQ? POSTSCRIPT.TEXTURE.SCALE 4) (RPAQ? POSTSCRIPTFONTDIRECTORIES '("{DSK}FONTS>PSC>")) (RPAQ? \POSTSCRIPT.LONGEDGE.SHIFT 0) (RPAQ? \POSTSCRIPT.SHORTEDGE.SHIFT 0) (RPAQ? \POSTSCRIPT.LONGEDGE.PTS (+ (TIMES 72 10.92) \POSTSCRIPT.SHORTEDGE.SHIFT)) (RPAQ? \POSTSCRIPT.SHORTEDGE.PTS (+ (TIMES 72 8.0) \POSTSCRIPT.LONGEDGE.SHIFT)) (RPAQ? \POSTSCRIPT.MAX.WILD.FONTSIZE 72) (ADDTOVAR POSTSCRIPT.FONT.ALIST (HELVETICA . HELVETICA) (TIMESROMAN . TIMES) (TIMESROMAND . TIMES) (COURIER . COURIER) (GACHA . COURIER) (CLASSIC . TIMES) (MODERN . HELVETICA) (CREAM . HELVETICA) (TERMINAL . COURIER) (LOGO . HELVETICA)) (ADDTOVAR PRINTERTYPES ((POSTSCRIPT) (CANPRINT (POSTSCRIPT)) (STATUS TRUE) (PROPERTIES NILL) (SEND POSTSCRIPT.SEND) (BITMAPSCALE POSTSCRIPT.BITMAPSCALE) (BITMAPFILE (POSTSCRIPT.HARDCOPYW FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) (ADDTOVAR PRINTFILETYPES (POSTSCRIPT (TEST POSTSCRIPTFILEP) (EXTENSION (PS PSC)) (CONVERSION (TEXT POSTSCRIPT.TEXT TEDIT POSTSCRIPT.TEDIT)))) (ADDTOVAR IMAGESTREAMTYPES (POSTSCRIPT (OPENSTREAM OPENPOSTSCRIPTSTREAM) (FONTCREATE POSTSCRIPT.FONTCREATE) (FONTSAVAILABLE POSTSCRIPT.FONTSAVAILABLE) (CREATECHARSET NILL))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTPRINTINGHOST POSTSCRIPT.BITMAP.SCALE POSTSCRIPT.FONT.ALIST POSTSCRIPT.PREFER.LANDSCAPE POSTSCRIPT.TEXTFILE.LANDSCAPE POSTSCRIPT.TEXTURE.SCALE POSTSCRIPTFONTDIRECTORIES \POSTSCRIPT.JOB.SETUP \POSTSCRIPT.LONGEDGE.PTS \POSTSCRIPT.LONGEDGE.SHIFT \POSTSCRIPT.MAX.WILD.FONTSIZE \POSTSCRIPT.ORIENTATION.MENU \POSTSCRIPT.SHORTEDGE.PTS \POSTSCRIPT.SHORTEDGE.SHIFT \POSTSCRIPTIMAGEOPS) ) (FILESLOAD PS-SEND) (POSTSCRIPT.INIT) (PUTPROPS POSTSCRIPT FILETYPE :TCOMPL) (PUTPROPS POSTSCRIPT MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA POSTSCRIPT.PUTCOMMAND) ) (PUTPROPS POSTSCRIPT COPYRIGHT ("Beckman Instruments, Inc" 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9155 101635 (CLOSEPOSTSCRIPTSTREAM 9165 . 9380) (OPENPOSTSCRIPTSTREAM 9382 . 14794) ( POSTSCRIPT.BITMAPSCALE 14796 . 17008) (POSTSCRIPT.CLOSESTRING 17010 . 17459) (POSTSCRIPT.FONTCREATE 17461 . 25278) (POSTSCRIPT.FONTSAVAILABLE 25280 . 29046) (POSTSCRIPT.GETFONTID 29048 . 30328) ( POSTSCRIPT.HARDCOPYW 30330 . 33031) (POSTSCRIPT.INIT 33033 . 38121) (POSTSCRIPT.OUTSTR 38123 . 38620) (POSTSCRIPT.PUTBITMAPBYTES 38622 . 40679) (POSTSCRIPT.PUTCOMMAND 40681 . 41085) (POSTSCRIPT.SHOWACCUM 41087 . 42341) (POSTSCRIPT.STARTPAGE 42343 . 45870) (POSTSCRIPT.TEDIT 45872 . 46132) (POSTSCRIPT.TEXT 46134 . 46609) (POSTSCRIPTFILEP 46611 . 47160) (PSCFONT.READFONT 47162 . 48234) (PSCFONT.SPELLFILE 48236 . 48663) (PSCFONT.WRITEFONT 48665 . 49497) (READ-AFM-FILE 49499 . 53395) (\BITBLT.PSC 53397 . 56573) (\BLTSHADE.PSC 56575 . 61298) (\CHARWIDTH.PSC 61300 . 62051) (\DRAWARC.PSC 62053 . 64572) ( \DRAWCIRCLE.PSC 64574 . 66993) (\DRAWCURVE.PSC 66995 . 70820) (\DRAWELLIPSE.PSC 70822 . 73341) ( \DRAWLINE.PSC 73343 . 75058) (\DRAWPOLYGON.PSC 75060 . 78208) (\DSPBOTTOMMARGIN.PSC 78210 . 78603) ( \DSPCLIPPINGREGION.PSC 78605 . 80921) (\DSPFONT.PSC 80923 . 84170) (\DSPLEFTMARGIN.PSC 84172 . 84559) (\DSPLINEFEED.PSC 84561 . 84952) (\DSPRESET.PSC 84954 . 85413) (\DSPRIGHTMARGIN.PSC 85415 . 85805) ( \DSPSCALE.PSC 85807 . 86661) (\DSPSPACEFACTOR.PSC 86663 . 87102) (\DSPTOPMARGIN.PSC 87104 . 87488) ( \DSPXPOSITION.PSC 87490 . 87953) (\DSPYPOSITION.PSC 87955 . 88430) (\FILLCIRCLE.PSC 88432 . 91049) ( \FILLPOLYGON.PSC 91051 . 94736) (\MOVETO.PSC 94738 . 95086) (\NEWPAGE.PSC 95088 . 95318) ( \POSTSCRIPT.OUTCHARFN 95320 . 96082) (\POSTSCRIPT.PUTCHAR 96084 . 98010) (\STRINGWIDTH.PSC 98012 . 99148) (\TERPRI.PSC 99150 . 100132) (\DSPROTATE.PSC 100134 . 100753) (\DSPTRANSLATE.PSC 100755 . 101078) (\DRAWPOINT.PSC 101080 . 101633))))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS b/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS deleted file mode 100644 index accfdb48..00000000 --- a/obsolete/lispusers/POSTSCRIPT-old/POSTSCRIPT.PS +++ /dev/null @@ -1 +0,0 @@ -%!PS-Adobe-2.0 %%Title: POSTSCRIPT.PS %%Creator: PostScript ImageStream Driver by Matt Heffron of Beckman Instruments %%CreationDate: 9-Feb-88 14:19:16 %%For: Matt Heffron %%EndComments /s /show load def /mto /moveto load def /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 } bind def /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 } bind def /resmatrix matrix def /findresolution {72 0 resmatrix defaultmatrix dtransform /yres exch def /xres exch def xres dup mul yres dup mul add sqrt } bind def /thebitimage {/maskp exch def /bihgt exch def /biwid exch def /strbuf biwid 8 div ceiling cvi string def {1 exch sub} currenttransfer concatprocs settransfer biwid bihgt maskp { false } { 1 } ifelse [biwid 0 0 bihgt 0 0] { currentfile strbuf readhexstring pop } maskp { imagemask } { image } ifelse } bind def /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 } bind def /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 } bind def end /bitpatternspotfunction {setpatterndict begin /y exch def /x exch def /xindex x 1 add 2 div bpside mul cvi def /yindex y 1 add 2 div bpside mul cvi def xindex yindex bitison {/onbits onbits 1 add def 1} {/offbits offbits 1 add def 0} ifelse end } bind def /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 } bind def %%EndProlog %%BeginSetup clippath pathbbox /ymax exch def /xmax exch def /ymin exch def /xmin exch def /imagesizefactor 1.0 def %%EndSetup /Courier findfont 800 scalefont setfont %%BeginPageSetup xmin -5 add ymin 0 add translate 0.01 imagesizefactor mul 0.01 imagesizefactor mul scale %%EndPageSetup /savepage save def newpath 0.0 0.0 mto 57100.0 0 rlineto 0 78624.0 rlineto -57100 0 rlineto closepath clip newpath /Courier findfont 800 scalefont setfont 0 77940 mto initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath 7200 73200 mto /Helvetica findfont 2400 scalefont setfont (XEROX) show 15603 73200 mto /Helvetica findfont 600 scalefont setfont 46410 73200 mto 46410 73200 mto /Helvetica findfont 1000 scalefont setfont (POSTSCRIPT) show 52800 73200 mto 7200 72470 mto gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke grestore 52800 72570 mto 52800 72470 mto 52800 72470 mto 21000 71599 mto gsave newpath 400 setlinewidth 0 setlinecap 21000 71799 mto 38400 71799 lineto stroke grestore 38400 71799 mto 38400 71599 mto 38400 71599 mto 21000 71099 mto gsave newpath 100 setlinewidth 0 setlinecap 21000 71149 mto 38400 71149 lineto stroke grestore 38400 71149 mto 38400 71099 mto 38400 71099 mto 25867 68971 mto /Helvetica-Bold findfont 1200 scalefont setfont (POSTSCRIPT) show 33533 68971 mto 21000 67606 mto gsave newpath 100 setlinewidth 0 setlinecap 21000 67656 mto 38400 67656 lineto stroke grestore 38400 67656 mto 38400 67606 mto 38400 67606 mto 21000 66806 mto gsave newpath 400 setlinewidth 0 setlinecap 21000 67006 mto 38400 67006 lineto stroke grestore 38400 67006 mto 38400 66806 mto 38400 66806 mto 17990 63766 mto /Helvetica findfont 1000 scalefont setfont (By: Matt Heffron \(BEC.HEFFRON@ECLA.USC.EDU\)) show 42009 63766 mto 7200 61105 mto /Helvetica-Bold findfont 1000 scalefont setfont (INTRODUCTION) show 14866 61105 mto /Helvetica findfont 1000 scalefont setfont 14866 61105 mto 7200 58444 mto (The PostScript package defines a set of imageops for printers which understand the PostScript page) 81.00001 0 32 4 -1 roll widthshow 52800 58444 mto 7200 56883 mto (description language by Adobe. At Beckman we have successfully used TEdit, Sketch, and) 390.76923 0 32 4 -1 roll widthshow 52799 56883 mto 7200 55322 mto (HARDCOPYW to an Apple LaserWriter and an AST TurboLaser PS. \(Actually, the PostScript) 322.7692 0 32 4 -1 roll widthshow 52799 55322 mto 7200 53761 mto (imagestream output was directed to a file, which was then moved to a PC which actually) 438.93338 0 32 4 -1 roll widthshow 52799 53761 mto 7200 52200 mto (communicated with the laser printer.\) The PostScript imagestream driver installs itself when it is) 191.0 0 32 4 -1 roll widthshow 52800 52200 mto 7200 50639 mto (loaded. All symbols in the PostScript driver are located in the INTERLISP: package.) show 44438 50639 mto 7200 47978 mto /Helvetica-Bold findfont 1000 scalefont setfont (VARIABLES) show 12978 47978 mto 7200 45317 mto /Helvetica findfont 1000 scalefont setfont (POSTSCRIPT.FONT.ALIST) show 19647 45317 mto /Helvetica findfont 1000 scalefont setfont 47242 45317 mto 47242 45317 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 45317 mto 7200 42656 mto (POSTSCRIPT.FONT.ALIST is an ALIST mapping Xerox Lisp font names intothe root names of) 307.8333 0 32 4 -1 roll widthshow 52799 42656 mto 7200 41095 mto (PostScript font files. It is also used for font family coercions. The default value should be acceptable) 56.833324 0 32 4 -1 roll widthshow 52799 41095 mto 7200 39534 mto (for any of the fonts which are built into the Apple Laserwriter.) show 34046 39534 mto 7200 36873 mto (POSTSCRIPTFONTDIRECTORIES) show 23146 36873 mto /Helvetica findfont 1000 scalefont setfont 47242 36873 mto 47242 36873 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 36873 mto 7200 34212 mto (POSTSCRIPTFONTDIRECTORIES is the list of directories where the PostScript .PSCFONT font files) 58.54545 0 32 4 -1 roll widthshow 52799 34212 mto 7200 32651 mto (can be found. The default value is: \("{DSK}FONTS>PSC>"\).) show 40427 32651 mto 7200 29990 mto (\\POSTSCRIPT.SHORTEDGE.SHIFT) show 23647 29990 mto /Helvetica findfont 1000 scalefont setfont 47242 29990 mto 47242 29990 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 29990 mto 7200 27329 mto (\\POSTSCRIPT.SHORTEDGE.SHIFT is the distance \(in points\) to shift the image perpendicular to the) 67.166664 0 32 4 -1 roll widthshow 52799 27329 mto 7200 25768 mto (short edge of the paper. A positive value gives a shift upward in portrait mode, and to the right in) 140.0 0 32 4 -1 roll widthshow 52800 25768 mto 7200 24207 mto (landscape mode. The default value is: 0.) show 25432 24207 mto 7200 21546 mto (\\POSTSCRIPT.LONGEDGE.SHIFT) show 22981 21546 mto /Helvetica findfont 1000 scalefont setfont 47242 21546 mto 47242 21546 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 21546 mto 7200 18885 mto (\\POSTSCRIPT.LONGEDGE.SHIFT is the corresponding variable for shifts perpendicular to the long) 141.7 0 32 4 -1 roll widthshow 52799 18885 mto 7200 17324 mto (edge of the paper. A positive value here gives a shift to the right in portrait mode and downward in) 101.09999 0 32 4 -1 roll widthshow 52799 17324 mto 7200 15763 mto (landscape mode. The default value is: 0.) show 25432 15763 mto 7200 13102 mto (\\POSTSCRIPT.SHORTEDGE.PTS) show 22703 13102 mto /Helvetica findfont 1000 scalefont setfont 47242 13102 mto 47242 13102 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 13102 mto savepage restore showpage %%BeginPageSetup xmin -5 add ymin 0 add translate 0.01 imagesizefactor mul 0.01 imagesizefactor mul scale %%EndPageSetup /savepage save def newpath 0 0 mto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath /Helvetica findfont 1000 scalefont setfont 0 77684 mto initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath 30322 5021 mto (2) show 30878 5021 mto 7200 73200 mto /Helvetica findfont 2400 scalefont setfont (XEROX) show 15603 73200 mto /Helvetica findfont 600 scalefont setfont 46410 73200 mto 46410 73200 mto /Helvetica findfont 1000 scalefont setfont (POSTSCRIPT) show 52800 73200 mto 7200 72470 mto gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke grestore 52800 72570 mto 52800 72470 mto 52800 72470 mto 7200 71059 mto (\\POSTSCRIPT.SHORTEDGE.PTS indicates the printable region of the page \(in points\) along the short) 16.000013 0 32 4 -1 roll widthshow 52800 71059 mto 7200 69498 mto (edge of the paper. It should be adjusted to allow for any shifts of the image \(see above\). The default) 43.238094 0 32 4 -1 roll widthshow 52799 69498 mto 7200 67937 mto (value is: 576 \(= 8 inches\).) show 18622 67937 mto 7200 65276 mto (\\POSTSCRIPT.LONGEDGE.PTS) show 22037 65276 mto /Helvetica findfont 1000 scalefont setfont 47242 65276 mto 47242 65276 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 65276 mto 7200 62615 mto (\\POSTSCRIPT.LONGEDGE.PTS indicates the printable region of the page \(in points\) along the long) 99.25001 0 32 4 -1 roll widthshow 52800 62615 mto 7200 61054 mto (edge of the paper. It should be adjusted to allow for any shifts of the image \(see above\). The default) 43.238094 0 32 4 -1 roll widthshow 52799 61054 mto 7200 59493 mto (value is: 786.24 \(= 10.92 inches\).) show 21958 59493 mto 7200 56832 mto (\\POSTSCRIPT.MAX.WILD.FONTSIZE) show 24314 56832 mto /Helvetica findfont 1000 scalefont setfont 47242 56832 mto 47242 56832 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 56832 mto 7200 54171 mto (\\POSTSCRIPT.MAX.WILD.FONTSIZE indicates the maximum point size that should be returned from) 64.100006 0 32 4 -1 roll widthshow 52799 54171 mto 7200 52610 mto (FONTSAVAILABLE when the SIZE argument is wild \(i.e. *\). All integer pointsizes from 1 to) 353.80002 0 32 4 -1 roll widthshow 52799 52610 mto 7200 51049 mto (\\POSTSCRIPT.MAX.WILD.FONTSIZE will be indicated as available. The default value is: 72.) show 48659 51049 mto 7200 48388 mto (POSTSCRIPT.PREFER.LANDSCAPE) show 24259 48388 mto /Helvetica findfont 1000 scalefont setfont 47242 48388 mto 47242 48388 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 48388 mto 7200 45727 mto (POSTSCRIPT.PREFER.LANDSCAPE indicates if the OPENIMAGESTREAM method should default) 178.85713 0 32 4 -1 roll widthshow 52799 45727 mto 7200 44166 mto (the orientation of output files to LANDSCAPE. The default value is: NIL.) show 39105 44166 mto 7200 41505 mto (POSTSCRIPT.TEXTFILE.LANDSCAPE) show 24871 41505 mto /Helvetica findfont 1000 scalefont setfont 47242 41505 mto 47242 41505 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 41505 mto 7200 38844 mto (POSTSCRIPT.TEXTFILE.LANDSCAPE indicates if the printing of TEXT files \(e.g. LISTFILES, ...\)) 252.9 0 32 4 -1 roll widthshow 52799 38844 mto 7200 37283 mto (should force the orientation of output files to LANDSCAPE. The default value is: T.) show 43885 37283 mto 7200 34622 mto (POSTSCRIPT.BITMAP.SCALE) show 21148 34622 mto /Helvetica findfont 1000 scalefont setfont 47242 34622 mto 47242 34622 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 34622 mto 7200 31961 mto (POSTSCRIPT.BITMAP.SCALE specifies an independent scale factor for display of bitmap images) 219.40001 0 32 4 -1 roll widthshow 52799 31961 mto 7200 30400 mto (\(e.g. window hardcopies\). Values less than 1 will reduce the image size. \(I.e. a value of 0.5 will give a) 29.049988 0 32 4 -1 roll widthshow 52799 30400 mto 7200 28839 mto (half size bitmap image.\) The position of the scaled bitmap will still have the SAME lower-left corner) 102.999985 0 32 4 -1 roll widthshow 52800 28839 mto 7200 27278 mto (\(i.e. the scaled bitmap is not centered in the region of the full size bitmap image\). The default value is:) 20.600004 0 32 4 -1 roll widthshow 52799 27278 mto 7200 25717 mto (1.) show 8034 25717 mto 28833 23656 mto /Helvetica-Bold findfont 1000 scalefont setfont (HINT) show 31166 23656 mto /Helvetica findfont 1000 scalefont setfont 31166 23656 mto 10800 21595 mto (Setting POSTSCRIPT.BITMAP.SCALE to 0.96, instead of 1, will give cleaner BITMAP) 38.50001 0 32 4 -1 roll widthshow 49200 21595 mto 10800 20034 mto (images on a 300 dpi printer. \(This corrects for the 72 ppi imagestream ) 58.529408 0 32 4 -1 roll widthshow 43076 20034 mto /Helvetica-Oblique findfont 1000 scalefont setfont (vs) 58.529408 0 32 4 -1 roll widthshow 44076 20034 mto /Helvetica findfont 1000 scalefont setfont (. the 75 dpi) 58.529408 0 32 4 -1 roll widthshow 49199 20034 mto 10800 18473 mto (printer, using 4x4 device dots per bitmap pixel.\) Also, values of 0.24, 0.48 and 0.72,) 80.93333 0 32 4 -1 roll widthshow 49199 18473 mto 10800 16912 mto (instead of 0.25, 0.5 and 0.75, will also give cleaner images for reduced size output. In) 23.750011 0 32 4 -1 roll widthshow 49200 16912 mto 10800 15351 mto (general, use integer multiples of 0.24 for a 300 dpi printer.) show 36424 15351 mto 7200 12690 mto (POSTSCRIPT.TEXTURE.SCALE) show 22092 12690 mto /Helvetica findfont 1000 scalefont setfont 47242 12690 mto 47242 12690 mto /Helvetica findfont 1000 scalefont setfont ([InitVariable]) show 52800 12690 mto 7200 10029 mto (POSTSCRIPT.TEXTURE.SCALE specifies an independent scale for the display of bitmap textures.) 174.9 0 32 4 -1 roll widthshow 52799 10029 mto 7200 8468 mto (The value represents the number of device space units per texture unit \(bitmap bit\). The default value) 50.06249 0 32 4 -1 roll widthshow 52800 8468 mto savepage restore showpage %%BeginPageSetup xmin -5 add ymin 0 add translate 0.01 imagesizefactor mul 0.01 imagesizefactor mul scale %%EndPageSetup /savepage save def newpath 0 0 mto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath /Helvetica findfont 1000 scalefont setfont 0 77684 mto initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath 30322 5021 mto (3) show 30878 5021 mto 7200 73200 mto /Helvetica findfont 2400 scalefont setfont (XEROX) show 15603 73200 mto /Helvetica findfont 600 scalefont setfont 46410 73200 mto 46410 73200 mto /Helvetica findfont 1000 scalefont setfont (POSTSCRIPT) show 52800 73200 mto 7200 72470 mto gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke grestore 52800 72570 mto 52800 72470 mto 52800 72470 mto 7200 71059 mto (is 4, which represents each bit of the texture as a 4x4 block, so that textures are approximately the) 115.5 0 32 4 -1 roll widthshow 52800 71059 mto 7200 69498 mto (same resolution as on the screen \(for 300 dpi output devices, such as the Apple Laserwriter\). ) show 48886 69498 mto 7200 66837 mto (The PostScript package extends the allowed representations of a texture, beyond 16-bit FIXP and) 181.15385 0 32 4 -1 roll widthshow 52799 66837 mto 7200 65276 mto (16x16 bitmap, to ANY square bitmap. \(If the bitmap is not square, its longer edge is truncated from the) 4.1052732 0 32 4 -1 roll widthshow 52799 65276 mto 7200 63715 mto (top or right to make it square.\) Use this feature with caution, as large bitmap textures, or sizes other) 71.52632 0 32 4 -1 roll widthshow 52799 63715 mto 7200 62154 mto (than multiples of 16 bits square, require large amounts of storage in the PostScript interpreter \(in the) 81.37499 0 32 4 -1 roll widthshow 52800 62154 mto 7200 60593 mto (printer controller\), and can cause limitcheck errors when actually printing.) show 39544 60593 mto 7200 57932 mto (Anywhere that a texture or color can be used on an imagestream or in the specification of a BRUSH,) 66.166664 0 32 4 -1 roll widthshow 52799 57932 mto 7200 56371 mto (you can instead give a FLOATP between 0.0 and 1.0 \(inclusive\) to represent a PostScript halftone gray) 1.3749862 0 32 4 -1 roll widthshow 52800 56371 mto 7200 54810 mto (shade. \(0.0 is black and 1.0 is white. Specifically, the value sets the brightness of the shade.\) The) 84.45 0 32 4 -1 roll widthshow 52799 54810 mto 7200 53249 mto (value you specify will not be range checked, and will be passed directly through to the PostScript) 178.62498 0 32 4 -1 roll widthshow 52800 53249 mto 7200 51688 mto (setgray operator. \(E.g. you can pass 0.33 as the color to DRAWLINE to get a dark gray line with) 153.36842 0 32 4 -1 roll widthshow 52799 51688 mto 7200 50127 mto (approximately 67% of the pixels in the line black.\)) show 29098 50127 mto 7200 47466 mto /Helvetica-Bold findfont 1000 scalefont setfont (MISCELLANEOUS) show 15867 47466 mto 7200 44805 mto /Helvetica findfont 1000 scalefont setfont (The SCALE of a PostScript imagestream is 100. This is to allow enough resolution in the width) 210.70587 0 32 4 -1 roll widthshow 52799 44805 mto 7200 43244 mto (information for fonts to enable TEdit to correctly fill and justify text.) show 36379 43244 mto 7200 40583 mto (The first time any PostScript imagestream is created \(even if only to hardcopy a bitmap or window\) the) 21.235302 0 32 4 -1 roll widthshow 52799 40583 mto 7200 39022 mto (DEFAULTFONT is instantiated \(unless a FONTS option was given to the OPENIMAGESTREAM, in) 132.16666 0 32 4 -1 roll widthshow 52799 39022 mto 7200 37461 mto (which case the initial font for the imagestream will be set to that font, or to the CAR if a list\).) show 47495 37461 mto 7200 34800 mto (The PostScript imagestream method for FILLPOLYGON uses the global variable FILL.WRULE as the) 62.41665 0 32 4 -1 roll widthshow 52799 34800 mto 7200 33239 mto (default value for the WINDINGNUMBER argument. \(This is the same variable which is used by the) 109.5 0 32 4 -1 roll widthshow 52800 33239 mto 7200 31678 mto (DISPLAY imagestream method for FILLPOLYGON.\)) show 30375 31678 mto 7200 29017 mto (The PostScript imagestream methods for OPENIMAGESTREAM and SEND.FILE.TO.PRINTER) 457.0 0 32 4 -1 roll widthshow 52800 29017 mto 7200 27456 mto (\(OPENPOSTSCRIPTSTREAM and POSTSCRIPT.SEND, respectively\), support an) 1751.4 0 32 4 -1 roll widthshow 52799 27456 mto 7200 25895 mto (IMAGESIZEFACTOR option to change the overall size of the printed image. The) 812.5834 0 32 4 -1 roll widthshow 52799 25895 mto 7200 24334 mto (IMAGESIZEFACTOR re-sizing affects the entire printed output \(specifically, it superimposes its effects) 37.999992 0 32 4 -1 roll widthshow 52800 24334 mto 7200 22773 mto (upon those of POSTSCRIPT.BITMAP.SCALE and POSTSCRIPT.TEXTURE.SCALE\). Values greater) 66.0 0 32 4 -1 roll widthshow 52800 22773 mto 7200 21212 mto (than 1 enlarge the printed image, and values less than 1 reduce it. \(Specifying an) 627.60004 0 32 4 -1 roll widthshow 52799 21212 mto 7200 19651 mto (IMAGESIZEFACTOR of 0 will cause a divide by zero error!\) ) show 34152 19651 mto 7200 16990 mto (The PostScript package is contained in the files: POSTSCRIPT.LCOM & PS-SEND.LCOM, with the) 136.66667 0 32 4 -1 roll widthshow 52799 16990 mto 7200 15429 mto (source in the files: POSTSCRIPT & PS-SEND. The module PS-SEND.LCOM is required and will be) 60.937504 0 32 4 -1 roll widthshow 52800 15429 mto 7200 13868 mto (loaded automatically when POSTSCRIPT.LCOM is loaded. It contains the function which is called by) 57.428555 0 32 4 -1 roll widthshow 52799 13868 mto 7200 12307 mto (SEND.FILE.TO.PRINTER to actually transmit the file to the printer. It is, by its nature, quite site) 213.5625 0 32 4 -1 roll widthshow 52800 12307 mto 7200 10746 mto (specific, so it is in a separate file to make modifying it for any site relatively simple. System record) 118.52633 0 32 4 -1 roll widthshow 52799 10746 mto 7200 9185 mto (declarations required to compile POSTSCRIPT can be found in EXPORTS.ALL. ) show 42826 9185 mto savepage restore showpage %%BeginPageSetup xmin -5 add ymin 0 add translate 0.01 imagesizefactor mul 0.01 imagesizefactor mul scale %%EndPageSetup /savepage save def newpath 0 0 mto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath /Helvetica findfont 1000 scalefont setfont 0 77684 mto initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath 30322 5021 mto (4) show 30878 5021 mto 7200 73200 mto /Helvetica findfont 2400 scalefont setfont (XEROX) show 15603 73200 mto /Helvetica findfont 600 scalefont setfont 46410 73200 mto 46410 73200 mto /Helvetica findfont 1000 scalefont setfont (POSTSCRIPT) show 52800 73200 mto 7200 72470 mto gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke grestore 52800 72570 mto 52800 72470 mto 52800 72470 mto 7200 71059 mto (I'm pretty sure that the output generated by the PostScript imageops fully conforms to the Adobe) 168.06252 0 32 4 -1 roll widthshow 52800 71059 mto 7200 69498 mto (Systems Document Structuring Conventions, Version 2.0, January 31, 1987.) show 40993 69498 mto /Helvetica-Bold findfont 1000 scalefont setfont 40993 69498 mto 7200 66837 mto (Including Other PostScript Operations) show 25426 66837 mto 7200 64176 mto /Helvetica findfont 1000 scalefont setfont (If you wish to insert your own specific PostScript operations into a PostScript imagestream, you can do) 15.499995 0 32 4 -1 roll widthshow 52800 64176 mto 7200 62615 mto (so with either POSTSCRIPT.OUTSTR or POSTSCRIPT.PUTCOMMAND.) show 39816 62615 mto 7200 59954 mto (\(POSTSCRIPT.OUTSTR ) show 18868 59954 mto /Helvetica-Oblique findfont 1000 scalefont setfont (STREAM STRING) show 27091 59954 mto /Helvetica findfont 1000 scalefont setfont (\)) show 27424 59954 mto /Helvetica findfont 1000 scalefont setfont 48409 59954 mto 48409 59954 mto /Helvetica findfont 1000 scalefont setfont ([Function]) show 52800 59954 mto 7200 57293 mto (POSTSCRIPT.OUTSTR outputs a string or value to the imagestream. ) 164.7143 0 32 4 -1 roll widthshow 40247 57293 mto /Helvetica-Oblique findfont 1000 scalefont setfont (STREAM) 164.7143 0 32 4 -1 roll widthshow 44414 57293 mto /Helvetica findfont 1000 scalefont setfont ( must be an open) 164.7143 0 32 4 -1 roll widthshow 52799 57293 mto 7200 55732 mto (PostScript imagestream. ) 77.42856 0 32 4 -1 roll widthshow 18880 55732 mto /Helvetica-Oblique findfont 1000 scalefont setfont (STRING) 77.42856 0 32 4 -1 roll widthshow 22658 55732 mto /Helvetica findfont 1000 scalefont setfont ( is the value to output \(STRINGP and LITATOM are most efficient,) 77.42856 0 32 4 -1 roll widthshow 52799 55732 mto 7200 54171 mto (but any value can be output \(its PRIN1 pname is used\)\).) show 32045 54171 mto 7200 51510 mto (\(POSTSCRIPT.PUTCOMMAND ) show 22034 51510 mto /Helvetica-Oblique findfont 1000 scalefont setfont (STREAM STRING) show 30257 51510 mto 30257 51310 mto (1) show 30813 51510 mto ( ... STRING) show 35981 51510 mto 35981 51310 mto (n) show 36537 51510 mto /Helvetica findfont 1000 scalefont setfont (\)) show 36870 51510 mto /Helvetica findfont 1000 scalefont setfont 43629 51510 mto 43629 51510 mto /Helvetica findfont 1000 scalefont setfont ([NoSpread Function]) show 52800 51510 mto 7200 48649 mto (POSTSCRIPT.PUTCOMMAND is more general for sequences of commands and values. It calls) 238.75 0 32 4 -1 roll widthshow 52800 48649 mto 7200 47088 mto (POSTSCRIPT.OUTSTR repeatedly to output each of the ) show 32600 47088 mto /Helvetica-Oblique findfont 1000 scalefont setfont (STRING) show 36378 47088 mto 36378 46888 mto (i) show 36600 47088 mto /Helvetica findfont 1000 scalefont setfont ( arguments to ) show 42992 47088 mto /Helvetica-Oblique findfont 1000 scalefont setfont (STREAM) show 47159 47088 mto /Helvetica findfont 1000 scalefont setfont (.) show 47437 47088 mto 7200 44227 mto (\(\\POSTSCRIPT.OUTCHARFN ) show 21312 44227 mto /Helvetica-Oblique findfont 1000 scalefont setfont (STREAM CHAR) show 28590 44227 mto /Helvetica findfont 1000 scalefont setfont (\)) show 28923 44227 mto /Helvetica findfont 1000 scalefont setfont 48409 44227 mto 48409 44227 mto /Helvetica findfont 1000 scalefont setfont ([Function]) show 52800 44227 mto 7200 41566 mto (\\POSTSCRIPT.OUTCHARFN is used to output the characters forming the text of a PostScript string) 113.30768 0 32 4 -1 roll widthshow 52799 41566 mto 7200 40005 mto (\(e.g. the argument to a show or charpath operator\). ) 64.06249 0 32 4 -1 roll widthshow 31075 40005 mto /Helvetica-Oblique findfont 1000 scalefont setfont (STREAM) 64.06249 0 32 4 -1 roll widthshow 35242 40005 mto /Helvetica findfont 1000 scalefont setfont ( is the open PostScript imagestream to) 64.06249 0 32 4 -1 roll widthshow 52800 40005 mto 7200 38444 mto (output to, and ) 18.894743 0 32 4 -1 roll widthshow 13650 38444 mto /Helvetica-Oblique findfont 1000 scalefont setfont (CHAR) 18.894743 0 32 4 -1 roll widthshow 16483 38444 mto /Helvetica findfont 1000 scalefont setfont ( is the CHARCODE of the character to output. The ) 18.894743 0 32 4 -1 roll widthshow 39590 38444 mto /Helvetica-Bold findfont 1000 scalefont setfont (/) 18.894743 0 32 4 -1 roll widthshow 39868 38444 mto /Helvetica findfont 1000 scalefont setfont ( \(slash\), ) 18.894743 0 32 4 -1 roll widthshow 43740 38444 mto /Helvetica-Bold findfont 1000 scalefont setfont (\() 18.894743 0 32 4 -1 roll widthshow 44073 38444 mto /Helvetica findfont 1000 scalefont setfont ( and ) 18.894743 0 32 4 -1 roll widthshow 46335 38444 mto /Helvetica-Bold findfont 1000 scalefont setfont (\)) 18.894743 0 32 4 -1 roll widthshow 46668 38444 mto /Helvetica findfont 1000 scalefont setfont ( \(parenthesis\)) 18.894743 0 32 4 -1 roll widthshow 52799 38444 mto 7200 36883 mto (characters will be quoted with) 30.882341 0 32 4 -1 roll widthshow 20439 36883 mto /Helvetica-Bold findfont 1000 scalefont setfont ( /) 30.882341 0 32 4 -1 roll widthshow 21026 36883 mto /Helvetica findfont 1000 scalefont setfont (, and characters with ASCII values less than 32 \(space\) or greater than) 30.882341 0 32 4 -1 roll widthshow 52799 36883 mto 7200 35322 mto (126 \(tilde\) will be output as ) 36.687508 0 32 4 -1 roll widthshow 19593 35322 mto /Helvetica-Bold findfont 1000 scalefont setfont (/nnn) 36.687508 0 32 4 -1 roll widthshow 21704 35322 mto /Helvetica findfont 1000 scalefont setfont ( \(in octal\). \\POSTSCRIPT.OUTCHARFN will output the ) 36.687508 0 32 4 -1 roll widthshow 46836 35322 mto /Helvetica-Bold findfont 1000 scalefont setfont (\() 36.687508 0 32 4 -1 roll widthshow 47169 35322 mto /Helvetica findfont 1000 scalefont setfont ( character to) 36.687508 0 32 4 -1 roll widthshow 52800 35322 mto 7200 33761 mto (open the string if necessary. It is important to use POSTSCRIPT.CLOSESTRING to output the ) 232.07143 0 32 4 -1 roll widthshow 52466 33761 mto /Helvetica-Bold findfont 1000 scalefont setfont (\)) 232.07143 0 32 4 -1 roll widthshow 52799 33761 mto /Helvetica findfont 1000 scalefont setfont 52799 33761 mto 7200 32200 mto (character to close the string, because it also clears the stream state flag that indicates that a string is in) 4.1579 0 32 4 -1 roll widthshow 52799 32200 mto 7200 30639 mto (progress \(otherwise, the next POSTSCRIPT.PUTCOMMAND would output the commands to close the) 2.4166815 0 32 4 -1 roll widthshow 52799 30639 mto 7200 29078 mto (string and show it\).) show 15592 29078 mto 7200 26417 mto /Helvetica-Bold findfont 1000 scalefont setfont (Warning) show 11200 26417 mto 7200 23756 mto /Helvetica findfont 1000 scalefont setfont (Do not attempt to create a PostScript font larger than about 600 points, as much of Interlisp's font) 154.88237 0 32 4 -1 roll widthshow 52799 23756 mto 7200 22195 mto (information is stored in SMALLP integers, and too large a font would overflow the font's height, or the) 56.88234 0 32 4 -1 roll widthshow 52799 22195 mto 7200 20634 mto (width for any of the wider characters. \(I know that 600 points is a rediculously large limit \(about 8.3) 100.78947 0 32 4 -1 roll widthshow 52799 20634 mto 7200 19073 mto (inches\), but I thought I'd better mention it, or someone might try it!\)) show 36658 19073 mto 7200 16412 mto /Helvetica-Bold findfont 1000 scalefont setfont (Known Problems/Limitations) show 20980 16412 mto 7200 13751 mto /Helvetica findfont 1000 scalefont setfont (The output generated for a PostScript imagestream is rather brute force. It isn't particularly careful to) 60.624992 0 32 4 -1 roll widthshow 52800 13751 mto 7200 12190 mto (generate the smallest output file for a given sequence of operations. Specifically, it often generates) 112.533325 0 32 4 -1 roll widthshow 52799 12190 mto 7200 10629 mto (extra end-of-lines between PostScript operator sequences \(this has no effect on the printed output,) 151.23079 0 32 4 -1 roll widthshow 52799 10629 mto 7200 9068 mto (only on the file size\).) show 16315 9068 mto savepage restore showpage %%BeginPageSetup xmin -5 add ymin 0 add translate 0.01 imagesizefactor mul 0.01 imagesizefactor mul scale %%EndPageSetup /savepage save def newpath 0 0 mto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath /Helvetica findfont 1000 scalefont setfont 0 77684 mto initclip newpath 0 0 moveto 57100 0 rlineto 0 78624 rlineto -57100 0 rlineto closepath clip newpath 30322 5021 mto (5) show 30878 5021 mto 7200 73200 mto /Helvetica findfont 2400 scalefont setfont (XEROX) show 15603 73200 mto /Helvetica findfont 600 scalefont setfont 46410 73200 mto 46410 73200 mto /Helvetica findfont 1000 scalefont setfont (POSTSCRIPT) show 52800 73200 mto 7200 72470 mto gsave newpath 200 setlinewidth 0 setlinecap 7200 72570 mto 52800 72570 lineto stroke grestore 52800 72570 mto 52800 72470 mto 52800 72470 mto 7200 71059 mto (Using BITMAPs or Functions as BRUSH arguments to the curve drawing functions is not supported,) 101.142845 0 32 4 -1 roll widthshow 52799 71059 mto 7200 69498 mto (nor is using a non-ROUND BRUSH with DRAWCIRCLE or DRAWELLIPSE.) show 40762 69498 mto 7200 66837 mto (There is no support for NS character sets other than 0, and there is no translation of the character) 134.00002 0 32 4 -1 roll widthshow 52800 66837 mto 7200 65276 mto (code values from NS encoding to PostScript encoding.) show 31378 65276 mto 7200 62615 mto (There is no support for color.) show 19983 62615 mto 7200 59954 mto (\\POSTSCRIPT.OUTCHARFN is pretty wimpy in its handling of TAB characters. It just outputs 8) 228.42859 0 32 4 -1 roll widthshow 52799 59954 mto 7200 58393 mto (SPACEs for the TAB.) show 16704 58393 mto 7200 55732 mto (I haven't yet documented how to build the .PSCFONT files for any new fonts that become available, I'll) 21.000006 0 32 4 -1 roll widthshow 52800 55732 mto 7200 54171 mto (do that eventually.) show 15316 54171 mto savepage restore showpage %%Trailer \ No newline at end of file diff --git a/obsolete/lispusers/POSTSCRIPT-old/PostScript.TEDIT b/obsolete/lispusers/POSTSCRIPT-old/PostScript.TEDIT deleted file mode 100644 index 83a128d2..00000000 --- a/obsolete/lispusers/POSTSCRIPT-old/PostScript.TEDIT +++ /dev/null @@ -1,14 +0,0 @@ -en·vÅos POSTSCRIPT 2 4 1 POSTSCRIPT 1 4 By: Matt Heffron (BEC.HEFFRON@ECLA.USC.EDU) INTRODUCTION The PostScript package defines a set of imageops for printers which understand the PostScript page description language by Adobe. At Beckman we have successfully used TEdit, Sketch, LISTFILES, and HARDCOPYW to an Apple LaserWriter and an AST TurboLaser PS. The PostScript imagestream driver installs itself when it is loaded. All symbols in the PostScript driver are located in the INTERLISP: package. VARIABLES POSTSCRIPT.FONT.ALIST [InitVariable] POSTSCRIPT.FONT.ALIST is an ALIST mapping Xerox Lisp font names into the root names of PostScript font files. It is also used for font family coercions. The default value should be acceptable for any of the fonts which are built into the Apple Laserwriter. POSTSCRIPTFONTDIRECTORIES [InitVariable] POSTSCRIPTFONTDIRECTORIES is the list of directories where the PostScript .PSCFONT font files can be found. The default value is: ("{DSK}FONTS>PSC>"). \POSTSCRIPT.SHORTEDGE.SHIFT [InitVariable] \POSTSCRIPT.SHORTEDGE.SHIFT is the distance (in points) to shift the image perpendicular to the short edge of the paper. A positive value gives a shift upward in portrait mode, and to the right in landscape mode. The default value is: 0. \POSTSCRIPT.LONGEDGE.SHIFT [InitVariable] \POSTSCRIPT.LONGEDGE.SHIFT is the corresponding variable for shifts perpendicular to the long edge of the paper. A positive value here gives a shift to the right in portrait mode and downward in landscape mode. The default value is: 0. \POSTSCRIPT.SHORTEDGE.PTS [InitVariable] \POSTSCRIPT.SHORTEDGE.PTS indicates the printable region of the page (in points) along the short edge of the paper. It should be adjusted to allow for any shifts of the image (see above). The default value is: 576 (= 8 inches). \POSTSCRIPT.LONGEDGE.PTS [InitVariable] \POSTSCRIPT.LONGEDGE.PTS indicates the printable region of the page (in points) along the long edge of the paper. It should be adjusted to allow for any shifts of the image (see above). The default value is: 786.24 (= 10.92 inches). HINT The AST TurboLaser PS has an imageable area on the page which is a different size than that of the Apple LaserWriter. The values of \POSTSCRIPT.SHORTEDGE.PTS and \POSTSCRIPT.LONGEDGE.PTS for the AST are 575.76 and 767.76, respectively. \POSTSCRIPT.MAX.WILD.FONTSIZE [InitVariable] \POSTSCRIPT.MAX.WILD.FONTSIZE indicates the maximum point size that should be returned from FONTSAVAILABLE when the SIZE argument is wild (i.e. *). All integer pointsizes from 1 to \POSTSCRIPT.MAX.WILD.FONTSIZE will be indicated as available. The default value is: 72. POSTSCRIPT.PREFER.LANDSCAPE [InitVariable] POSTSCRIPT.PREFER.LANDSCAPE indicates if the OPENIMAGESTREAM method should default the orientation of output files to LANDSCAPE. It can have one of three values: NIL, T, or ASK. NIL means prefer portrait orientation output, T means prefer landscape, and ASK says to bring up a menu to ask the preferred orientation if it wasn't explicitly indicated in the OPENIMAGESTREAM call (with the ROTATION option). The default value is: NIL. POSTSCRIPT.TEXTFILE.LANDSCAPE [InitVariable] POSTSCRIPT.TEXTFILE.LANDSCAPE indicates if the printing of TEXT files (e.g. LISTFILES, ...) should force the orientation of output files to LANDSCAPE. The default value is: NIL. POSTSCRIPT.BITMAP.SCALE [InitVariable] POSTSCRIPT.BITMAP.SCALE specifies an independent scale factor for display of bitmap images (e.g. window hardcopies). Values less than 1 will reduce the image size. (I.e. a value of 0.5 will give a half size bitmap image.) The position of the scaled bitmap will still have the SAME lower-left corner (i.e. the scaled bitmap is not centered in the region of the full size bitmap image). The default value is: 1. HINT Setting POSTSCRIPT.BITMAP.SCALE to 0.96, instead of 1, will give cleaner BITMAP images on a 300 dpi printer. (This corrects for the 72 ppi imagestream vs. the 75 dpi printer, using 4x4 device dots per bitmap pixel.) Also, values of 0.24, 0.48 and 0.72, instead of 0.25, 0.5 and 0.75, will also give cleaner images for reduced size output. In general, use integer multiples of 0.24 for a 300 dpi printer. POSTSCRIPT.TEXTURE.SCALE [InitVariable] POSTSCRIPT.TEXTURE.SCALE specifies an independent scale for the display of bitmap textures. The value represents the number of device space units per texture unit (bitmap bit). The default value is 4, which represents each bit of the texture as a 4x4 block, so that textures are approximately the same resolution as on the screen (for 300 dpi output devices, such as the Apple Laserwriter). The PostScript package extends the allowed representations of a texture, beyond 16-bit FIXP and 16x16 bitmap, to ANY square bitmap. (If the bitmap is not square, its longer edge is truncated from the top or right to make it square.) Use this feature with caution, as large bitmap textures, or sizes other than multiples of 16 bits square, require large amounts of storage in the PostScript interpreter (in the printer controller), and can cause limitcheck errors when actually printing. Anywhere that a texture or color can be used on an imagestream or in the specification of a BRUSH, you can instead give a FLOATP between 0.0 and 1.0 (inclusive) to represent a PostScript halftone gray shade. (0.0 is black and 1.0 is white. Specifically, the value sets the brightness of the shade.) The value you specify will not be range checked, and will be passed directly through to the PostScript setgray operator. (E.g. you can pass 0.33 as the color to DRAWLINE to get a dark gray line with approximately 67% of the pixels in the line black.) POSTSCRIPT.IMAGESIZEFACTOR [InitVariable] POSTSCRIPT.IMAGESIZEFACTOR specifies an independent factor to change the overall size of the printed image. This re-sizing affects the entire printed output (specifically, it superimposes its effects upon those of POSTSCRIPT.BITMAP.SCALE and POSTSCRIPT.TEXTURE.SCALE). Values greater than 1 enlarge the printed image, and values less than 1 reduce it. An invalid POSTSCRIPT.IMAGESIZEFACTOR (i.e. not a positive, non-zero number) will use a value of 1. The BITMAPSCALE function for the POSTSCRIPT printer type does NOT consider the POSTSCRIPT.IMAGESIZEFACTOR when determining the scale factor for a bitmap. MISCELLANEOUS The SCALE of a PostScript imagestream is 100. This is to allow enough resolution in the width information for fonts to enable TEdit to correctly fill and justify text. The first time any PostScript imagestream is created (even if only to hardcopy a bitmap or window) the DEFAULTFONT is instantiated (unless a FONTS option was given to the OPENIMAGESTREAM, in which case the initial font for the imagestream will be set to that font, or to the CAR if a list). The PostScript imagestream method for FILLPOLYGON uses the global variable FILL.WRULE as the default value for the WINDINGNUMBER argument. (This is the same variable which is used by the DISPLAY imagestream method for FILLPOLYGON.) The PostScript imagestream method for OPENIMAGESTREAM (and, therefore, SEND.FILE.TO.PRINTER), supports an IMAGESIZEFACTOR option to change the size of the printed image. The IMAGESIZEFACTOR re-sizing is combined with the POSTSCRIPT.IMAGESIZEFACTOR to produce an overall re-sizing of the printed image. A HEADING option is also supported to give a running header on each page of output. The value of the HEADING option is printed at the top left of the page, followed by "Page " and the appropriate page number. They are printed in the DEFAULTFONT (unless a FONTS option was given to the OPENIMAGESTREAM, in which case it will be that font, or to the CAR if a list). The PostScript package is contained in the files: POSTSCRIPT.LCOM & PS-SEND.LCOM, with the source in the files: POSTSCRIPT & PS-SEND. The module PS-SEND.LCOM is required and will be loaded automatically when POSTSCRIPT.LCOM is loaded. It contains the function which is called by SEND.FILE.TO.PRINTER to actually transmit the file to the printer. It is, by its nature, quite site specific, so it is in a separate file to make modifying it for any site relatively simple. System record declarations required to compile POSTSCRIPT can be found in EXPORTS.ALL. I'm pretty sure that the output generated by the PostScript imageops fully conforms to the Adobe Systems Document Structuring Conventions, Version 2.0, January 31, 1987. Including Other PostScript Operations If you wish to insert your own specific PostScript operations into a PostScript imagestream, you can do so with the following functions: (POSTSCRIPT.OUTSTR STREAM STRING) [Function] POSTSCRIPT.OUTSTR outputs a string or value to the imagestream. STREAM must be an open PostScript imagestream. STRING is the value to output (STRINGP and LITATOM are most efficient, but any value can be output (its PRIN1 pname is used)). (POSTSCRIPT.PUTCOMMAND STREAM STRING1 ... STRINGn) [NoSpread Function] POSTSCRIPT.PUTCOMMAND is more general for sequences of commands and values. It calls POSTSCRIPT.OUTSTR repeatedly to output each of the STRINGi arguments to STREAM. (\POSTSCRIPT.OUTCHARFN STREAM CHAR) [Function] \POSTSCRIPT.OUTCHARFN is used to output the characters forming the text of a PostScript string (e.g. the argument to a show or charpath operator). STREAM is the open PostScript imagestream to output to, and CHAR is the CHARCODE of the character to output. The / (slash), ( and ) (parenthesis) characters will be quoted with /, and characters with ASCII values less than 32 (space) or greater than 126 (tilde) will be output as /nnn (in octal). \POSTSCRIPT.OUTCHARFN will output the ( character to open the string, if necessary. Use POSTSCRIPT.CLOSESTRING (below) to close the string. (POSTSCRIPT.CLOSESTRING STREAM) [Function] POSTSCRIPT.CLOSESTRING closes a PostScript string (e.g. the argument to a show or charpath operator). STREAM is the open PostScript imagestream. It is important to use POSTSCRIPT.CLOSESTRING to output the ) character to close the string, because it also clears the stream state flag that indicates that a string is in progress (otherwise, the next POSTSCRIPT.PUTCOMMAND would output the commands to close the string and show it). Warning Do not attempt to create a PostScript font larger than about 600 points, as much of Interlisp's font information is stored in SMALLP integers, and too large a font would overflow the font's height, or the width for any of the wider characters. (I know that 600 points is a ridiculously large limit (about 8.3 inches), but I thought I'd better mention it, or someone might try it!) Changes from the Lyric Release The Medley release of this PostScript imagestream driver changed the default value of POSTSCRIPT.TEXTFILE.LANDSCAPE from T to NIL. It also added the support for the HEADING option. Known Problems/Limitations The output generated for a PostScript imagestream is rather brute force. It isn't particularly careful to generate the smallest output file for a given sequence of operations. Specifically, it often generates extra end-of-lines between PostScript operator sequences (this has no effect on the printed output, only on the file size). Using BITMAPs or Functions as BRUSH arguments to the curve drawing functions is not supported, nor is using a non-ROUND BRUSH with DRAWCIRCLE or DRAWELLIPSE. There is no support for NS character sets other than 0, and there is no translation of the character code values from NS encoding to PostScript encoding. There is no support for color. \POSTSCRIPT.OUTCHARFN is pretty wimpy in its handling of TAB characters. It just outputs 8 SPACEs for the TAB. I haven't yet documented how to build the .PSCFONT files for any new fonts that become available, I'll do that eventually.(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (162 48 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (162 48 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (72 732 540 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))))) -5È ÈHÈ -È PAGEHEADING RUNNINGHEAD,66’,È5È È,È ,È,ŠŠ8,ŠŠ8HÈÈ PAGEHEADING RUNNINGHEAD CLASSICCLASSICMODERN -ÿþ HELVETICA -MODERN -MODERN -MODERN MODERN -MODERN -  HRULE.GETFNMODERN -  HRULE.GETFNMODERN -  HRULE.GETFNMODERN -  HRULE.GETFNMODERN   HRULE.GETFNMODERN - • -¤ðîæëí³³˜ýŠé*e©#é¢3©&‰  A*y  ‰  ”62 --f4f gbá~¶Ožšpz.Lâzº \ No newline at end of file diff --git a/obsolete/lispusers/PRESSFROMNS b/obsolete/lispusers/PRESSFROMNS deleted file mode 100644 index 9817f18d..00000000 --- a/obsolete/lispusers/PRESSFROMNS +++ /dev/null @@ -1,1387 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - -(FILECREATED "14-Jul-2025 23:24:28"  -{DSK}kaplan>Local>medley3.5>working-medley>lispusers>PRESSFROMNS.;3 80159 - - :EDIT-BY rmk - - :CHANGES-TO (FNS GETCHARPRESSTRANSLATION PUTCHARPRESSTRANSLATION) - - :PREVIOUS-DATE " 5-Jul-2025 18:52:47" -{DSK}kaplan>Local>medley3.5>working-medley>lispusers>PRESSFROMNS.;2) - - -(PRETTYCOMPRINT PRESSFROMNSCOMS) - -(RPAQQ PRESSFROMNSCOMS - [(* This file uses CONSTANTS defined in PRESS, so it is necessary to LOADFROM PRESS before - changing this file.) - (FNS \SMASHPRESSFONTS) - (FNS GETCHARPRESSTRANSLATION PRESS.NSARRAY PUTCHARPRESSTRANSLATION) - (FNS \DSPFONT.PRESS \DSPSPACEFACTOR.PRESS \ENTITYSTART.PRESS \SETSPACE.PRESS \STARTPAGE.PRESS - \PRESS.COERCEFONT \DSPFONT.PRESSFONT SETUPFONTS.PRESS) - (FNS \CREATEPRESSFONT \CREATECHARSET.PRESS \CREATECHARSETZERO.PRESS) - (FNS \PRESSCURVE2) - (COMS (* Generic utility for coercing fonts, could be used by other devices) - (FNS \COERCEFONT)) - (ALISTS (FONTCOERCIONS PRESS) - (MISSINGFONTCOERCIONS PRESS)) - (GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS) - (FNS \STRINGWIDTH.PRESS \CHARWIDTH.PRESS \OUTCHARFN.PRESS) - (* * new declaration for PRESSDATA) - (DECLARE%: DONTCOPY (RECORDS PRESSDATA)) - (INITRECORDS PRESSDATA) - (* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName) - %, where translationArrayName is bound to a translation array for charset which contains - (fontFamily charcode) - lists) - (FNS \NSTOASCIIARRAY \NSTOASCIITRANSLATION) - (GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES) - [INITVARS (PRESSFONTFAMILIES '((GACHA) - (TIMESROMAN) - (HELVETICA) - (SYMBOL) - (MATH) - (HIPPO) - (CYRILLIC) - (NEWVEC) - (SNEWVEC) - (HNEWVEC) - (VNEWVEC] - (INITVARS (NSTOASCIITRANSLATIONS)) - (ADDVARS (NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY) - (38 ASCIIFROM38ARRAY) - (39 ASCIIFROM39ARRAY) - (239 ASCIIFROM239ARRAY))) - (UGLYVARS ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY) - (P (\SMASHPRESSFONTS)) - (DECLARE%: DONTCOPY (CONSTANTS (unknownCharTranslation '(MATH 59]) - - - -(* This file uses CONSTANTS defined in PRESS, so it is necessary to LOADFROM PRESS before changing -this file.) - -(DEFINEQ - -(\SMASHPRESSFONTS - [LAMBDA NIL (* ; "Edited 29-Feb-88 10:21 by thh:") - - (* ;; "Executed after all patchfns have been loaded, coerces existing Koto press fonts into NS-type press fonts") - - (for F in (FONTSAVAILABLE '* '* '* '* 'PRESS) do (\CREATECHARSET 0 (FONTCREATE F]) -) -(DEFINEQ - -(GETCHARPRESSTRANSLATION - [LAMBDA (CHARCODE FONT) (* ; "Edited 14-Jul-2025 23:23 by rmk") - (* ; "Edited 5-Jul-2025 18:51 by rmk") - (* thh%: "28-Feb-86 12:03") - (* ; - "returns the Press translation for a character in a font") - (COND - ((OR (CHARCODEP CHARCODE) - (EQ CHARCODE 256)) (* ; - "bitmap for char 256 is what gets printed if char not found") - ) - ((OR (STRINGP CHARCODE) - (LITATOM CHARCODE)) - (SETQ CHARCODE (CHCON1 CHARCODE))) - (T (\ILLEGAL.ARG CHARCODE))) - (LET [TR CSINFO (FONTDESC (FONTCOPY FONT NIL NIL NIL 'PRESS] - (* ; - "fetch the csinfo for the character set of this character.") - (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) - FONTDESC)) - (SETQ TR (\GETBASEPTR (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO) - (UNFOLD (\CHAR8CODE CHARCODE) - 2))) (* ; "Return a copy") - (LIST (CAR TR) - (CDR TR]) - -(PRESS.NSARRAY - [LAMBDA (CHARSET FAMILY ASCIIARRAY) (* thh%: "28-Feb-86 12:08") - - (* using info in ASCIIARRAY or ASCIITONSTRANSLATIONS, creates an array of - (pressFont charcode) lists) - - (LET* ((min (TIMES 256 CHARSET)) - (max (PLUS min 255)) - (array (ARRAY 256 NIL NIL 0))) - [for item in (COND - [ASCIIARRAY `((%, FAMILY ASCIIARRAY] - (T ASCIITONSTRANSLATIONS)) bind asciiArray - do - - (* * item is of the form (PressFont TranslationArray NSFont)) - - (SETQ asciiArray (EVAL (CADR item))) - (COND - (asciiArray (for i from 0 to 255 - do (SETA array (REMAINDER (ELT asciiArray i) - 256) - (LIST (CAR item) - i)) - when (AND (LEQ min (ELT asciiArray i)) - (LEQ (ELT asciiArray i) - max] - array]) - -(PUTCHARPRESSTRANSLATION - [LAMBDA (CHARCODE FONT NEWTRANSLATION) (* ; "Edited 14-Jul-2025 23:24 by rmk") - (* ; "Edited 5-Jul-2025 18:51 by rmk") - (* ; "Edited 29-Feb-88 10:28 by thh:") - (* ; - "Changes the Press translation for a character in a font") - (COND - ((CHARCODEP CHARCODE)) - ((OR (STRINGP CHARCODE) - (LITATOM CHARCODE)) - (SETQ CHARCODE (CHCON1 CHARCODE))) - (T (\ILLEGAL.ARG CHARCODE))) - (PROG* ((FONTDESC (FONTCREATE FONT NIL NIL NIL 'PRESS)) - (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) - FONTDESC)) - (CHAR8CODE (\CHAR8CODE CHARCODE)) - (TR (\NSTOASCIITRANSLATION NEWTRANSLATION NIL FONTDESC))) - (UNINTERRUPTABLY - (\RPLPTR (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) - (UNFOLD CHAR8CODE 2) - TR) - (\PUTBASE (ffetch (CHARSETINFO WIDTHS) of CSINFO) - CHAR8CODE - (\FGETCHARWIDTH (CAR TR) - (CDR TR))) - [change (ffetch CHARSETASCENT of CSINFO) - (MAX DATUM (ffetch \SFAscent of (CAR TR] - [change (ffetch CHARSETDESCENT of CSINFO) - (MAX DATUM (ffetch \SFDescent of (CAR TR] - [freplace \SFHeight of FONTDESC with (PLUS (change (ffetch \SFAscent of FONTDESC) - (MAX DATUM (ffetch CHARSETASCENT - of CSINFO))) - (change (ffetch \SFDescent of FONTDESC) - (MAX DATUM (ffetch CHARSETDESCENT - of CSINFO]) - (RETURN NEWTRANSLATION]) -) -(DEFINEQ - -(\DSPFONT.PRESS - [LAMBDA (PRSTREAM FONT) (* rmk%: "25-Feb-86 11:05") - - (* * The DSPFONT method for PRESS-type image streams -- - change the stream's current logical font to FONT; - the device font changes only when we print a character) - - (PROG (OLDFONT FDENTRY (PRDATA (ffetch IMAGEDATA of PRSTREAM))) - (SETQ OLDFONT (ffetch PRLOGICALFONT of PRDATA)) - (COND - ([OR (NULL FONT) - (EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT 'PRESS T) - (FONTCOPY OLDFONT FONT] - (RETURN OLDFONT))) - (freplace PRLOGICALFONT of PRDATA with FONT) - (freplace PRLOGICALCHARSET of PRDATA with NIL) - [\SETSPACE.PRESS PRSTREAM (FIXR (TIMES (ffetch PRSPACEFACTOR of PRDATA) - (\FGETCHARWIDTH FONT (CHARCODE SPACE] - [freplace PRLINEFEED of PRDATA with (IDIFFERENCE (CONSTANT (IMINUS - MicasPerPoint - )) - (FONTPROP FONT 'HEIGHT] - (\FIXLINELENGTH.PRESS PRSTREAM) - (RETURN OLDFONT]) - -(\DSPSPACEFACTOR.PRESS - [LAMBDA (STREAM FACTOR) (* rmk%: "24-Feb-86 09:49") - (LET ((PRDATA (ffetch IMAGEDATA of STREAM))) - (PROG1 (ffetch PRSPACEFACTOR of PRDATA) - (COND - (FACTOR (SHOW.PRESS STREAM) - (freplace PRSPACEFACTOR of PRDATA with FACTOR) - (\SETSPACE.PRESS STREAM (FIXR (TIMES FACTOR - (\FGETCHARWIDTH (ffetch - PRLOGICALFONT - of PRDATA) - (CHARCODE SPACE]) - -(\ENTITYSTART.PRESS - [LAMBDA (PRSTREAM) (* thh%: "10-Dec-86 08:33") - (PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM))) - (freplace PRSPACEWIDTH of PRDATA with NIL) - - (* This really should be the spacewidth of the current font. - But then, if we switch fonts to one whose space*spacefactor comes out the - same, we won't know to put out a setspace command. - So when we actually set up the first font in this entity, we will end up - putting out an explicit setspace (even if the space factor is 1)) - - (freplace PRFONT of PRDATA with NIL) - (freplace PRLOGICALFONT of PRDATA with NIL) - - (* We set the font to NIL, knowing that the current font can be recoverd from - the PRCURRFDE. This font will be set in the press file before the first show, - if no explicit dspfont intervenes. Note, however, that up until the first - dspfont, the widthscache still corresponds to what was the PRLOGICALFONT) - - (freplace DLSTARTBYTE of PRDATA with (\GETFILEPTR PRSTREAM)) - (freplace ELSTARTBYTE of PRDATA with (\GETFILEPTR (fetch ELSTREAM - of PRDATA))) - (freplace STARTCHARBYTE of PRDATA with (\GETFILEPTR PRSTREAM)) - - (* Entity starts with position at 0,0 so must re-establish current position - (?)) - - (SETXY.PRESS PRSTREAM (fetch PRXPOS of PRDATA) - (fetch PRYPOS of PRDATA]) - -(\SETSPACE.PRESS - [LAMBDA (PRSTREAM S) (* rmk%: "31-Mar-86 16:08") - (PROG (ELSTREAM (PRDATA (fetch IMAGEDATA of PRSTREAM))) - (AND (EQ S (ffetch PRSPACEWIDTH of PRDATA)) - (RETURN)) - (SHOW.PRESS PRSTREAM) - (SETQ ELSTREAM (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM))) - (if (ILEQ S 2047) - then (\WOUT ELSTREAM (IPLUS (LLSH SetSpaceXShortCode 8) - S)) - else (\BOUT ELSTREAM SetSpaceXCode) - (\WOUT ELSTREAM S)) - (freplace PRSPACEWIDTH of PRDATA with S]) - -(\STARTPAGE.PRESS - [LAMBDA (PRSTREAM) (* rmk%: "25-Feb-86 11:36") - - (* Should be called only when no previous page is open) - - (PROG (CFONT HFONT SPACEFACTOR (PRDATA (ffetch IMAGEDATA of PRSTREAM))) - (SETQ CFONT (ffetch PRLOGICALFONT of PRDATA)) - - (* Save current font so that \ENTITYSTART.PRESS can make PRLOGICALFONT be - NIL, indicating that there is no actual font at the beginning of a page) - - (\ENTITYSTART.PRESS PRSTREAM) - [COND - ((ffetch PRHEADING of PRDATA) - (SETQ SPACEFACTOR (ffetch PRSPACEFACTOR of PRDATA)) - (freplace PRSPACEFACTOR of PRDATA with 1) - (SETQ HFONT (ffetch PRHEADINGFONT of PRDATA)) - (\DSPFONT.PRESS PRSTREAM HFONT) (* Set up heading font) - [SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA) - (IDIFFERENCE (ffetch PRTOP of PRDATA) - (FONTPROP HFONT 'ASCENT] - (PRIN3 (ffetch PRHEADING of PRDATA) - PRSTREAM) (* Skip an inch before page number) - (SHOW.PRESS PRSTREAM) - (SETX.PRESS PRSTREAM (IPLUS MICASPERINCH (ffetch PRXPOS of PRDATA))) - (PRIN3 "Page " PRSTREAM) - (PRIN3 (add (ffetch PRPAGENUM of PRDATA) - 1) - PRSTREAM) - (NEWLINE.PRESS PRSTREAM) (* Skip 2 lines) - (NEWLINE.PRESS PRSTREAM) - (freplace PRSPACEFACTOR of PRDATA with SPACEFACTOR)) - (T (SETXY.PRESS PRSTREAM (ffetch PRLEFT of PRDATA) - (IDIFFERENCE (ffetch PRTOP of PRDATA) - (FONTPROP CFONT 'ASCENT] - - (* Now we set the font to our (previous) current font) - - (\DSPFONT.PRESS PRSTREAM CFONT]) - -(\PRESS.COERCEFONT - [LAMBDA (FONT FAMILY) (* rmk%: "25-Mar-86 15:44") - - (* coerces FONT to be new FAMILY FAMILY, and caches result on - \PRESS.COERCEDFONTS) - - (DECLARE (GLOBALVARS \PRESS.COERCEDFONTS)) - (COND - [[OR (NOT FAMILY) - (EQ FAMILY (FONTPROP FONT 'FAMILY] - - (* Don't call FONTCOPY if it's the same font. - This avoids circularity thru AVGCHARWIDTH and CHARWIDTH before the font has - been stored in \FONTSINCORE.) - - (COND - ((EQ 'PRESS (FONTPROP FONT 'DEVICE)) (* How could it not be PRESS? Ask - Tad.) - FONT) - (T (FONTCOPY FONT 'DEVICE 'PRESS] - ((OR (FONTP FAMILY) - (LISTP FAMILY)) (* FAMILY is a font specification) - (FONTCOPY FAMILY 'DEVICE 'PRESS)) - [(FONTP (CADR (ASSOC FONT (CDR (ASSOC FAMILY \PRESS.COERCEDFONTS] - (T (LET [(pressFont (OR (FONTCOPY FONT 'FAMILY FAMILY 'DEVICE 'PRESS 'NOERROR T) - (FONTCOPY FONT 'FAMILY FAMILY 'FACE 'STANDARD 'DEVICE 'PRESS] - (push [CDR (OR (ASSOC FAMILY \PRESS.COERCEDFONTS) - (CAR (push \PRESS.COERCEDFONTS (CONS FAMILY] - (LIST FONT pressFont)) - pressFont]) - -(\DSPFONT.PRESSFONT - [LAMBDA (PRSTREAM PRFONT) (* thh%: "16-Jun-86 10:50") - (* Changes the Pressfiles device - font) - (PROG (FDENTRY LFONT OLDFONT (PRDATA (ffetch IMAGEDATA of PRSTREAM))) - (SETQ OLDFONT (ffetch PRFONT of PRDATA)) - (SHOW.PRESS PRSTREAM) - (SETQ FDENTRY (\DEFINEFONT.PRESS PRSTREAM PRFONT)) - (COND - ((NEQ (ffetch FONTSET# of FDENTRY) - (ffetch FONTSET# of (ffetch PRCURRFDE of PRDATA))) - (* Swtich font sets) - - (* must save and restore current logical font since \ENTITYSTART.PRESS makes - it NIL) - - (SETQ LFONT (ffetch PRLOGICALFONT of PRDATA)) - (\ENTITYEND.PRESS PRSTREAM) - (\ENTITYSTART.PRESS PRSTREAM) - (\DSPFONT.PRESS PRSTREAM LFONT))) - (freplace PRCURRFDE of PRDATA with FDENTRY) - (freplace PRFONT of PRDATA with PRFONT) - (\BOUT (ffetch ELSTREAM of PRDATA) - (LOGOR FontCode (ffetch FONT# of FDENTRY))) - (RETURN OLDFONT]) - -(SETUPFONTS.PRESS - [LAMBDA (PRSTREAM FONTS) (* thh%: "10-Dec-86 08:43") - - (* creates fonts in the initial fontset. - and sets heading font. Leaves PRFONT as NIL. - This means that \DSPFONT.PRESS of the heading font will establish that as the - current font when the first page opens.) - - (* since FONTS are logical, not device, fonts, they are not added to the - fontset here) - - (for F FLG inside (OR FONTS DEFAULTFONT) - do (SETQ F (FONTCREATE F NIL NIL NIL 'PRESS)) - (COND - (FLG NIL) - (T (\DSPFONT.PRESS PRSTREAM F) - - (* Install first font as current logical font and heading font.) - - (\ENTITYEND.PRESS PRSTREAM) - (replace PRHEADINGFONT of (fetch IMAGEDATA of PRSTREAM) - with F) - (SETQ FLG T]) -) -(DEFINEQ - -(\CREATEPRESSFONT - [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE) (* ; "Edited 9-Mar-88 15:54 by thh:") - (* ;; "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 PRESSFONTWIDTHSFILES)) - (RESETLST (* ; - "RESETLST to make sure the fontfiles get closed") - (PROG ((FD (create FONTDESCRIPTOR - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ PSIZE - FONTFACE _ FACE - \SFFACECODE _ (\FACECODE FACE) - ROTATION _ ROTATION - FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72)) - \SFHeight _ 0 - \SFAscent _ 0 - \SFDescent _ 0))) - (OR (\GETCHARSETINFO 0 FD T) - (RETURN NIL)) - (RETURN FD]) - -(\CREATECHARSET.PRESS - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC) - (* ; "Edited 9-Mar-88 15:19 by thh:") -(* ;;; "determines widths and translations to print the charset with Press fonts. Note that we get widths from widths of font translated to, which should be original press values because translations are always to press fonts.") -(* ;;; "NOTE: This code makes fonts that translate to themselves circular, and also gives fonts high reference counts. The translations should not be circular.") - - (DECLARE (GLOBALVARS PRESSFONTFAMILIES)) - (PROG ((CSETTRANSLATIONARRAY (\NSTOASCIIARRAY CHARSET)) - CSINFO widths (translationArray (ARRAY 256 NIL NIL 0)) - (ascent 0) - (descent 0) - CSETZEROTRANSLATIONS) - (* ;; "Determine translations for this charset") - - [COND - [(ZEROP CHARSET) - (* ;; "set up charsetinfo -- includes any coercions to known press fonts") - - (SETQ CSINFO (\CREATECHARSETZERO.PRESS FAMILY SIZE FACE ROTATION DEVICE FONTDESC)) - (OR CSINFO (RETURN NIL)) (* ; - "unable to coerce to a press font") - (* ;; "get translations for charset-0") - - (COND - [(SETQ CSETZEROTRANSLATIONS (ASSOC (FONTPROP FONTDESC 'FAMILY) - PRESSFONTFAMILIES)) - (* ; "use identity transformation") - (for i from 0 to 255 do (SETA translationArray i (CONS FONTDESC i)) - ) (* ; - "except for font-specific non-identities") - (for X in (CDR CSETZEROTRANSLATIONS) - do (SETA translationArray (CAR X) - (\NSTOASCIITRANSLATION (CADR X) - FAMILY FONTDESC] - (T - (* ;; "Not a press font: assume NS font which will be translated into a press font") - - (for i from 0 to 255 - do (SETA translationArray i - (\NSTOASCIITRANSLATION - (COND - ((AND CSETTRANSLATIONARRAY (ELT CSETTRANSLATIONARRAY i))) - (T (LIST (OR FAMILY (FONTPROP FONTDESC 'FAMILY)) - i))) - FAMILY FONTDESC] - (T - (* ;; "CHARSET not zero, assume NS codes") - - (for i from 0 to 255 do (SETA translationArray i - (\NSTOASCIITRANSLATION - (AND CSETTRANSLATIONARRAY - (ELT CSETTRANSLATIONARRAY i)) - FAMILY FONTDESC] - (* ;; "Set the widths array and install the translations in the CHARSETINFO") - - (OR CSINFO (SETQ CSINFO (create CHARSETINFO))) - (SETQ widths (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for i from 0 to 255 bind translation pressFont newAscent newDescent - do (SETQ translation (ELT translationArray i)) - (SETQ pressFont (CAR translation)) - [COND - ((AND (ZEROP CHARSET) - (EQ pressFont FONTDESC)) (* ; - "this is charset-0 font translating to itself, use widths already defined") - (\FSETWIDTH widths i (\FGETWIDTH widths (CDR translation))) - (SETQ newAscent (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) - (SETQ newDescent (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) - (T (\FSETWIDTH widths i (\FGETCHARWIDTH pressFont (CDR translation))) - (SETQ newAscent (ffetch (FONTDESCRIPTOR \SFAscent) of pressFont)) - (SETQ newDescent (ffetch (FONTDESCRIPTOR \SFDescent) of pressFont] - (SETQ ascent (MAX ascent newAscent)) - (SETQ descent (MAX descent newDescent))) - (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (ffetch (ARRAYP BASE) - of translationArray) - ) - (replace (CHARSETINFO CHARSETASCENT) of CSINFO with ascent) - (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with descent) - (RETURN CSINFO]) - -(\CREATECHARSETZERO.PRESS - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FD) (* ; "Edited 9-Mar-88 15:27 by thh:") -(* ;;; -"creates CSINFO for charset 0 of press fonts from info in widths file (without translations).") - - (DECLARE (GLOBALVARS PRESSFONTWIDTHSFILES FONTCOERCIONS MISSINGFONTCOERCIONS)) - (RESETLST (* ; - "RESETLST to make sure the fontfiles get closed") - (PROG* (WSTRM STRMCACHE FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHSY WIDTHS - (PRESSMICASIZE (IQUOTIENT (ITIMES SIZE 2540) - 72)) - (NSMICASIZE (FIXR (FQUOTIENT (ITIMES SIZE 2540) - 72))) - (FACECODE (\FACECODE FACE)) - (CSINFO (create CHARSETINFO)) - CHARSETHEIGHT FOO FBBOX) -(* ;;; "Go look for the fonts.widths file that has this font's info in it.") - - (OR [bind XLATEDNAME NEWFAMILY NEWNSMICASIZE NEWFACECODE for F inside - - PRESSFONTWIDTHSFILES - when (INFILEP F) - first (SETQ XLATEDNAME (\COERCEFONT FAMILY SIZE FACE ROTATION - 'PRESS FONTCOERCIONS)) - [COND - (XLATEDNAME (SETQ NEWFAMILY (CAR XLATEDNAME)) - (SETQ NEWNSMICASIZE (FIXR (FQUOTIENT (ITIMES (CADR - XLATEDNAME - ) - 2540) - 72))) - (SETQ NEWFACECODE (\FACECODE (CADDR XLATEDNAME] - do (* ; - "Look thru the candidate PRESSFONTWIDTHSFILES for a file that has a description for this font.") - [COND - [(SETQ WSTRM (\GETSTREAM F 'INPUT T)) - (COND - ((RANDACCESSP WSTRM) - (RESETSAVE NIL (LIST 'SETFILEPTR WSTRM (GETFILEPTR WSTRM))) - (SETFILEPTR WSTRM 0] - (T (RESETSAVE (SETQ WSTRM (OPENSTREAM F 'INPUT 'OLD 8)) - '(PROGN (CLOSEF? OLDVALUE] - [OR (RANDACCESSP WSTRM) - (COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM '{NODIRCORE} 'BOTH - 'NEW] - (push STRMCACHE WSTRM) (* ; "Save for coercions below") - (COND - ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM (OR NEWNSMICASIZE - NSMICASIZE) - FIRSTCHAR LASTCHAR (OR NEWFAMILY FAMILY) - (OR NEWFACECODE FACECODE))) - (* ; - "OK, we found this font described in this file.") - (COND - (XLATEDNAME (replace FONTDEVICESPEC of FD with - XLATEDNAME) - (SETQ NSMICASIZE NEWNSMICASIZE))) - (RETURN T] - [bind XLATEDNAME NEWFAMILY NEWNSMICASIZE NEWFACECODE XLATEDNAMES - first (SETQ STRMCACHE (DREVERSE STRMCACHE)) - while (SETQ XLATEDNAME (\COERCEFONT FAMILY SIZE FACE ROTATION - 'PRESS MISSINGFONTCOERCIONS XLATEDNAMES)) - thereis (push XLATEDNAMES XLATEDNAME) - (for old WSTRM in STRMCACHE - first (SETQ NEWFAMILY (CAR XLATEDNAME)) - (SETQ NEWNSMICASIZE (FIXR (FQUOTIENT (ITIMES (CADR XLATEDNAME - ) - 2540) - 72))) - (SETQ NEWFACECODE (\FACECODE (CADDR XLATEDNAME))) - do (* ; - "Now try coercing the family name") - (* ;; "We know the file was left open and is randaccessp from the previous loop, which must have run off the end of the file list") - - (SETFILEPTR WSTRM 0) - (COND - ((SETQ RELFLAG (\POSITIONFONTFILE WSTRM NEWNSMICASIZE - FIRSTCHAR LASTCHAR NEWFAMILY - NEWFACECODE)) - (replace FONTDEVICESPEC of FD with XLATEDNAME - ) - (SETQ NSMICASIZE NEWNSMICASIZE) - (RETURN T] - (RETURN NIL)) -(* ;;; "Having found the font-widths file, now read the width info from it.") - - (SETQ RELFLAG (ZEROP RELFLAG)) (* ; -"Actually, \POSITIONFONTFILE returns zero if the font metrics are size-relative and must be scaled.") - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (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") - (SETQ FOO (\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) - (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) - BYTESPERWORD)) (* ; "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]) -) -(DEFINEQ - -(\PRESSCURVE2 - [LAMBDA (PRSTREAM SPLINE DASHING BRUSHFONT) (* thh%: "16-Jun-86 10:53") - - (* Given a spline curve and a font, draw the lines to PRSTREAM) - - (RESETLST (RESETSAVE NIL (LIST '\DSPFONT.PRESSFONT PRSTREAM (\DSPFONT.PRESSFONT PRSTREAM - BRUSHFONT))) - [PROG ((PRDATA (fetch IMAGEDATA of PRSTREAM))) - (COND - ((IGREATERP (IDIFFERENCE (GETFILEPTR (fetch ELSTREAM of PRDATA)) - (fetch ELSTARTBYTE of PRDATA)) - 25000) - (\ENTITYEND.PRESS PRSTREAM) (* Hack to prevent mysterious - overflow in length of entities) - (\ENTITYSTART.PRESS PRSTREAM] - (\BOUT (fetch ELSTREAM of (fetch IMAGEDATA of PRSTREAM)) - ResetSpaceCode) - - (* because the space code shouldn't be interpreted specially when we are - drawing in the vector font) - - (PROG ((XPOLY (create POLYNOMIAL)) - (X'POLY (create POLYNOMIAL)) - (YPOLY (create POLYNOMIAL)) - (Y'POLY (create POLYNOMIAL)) - (X (fetch (SPLINE SPLINEX) of SPLINE)) - (Y (fetch (SPLINE SPLINEY) of SPLINE)) - (X' (fetch (SPLINE SPLINEDX) of SPLINE)) - (Y' (fetch (SPLINE SPLINEDY) of SPLINE)) - (X'' (fetch (SPLINE SPLINEDDX) of SPLINE)) - (Y'' (fetch (SPLINE SPLINEDDY) of SPLINE)) - (X''' (fetch (SPLINE SPLINEDDDX) of SPLINE)) - (Y''' (fetch (SPLINE SPLINEDDDY) of SPLINE)) - (%#KNOTS (fetch %#KNOTS of SPLINE)) - (X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) - 1)) - (Y0 (ELT (fetch (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 HALFVECWIDTH PUTDX EXTRADX PUTDY - EXTRADY) - (SETQ HALFVECWIDTH (FONTPROP BRUSHFONT 'SIZE)) - - (* Half the width of the brush, in dots. - Used to help decide when the line we're drawing goes off-paper.) - - (SETQ DASHON T) - - (* These are initialized outside the prog-bindings cause the compiler can't - hack so many initialized variables) - - (SETQ DASHLST DASHING) - (SETQ DASHCNT (CAR DASHING)) - (SETXY.PRESS PRSTREAM (FIXR (FTIMES X0 MicasPerScan)) - (FIXR (FTIMES Y0 MicasPerScan))) (* Move to the first knot on the - curve) - (replace VECMOVINGRIGHT of (fetch IMAGEDATA of PRSTREAM) - with T) (* Start by assuming we're moving in - increasing X (since the vector fonts - only have strokes that work in that - direction)) - (replace VECWASDISPLAYING of (fetch IMAGEDATA of PRSTREAM) - with (AND (GEQ X0 0) - (GEQ Y0 0))) - (replace VECSEGCHARS of (fetch IMAGEDATA of PRSTREAM) with - NIL) - (replace VECCURX of (fetch IMAGEDATA of PRSTREAM) with X0) - - (* And set the current X and Y positions, denominated in dover spots) - - (replace VECCURY of (fetch IMAGEDATA of PRSTREAM) with Y0) - (* Set up initial values in vec - variables, perform SetX/SetY.) - (SETQ TT 0.0) - (SETQ DELTA 16) - (SETQ IX (FIXR X0)) - (SETQ IY (FIXR Y0)) - [for KNOT# from 1 to (SUB1 %#KNOTS) - do (LOADPOLY XPOLY X'POLY (ELT X''' KNOT#) - (ELT X'' KNOT#) - (ELT X' KNOT#) - (ELT X KNOT#)) - - (* Set up the polynomials that describe X and X' over this segment) - - (LOADPOLY YPOLY Y'POLY (ELT Y''' KNOT#) - (ELT Y'' KNOT#) - (ELT Y' KNOT#) - (ELT Y KNOT#)) - - (* Set up the polynomials that describe Y and Y' over this segment) - - (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.0 up to |1.0.| - That moves the X and Y locations smoothly from this knot to the next one.) - - (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) - - (* Never let X' really get to 0.0 -- things become ill-conditioned there.) - - (SETQ X'T 5.0E-4))) - (COND - ((EQP Y'T 0.0) (* Likewise Y'.) - (SETQ Y'T 5.0E-4))) - [COND - ((FGTP X'T 0.0) - - (* If X' is positive, we'll try moving in the +X direction) - - (SETQ DX DELTA)) - (T (* If not, we'll try the -X - direction.) - (SETQ DX (IMINUS DELTA] - [COND - ((FGTP Y'T 0.0) - - (* Likewise, if Y' is positive, try moving by DELTA in the +Y direction) - - (SETQ DY DELTA)) - (T (SETQ DY (IMINUS DELTA] - (SETQ XWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IX DX) - XT) - X'T)) - - (* Compute a dT, based on moving by DELTA in X.) - - (SETQ YWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IY DY) - YT) - Y'T)) - - (* And a dT based on moving by DELTA in Y.) - - [COND - ((FLESSP XWALLDT YWALLDT) - - (* Use the smaller of the two dT's. In this case, dT for X was smaller, so - compute a new DY as depending on DX.) - - (SETQ NEWT (FPLUS TT XWALLDT)) - (SETQ DY (IDIFFERENCE (FIXR (FPLUS YT (FTIMES XWALLDT Y'T))) - IY))) - (T - - (* Changing Y gave the smaller dT. Compute a new DX, as though it depended on - DY.) - - (SETQ NEWT (FPLUS TT YWALLDT)) - (SETQ DX (IDIFFERENCE (FIXR (FPLUS XT (FTIMES YWALLDT X'T))) - IX] - (SETQ PUTDX DX) - (SETQ EXTRADX 0) - (SETQ PUTDY DY) - (SETQ EXTRADY 0) - [COND - ((IGREATERP DX 16) - (SETQ PUTDX 16) - (SETQ EXTRADX (IDIFFERENCE DX 16] - [COND - ((IGREATERP -16 DX) - (SETQ PUTDX -16) - (SETQ EXTRADX (IPLUS DX 16] - [COND - ((IGREATERP DY 16) - (SETQ PUTDY 16) - (SETQ EXTRADY (IDIFFERENCE DY 16] - [COND - ((IGREATERP -16 DY) - (SETQ PUTDY -16) - (SETQ EXTRADY (IPLUS DY 16] - (COND - ([AND (FGTP NEWT 1.0) - (OR DUPLICATEKNOT (EQ KNOT# (SUB1 %#KNOTS] - (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))) - (SETQ YDIFF (ABS (FDIFFERENCE (IPLUS IY DY) - NEWYT))) - (COND - ((AND (IGREATERP DELTA 1) - (OR (FGTP XDIFF 1.0) - (FGTP YDIFF 1.0))) - - (* If we're more than a dover spot off where we'd expect to be because of the - size of DELTA--and if there's room to make DELTA smaller--then try - DELTA_DELTA/2) - - (SETQ DELTA (LRSH DELTA 1))) - (T - - (* No, this estimate is close enough. Put out a vector segment based on it, - and move to the new TT.) - - (\VECPUT PRSTREAM PUTDX PUTDY HALFVECWIDTH) - (* Print out a stroke using the - vector font.) - (COND - ((OR (NEQ EXTRADX 0) - (NEQ EXTRADY 0)) - - (* If, actually, it was too big for one stroke, use another.) - - (\VECPUT PRSTREAM EXTRADX EXTRADY HALFVECWIDTH))) - (SETQ IX (IPLUS IX DX)) - (* Our new current location, in - Dover spots) - (SETQ IY (IPLUS IY DY)) - (SETQ TT NEWT) (* Set TT to its new value) - (SETQ XT NEWXT) - - (* And set the new floating-point values for X - (t) and Y (t)%.) - - (SETQ YT NEWYT) - (COND - ((AND (ILESSP DELTA 16) - (OR (FLESSP XDIFF 0.5) - (FLESSP YDIFF 0.5))) - - (* If we were especially close, try making DELTA larger for the next go - round.) - - (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] - (\ENDVECRUN PRSTREAM HALFVECWIDTH]) -) - - - -(* Generic utility for coercing fonts, could be used by other devices) - -(DEFINEQ - -(\COERCEFONT - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE COERCELIST BUTNOT CREATEFLG) - (* ; "Edited 9-Mar-88 12:58 by thh:") - (* ;; "Returns a font name that the requested font specification coerces to according to COERCELIST. If CREATEFLG is T, only returns name-lists for which a font descriptor has been created. BUTNOT can be a list of font-specs which are not an acceptable coercion--e.g. a previous one that failed, so we want to keep looking beyond that one.") -(* ;;; "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL (probably only useful for display fonts)") - (* ;; "COERCELIST is an alist of font coercions indexed by device, with the value for each device being a list of the form ((user-font real-font) (user-font real-font) ...) --- Each user-font is either simply a family name, or a list of FAMILY, and optionally SIZE, and FACE, in standard font-name order. Any of these can be NIL, meaning that any requested value matches. In addition, the SIZE can be either a specific number, or a constraint of the form (< n) or (> n), which matches requested sizes that are less than or greater than the constraint size n. --- The real-font is a similar family-name or list, except that a NIL field here means that the requested parameter is simply carried over. Also, no size constraints, only explicit sizes, are allowed. (e.g., (GACHA) or (GACHA (< 10)) or (GACHA 10))") - - (for TRANSL in (CDR (ASSOC DEVICE COERCELIST)) bind NEWCSINFO USERSPEC REALSPEC - FAMCONSTRAINT SIZECONSTRAINT - FACECONSTRAINT NEWFONTNAME - when (AND (SETQ USERSPEC (CAR TRANSL)) - (OR [NULL (SETQ FAMCONSTRAINT (COND - ((LISTP USERSPEC) - (pop USERSPEC)) - (T (PROG1 USERSPEC (SETQ USERSPEC NIL] - (EQ FAMILY FAMCONSTRAINT)) - (OR (NOT (SETQ SIZECONSTRAINT (pop USERSPEC))) - (EQ SIZE SIZECONSTRAINT) - (AND (LISTP SIZECONSTRAINT) - (SELECTQ (CAR SIZECONSTRAINT) - (< (LESSP SIZE (CADR SIZECONSTRAINT))) - (> (GREATERP SIZE (CADR SIZECONSTRAINT))) - NIL))) - (OR (NOT (SETQ FACECONSTRAINT (pop USERSPEC))) - (EQUAL FACE FACECONSTRAINT)) - (SETQ REALSPEC (CADR TRANSL)) - (SETQ NEWFONTNAME (LIST (OR [COND - ((LISTP REALSPEC) - (pop REALSPEC)) - (T (PROG1 REALSPEC (SETQ REALSPEC NIL] - FAMILY) - (OR (pop REALSPEC) - SIZE) - (\FONTFACE (OR (pop REALSPEC) - FACE)) - ROTATION DEVICE)) - (NOT (for EXCLUDE in BUTNOT thereis (EQUAL EXCLUDE NEWFONTNAME))) - (OR (NULL CREATEFLG) - (FONTCREATE NEWFONTNAME NIL NIL NIL NIL T))) do (RETURN NEWFONTNAME]) -) - -(ADDTOVAR FONTCOERCIONS (PRESS ((SYMBOL (< 10)) - (SYMBOL 10)) - ((SYMBOL (> 12)) - (SYMBOL 12)))) - -(ADDTOVAR MISSINGFONTCOERCIONS (PRESS (MODERN HELVETICA) - (CLASSIC TIMESROMAN) - (LOGOTYPE LOGO) - (TERMINAL GACHA) - (MODERN FRUTIGER) - (CLASSIC CENTURY))) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS FONTCOERCIONS MISSINGFONTCOERCIONS) -) -(DEFINEQ - -(\STRINGWIDTH.PRESS - [LAMBDA (STREAM STRING RDTBL) (* rmk%: "24-Feb-86 09:49") - - (* Returns the width of STRING in the press STREAM, observing spacefactor) - - (\STRINGWIDTH.GENERIC STRING (ffetch PRLOGICALFONT of (ffetch IMAGEDATA of STREAM - )) - RDTBL - (ffetch PRSPACEWIDTH of (ffetch IMAGEDATA of STREAM]) - -(\CHARWIDTH.PRESS - [LAMBDA (STREAM CHARCODE) (* rmk%: "24-Feb-86 09:49") - - (* Gets the width of CHARCODE in a Press STREAM, observing spacefactor) - - (COND - ((EQ CHARCODE (CHARCODE SPACE)) - (ffetch PRSPACEWIDTH of (ffetch IMAGEDATA of STREAM))) - (T (\FGETCHARWIDTH (ffetch PRLOGICALFONT of (ffetch IMAGEDATA of STREAM)) - CHARCODE]) - -(\OUTCHARFN.PRESS - [LAMBDA (PRSTREAM CHARCODE) (* rmk%: "24-Feb-86 12:18") - - (* Handle all the special-purpose characters going to a PRESS file) - - (SELCHARQ CHARCODE - (EOL (* New Line) - (NEWLINE.PRESS PRSTREAM) - (replace (STREAM CHARPOSITION) of PRSTREAM with 0)) - (LF (* Line feed--move down, but not - over) - (\DSPXPOSITION.PRESS PRSTREAM (PROG1 (DSPXPOSITION NIL PRSTREAM) - (NEWLINE.PRESS PRSTREAM)))) - (^L (* Form Feed) - (replace (STREAM CHARPOSITION) of PRSTREAM with 0) - (NEWPAGE.PRESS PRSTREAM)) - (PROG (XPOS NEWXPOS CLIPPINGREGION PRCHARCODE TRANSLATION (CHARSET (\CHARSET CHARCODE)) - (PRDATA (fetch IMAGEDATA of PRSTREAM))) - [if (NEQ CHARSET (ffetch PRLOGICALCHARSET of PRDATA)) - then (LET [(CSINFO (\GETCHARSETINFO CHARSET (ffetch PRLOGICALFONT - of PRDATA] - (UNINTERRUPTABLY - (freplace PRWIDTHSCACHE of PRDATA - with (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (freplace PRTRANSLATIONCACHE of PRDATA - with (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO - )) - (freplace PRLOGICALCHARSET of PRDATA with CHARSET))] - (SETQ TRANSLATION (\GETBASEPTR (ffetch PRTRANSLATIONCACHE of PRDATA) - (UNFOLD (\CHAR8CODE CHARCODE) - 2))) - (if (NEQ (CAR TRANSLATION) - (fetch PRFONT of PRDATA)) - then (\DSPFONT.PRESSFONT PRSTREAM (CAR TRANSLATION))) - (SETQ PRCHARCODE (CDR TRANSLATION)) - (SETQ XPOS (fetch PRXPOS of PRDATA)) - [SETQ NEWXPOS (IPLUS XPOS (COND - ((EQ CHARCODE (CHARCODE SPACE)) - (ffetch PRSPACEWIDTH of PRDATA)) - (T (\FGETWIDTH (ffetch (PRESSDATA PRWIDTHSCACHE) - of PRDATA) - (\CHAR8CODE CHARCODE] - (COND - ((AND [IGEQ XPOS (fetch LEFT of (SETQ CLIPPINGREGION (fetch - PRClippingRegion - of PRDATA] - (ILEQ NEWXPOS (fetch RIGHT of CLIPPINGREGION)) - (IGEQ (fetch PRYPOS of PRDATA) - (fetch BOTTOM of CLIPPINGREGION))) - - (* Bottom test should really subtract off the descent, and also should do a - top-test) - - (* The Y-tests can probably be done inside SETXY, SETY, and DSPFONT.) - - [COND - ((NOT (ffetch CHARWASDISPLAYING of PRDATA)) - (* Was being clipped, now not) - (freplace CHARWASDISPLAYING of PRDATA with T) - (SHOW.PRESS PRSTREAM) (* SHOW shouldn't be necessary, but - |...|) - (SETXY.PRESS PRSTREAM XPOS (fetch PRYPOS of PRDATA] - (\BOUT PRSTREAM PRCHARCODE)) - (T (SHOW.PRESS PRSTREAM) - - (* Don't put out any characters if out of the clipping region) - - (freplace CHARWASDISPLAYING of PRDATA with NIL))) - (replace PRXPOS of PRDATA with NEWXPOS]) -) - (* * new declaration for PRESSDATA) - -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(DATATYPE PRESSDATA (PRHEADING (* ; - "The string to be printed atop each page.") - PRHEADINGFONT (* ; "Font to print the heading in") - PRXPOS (* ; "Current X position") - PRYPOS (* ; "Current Y position") - PRFONT (* ; "Current font") - PRCURRFDE PRESSFONTDIR (PRWIDTHSCACHE POINTER - (* ; - "Widths table for the current logical character set") - ) - PRCOLOR PRLINEFEED PRPAGESTATE PDSTREAM ELSTREAM XPRPAGEREGION PRDOCNAME - (PRLEFT WORD) (* ; "Page left margin") - (PRBOTTOM WORD) (* ; "Page bottom margin") - (PRRIGHT WORD) (* ; "Page right margin") - (PRTOP WORD) (* ; "Page top margin") - (PRPAGENUM WORD) (* ; "Current Page number") - (PRNEXTFONT# BYTE) - (PRMAXFONTSET BYTE) - (PRPARTSTART INTEGER) - (DLSTARTBYTE INTEGER) - (ELSTARTBYTE INTEGER) - (STARTCHARBYTE INTEGER) - (VECMOVINGRIGHT FLAG) (* ; - "If we're drawing a curve with vector fonts, are we moving to the right?") - (VECWASDISPLAYING FLAG) - - (* ;; "Used during curve/line clipping to remember whether we were on-screen or not, so we know when to force a SETXY.") - - VECSEGCHARS (* ; - "Cache for vector characters while we're moving to the left.") - VECCURX (* ; - "Current X position within vector code, in Dover spots") - VECCURY (* ; - "Current Y position with vector code, in Dover spots") - PRSPACEFACTOR PRSPACEWIDTH (CHARWASDISPLAYING FLAG) - (* ; - "Says whether we have been printing characters inside the clipping region") - PRClippingRegion - - (* ;; "The edges of the paper, as far as PRESS is concerned. Used to protect SPRUCE users who get killed when the image goes off-paper") - - PRLOGICALFONT (* ; "Current logical font") - PRLOGICALCHARSET (* ; - "Current logical character set, whose info is cached. NIL if cache is invalid") - (PRTRANSLATIONCACHE POINTER (* ; - "Translation table for the current logical character set") - )) - PRSPACEFACTOR _ 1 PRXPOS _ 0 PRYPOS _ 0 (* ; - "We assume that the origin is translated to the bottom-left of the page region") - PRClippingRegion _ (create REGION - LEFT _ SPRUCEPAPERLEFTMICAS - BOTTOM _ SPRUCEPAPERBOTTOMMICAS - WIDTH _ (DIFFERENCE SPRUCEPAPERRIGHTMICAS - SPRUCEPAPERLEFTMICAS) - HEIGHT _ 29210) - [ACCESSFNS ((PRWIDTH (IDIFFERENCE (fetch (PRESSDATA PRRIGHT) of DATUM) - (fetch (PRESSDATA PRLEFT) of DATUM))) - (PRHEIGHT (IDIFFERENCE (fetch (PRESSDATA PRTOP) of DATUM) - (fetch (PRESSDATA PRBOTTOM) of DATUM))) - (PRPAGEREGION (fetch (PRESSDATA XPRPAGEREGION) of DATUM) - (PROGN (replace (PRESSDATA XPRPAGEREGION) of DATUM - with NEWVALUE) - (replace (PRESSDATA PRLEFT) of DATUM - with (fetch (REGION LEFT) of NEWVALUE)) - (replace (PRESSDATA PRBOTTOM) of DATUM - with (fetch (REGION BOTTOM) of NEWVALUE)) - (replace (PRESSDATA PRRIGHT) of DATUM - with (IPLUS (fetch (REGION LEFT) of NEWVALUE) - (fetch (REGION WIDTH) of NEWVALUE))) - (replace (PRESSDATA PRTOP) of DATUM - with (IPLUS (fetch (REGION BOTTOM) of NEWVALUE) - (fetch (REGION HEIGHT) of NEWVALUE]) -) - -(/DECLAREDATATYPE 'PRESSDATA - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP - FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER - ) - '((PRESSDATA 0 POINTER) - (PRESSDATA 2 POINTER) - (PRESSDATA 4 POINTER) - (PRESSDATA 6 POINTER) - (PRESSDATA 8 POINTER) - (PRESSDATA 10 POINTER) - (PRESSDATA 12 POINTER) - (PRESSDATA 14 POINTER) - (PRESSDATA 16 POINTER) - (PRESSDATA 18 POINTER) - (PRESSDATA 20 POINTER) - (PRESSDATA 22 POINTER) - (PRESSDATA 24 POINTER) - (PRESSDATA 26 POINTER) - (PRESSDATA 28 POINTER) - (PRESSDATA 30 (BITS . 15)) - (PRESSDATA 31 (BITS . 15)) - (PRESSDATA 32 (BITS . 15)) - (PRESSDATA 33 (BITS . 15)) - (PRESSDATA 34 (BITS . 15)) - (PRESSDATA 35 (BITS . 7)) - (PRESSDATA 35 (BITS . 135)) - (PRESSDATA 36 FIXP) - (PRESSDATA 38 FIXP) - (PRESSDATA 40 FIXP) - (PRESSDATA 42 FIXP) - (PRESSDATA 28 (FLAGBITS . 0)) - (PRESSDATA 28 (FLAGBITS . 16)) - (PRESSDATA 44 POINTER) - (PRESSDATA 46 POINTER) - (PRESSDATA 48 POINTER) - (PRESSDATA 50 POINTER) - (PRESSDATA 52 POINTER) - (PRESSDATA 52 (FLAGBITS . 0)) - (PRESSDATA 54 POINTER) - (PRESSDATA 56 POINTER) - (PRESSDATA 58 POINTER) - (PRESSDATA 60 POINTER)) - '62) -) - -(/DECLAREDATATYPE 'PRESSDATA - '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER - POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD BYTE BYTE FIXP FIXP FIXP FIXP - FLAG FLAG POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER - ) - '((PRESSDATA 0 POINTER) - (PRESSDATA 2 POINTER) - (PRESSDATA 4 POINTER) - (PRESSDATA 6 POINTER) - (PRESSDATA 8 POINTER) - (PRESSDATA 10 POINTER) - (PRESSDATA 12 POINTER) - (PRESSDATA 14 POINTER) - (PRESSDATA 16 POINTER) - (PRESSDATA 18 POINTER) - (PRESSDATA 20 POINTER) - (PRESSDATA 22 POINTER) - (PRESSDATA 24 POINTER) - (PRESSDATA 26 POINTER) - (PRESSDATA 28 POINTER) - (PRESSDATA 30 (BITS . 15)) - (PRESSDATA 31 (BITS . 15)) - (PRESSDATA 32 (BITS . 15)) - (PRESSDATA 33 (BITS . 15)) - (PRESSDATA 34 (BITS . 15)) - (PRESSDATA 35 (BITS . 7)) - (PRESSDATA 35 (BITS . 135)) - (PRESSDATA 36 FIXP) - (PRESSDATA 38 FIXP) - (PRESSDATA 40 FIXP) - (PRESSDATA 42 FIXP) - (PRESSDATA 28 (FLAGBITS . 0)) - (PRESSDATA 28 (FLAGBITS . 16)) - (PRESSDATA 44 POINTER) - (PRESSDATA 46 POINTER) - (PRESSDATA 48 POINTER) - (PRESSDATA 50 POINTER) - (PRESSDATA 52 POINTER) - (PRESSDATA 52 (FLAGBITS . 0)) - (PRESSDATA 54 POINTER) - (PRESSDATA 56 POINTER) - (PRESSDATA 58 POINTER) - (PRESSDATA 60 POINTER)) - '62) - (* * NSTOASCIITRANSLATIONS is a list with elements of the form (charset translationArrayName) %, where - translationArrayName is bound to a translation array for charset which contains (fontFamily charcode) - lists) - -(DEFINEQ - -(\NSTOASCIIARRAY - [LAMBDA (CHARSET) (* thh%: "17-Feb-86 09:05") - (* gets the translation array to use - for this charset) - (EVAL (CADR (ASSOC CHARSET NSTOASCIITRANSLATIONS]) - -(\NSTOASCIITRANSLATION - [LAMBDA (TRANSLATION FAMILY FONTDESC) (* thh%: " 5-Mar-86 10:23") - - (* returns (fontdesc . charcode) to use in place of the specified 8-bit - charcode) - - (* FAMILY, if specified, is font family to use when not specified by the - translation array) - - (* * determine the (family charcode) translation) - - (OR TRANSLATION (SETQ TRANSLATION unknownCharTranslation)) - [COND - ((FIXP TRANSLATION) - (SETQ TRANSLATION (LIST (OR FAMILY FONTDESC) - TRANSLATION] - - (* * coerce to a full font descriptor) - - (CONS (\PRESS.COERCEFONT FONTDESC (CAR TRANSLATION)) - (CADR TRANSLATION]) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS NSTOASCIITRANSLATIONS PRESSFONTFAMILIES) -) - -(RPAQ? PRESSFONTFAMILIES '((GACHA) - (TIMESROMAN) - (HELVETICA) - (SYMBOL) - (MATH) - (HIPPO) - (CYRILLIC) - (NEWVEC) - (SNEWVEC) - (HNEWVEC) - (VNEWVEC))) - -(RPAQ? NSTOASCIITRANSLATIONS ) - -(ADDTOVAR NSTOASCIITRANSLATIONS (0 ASCIIFROM0ARRAY) - (38 ASCIIFROM38ARRAY) - (39 ASCIIFROM39ARRAY) - (239 ASCIIFROM239ARRAY)) - -(READVARS-FROM-STRINGS '(ASCIIFROM0ARRAY ASCIIFROM38ARRAY ASCIIFROM39ARRAY ASCIIFROM239ARRAY) - "({Y256 POINTER 0 {R163 NIL} (SYMBOL 126) (SYMBOL 127) NIL NIL (SYMBOL 120) NIL 96 NIL NIL (SYMBOL -55) (SYMBOL 34) (SYMBOL 33) (SYMBOL 35) NIL (SYMBOL 6) NIL NIL (SYMBOL 2) NIL (SYMBOL 123) NIL -(SYMBOL 13) 39 {R25 NIL} (SYMBOL 125) {R44 NIL} } {Y256 POINTER 0 (HIPPO 118) {R64 NIL} (HIPPO 65) - (HIPPO 66) NIL (HIPPO 71) (HIPPO 68) (HIPPO 69) NIL NIL (HIPPO 90) (HIPPO 72) (HIPPO 81) ( -HIPPO 73) (HIPPO 75) (HIPPO 76) (HIPPO 77) (HIPPO 78) (HIPPO 67) (HIPPO 79) (HIPPO 80) NIL ( -HIPPO 82) (HIPPO 83) NIL (HIPPO 84) (HIPPO 85) (HIPPO 70) (HIPPO 88) (HIPPO 89) (HIPPO 87) NIL -NIL NIL (HIPPO 97) (HIPPO 98) NIL (HIPPO 103) (HIPPO 100) (HIPPO 101) NIL NIL (HIPPO 122) ( -HIPPO 104) (HIPPO 113) (HIPPO 105) (HIPPO 107) (HIPPO 108) (HIPPO 109) (HIPPO 110) (HIPPO 99) -(HIPPO 111) (HIPPO 112) NIL (HIPPO 114) (HIPPO 115) (HIPPO 106) (HIPPO 116) (HIPPO 117) (HIPPO -102) (HIPPO 120) (HIPPO 121) (HIPPO 119) {R130 NIL} } {Y256 POINTER 0 (CYRILLIC 127) {R32 NIL} ( -CYRILLIC 65) (CYRILLIC 66) (CYRILLIC 86) (CYRILLIC 71) (CYRILLIC 68) (CYRILLIC 69) (CYRILLIC 36) - (CYRILLIC 87) (CYRILLIC 90) (CYRILLIC 73) (CYRILLIC 74) (CYRILLIC 75) (CYRILLIC 76) (CYRILLIC -77) (CYRILLIC 78) (CYRILLIC 79) (CYRILLIC 80) (CYRILLIC 82) (CYRILLIC 83) (CYRILLIC 84) ( -CYRILLIC 85) (CYRILLIC 70) (CYRILLIC 81) (CYRILLIC 126) (CYRILLIC 42) (CYRILLIC 123) (CYRILLIC -125) (CYRILLIC 94) (CYRILLIC 88) (CYRILLIC 67) (CYRILLIC 64) (CYRILLIC 89) (CYRILLIC 72) {R15 -NIL} (CYRILLIC 97) (CYRILLIC 98) (CYRILLIC 118) (CYRILLIC 103) (CYRILLIC 100) (CYRILLIC 101) ( -CYRILLIC 52) (CYRILLIC 119) (CYRILLIC 122) (CYRILLIC 105) (CYRILLIC 106) (CYRILLIC 107) ( -CYRILLIC 108) (CYRILLIC 109) (CYRILLIC 110) (CYRILLIC 111) (CYRILLIC 112) (CYRILLIC 114) ( -CYRILLIC 115) (CYRILLIC 116) (CYRILLIC 117) (CYRILLIC 102) (CYRILLIC 113) (CYRILLIC 54) ( -CYRILLIC 56) (CYRILLIC 91) (CYRILLIC 93) (CYRILLIC 95) (CYRILLIC 120) (CYRILLIC 143) (CYRILLIC -50) (CYRILLIC 121) (CYRILLIC 104) {R12 NIL} (CYRILLIC 99) {R129 NIL} } {Y256 POINTER 0 {R36 NIL} -(TIMESROMAN 155) (TIMESROMAN 156) {R6 NIL} (TIMESROMAN 152) (TIMESROMAN 153) NIL (TIMESROMAN 159) - (MATH 33) (MATH 70) (SYMBOL 104) (SYMBOL 105) NIL NIL (SYMBOL 96) (SYMBOL 97) (MATH 113) NIL ( -SYMBOL 109) (SYMBOL 108) (MATH 116) (MATH 118) (MATH 115) (MATH 117) (MATH 64) NIL (SYMBOL 37) - (SYMBOL 38) {R4 NIL} (MATH 109) NIL (MATH 66) (MATH 78) (MATH 44) (SYMBOL 40) (SYMBOL 44) ( -SYMBOL 41) (MATH 126) (MATH 81) (SYMBOL 36) (MATH 98) NIL NIL (SYMBOL 92) (SYMBOL 91) (SYMBOL -19) (SYMBOL 18) (SYMBOL 27) (SYMBOL 26) NIL NIL (MATH 75) (MATH 72) NIL (MATH 79) (SYMBOL 8) ( -SYMBOL 9) (MATH 54) (SYMBOL 11) (TIMESROMAN 183) (SYMBOL 5) (MATH 104) NIL (SYMBOL 58) NIL ( -SYMBOL 54) NIL NIL (MATH 22) (SYMBOL 16) (MATH 80) (SYMBOL 17) (SYMBOL 29) NIL (SYMBOL 115) ( -MATH 7) (SYMBOL 39) NIL (SYMBOL 25) (MATH 19) (MATH 1) (SYMBOL 112) (SYMBOL 7) {R41 NIL} ( -SYMBOL 59) {R6 NIL} (MATH 82) NIL (SYMBOL 100) (SYMBOL 101) (SYMBOL 98) (SYMBOL 99) (SYMBOL 57) - (SYMBOL 56) (SYMBOL 94) (SYMBOL 95) (MATH 90) (MATH 68) (MATH 100) {R69 NIL} }) -") - -(\SMASHPRESSFONTS) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RPAQQ unknownCharTranslation (MATH 59)) - - -[CONSTANTS (unknownCharTranslation '(MATH 59] -) -) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (2898 3274 (\SMASHPRESSFONTS 2908 . 3272)) (3275 8422 (GETCHARPRESSTRANSLATION 3285 . -4793) (PRESS.NSARRAY 4795 . 6118) (PUTCHARPRESSTRANSLATION 6120 . 8420)) (8423 19133 (\DSPFONT.PRESS -8433 . 9884) (\DSPSPACEFACTOR.PRESS 9886 . 10738) (\ENTITYSTART.PRESS 10740 . 12462) (\SETSPACE.PRESS -12464 . 13166) (\STARTPAGE.PRESS 13168 . 15276) (\PRESS.COERCEFONT 15278 . 16744) (\DSPFONT.PRESSFONT -16746 . 18120) (SETUPFONTS.PRESS 18122 . 19131)) (19134 40822 (\CREATEPRESSFONT 19144 . 20342) ( -\CREATECHARSET.PRESS 20344 . 25444) (\CREATECHARSETZERO.PRESS 25446 . 40820)) (40823 55366 ( -\PRESSCURVE2 40833 . 55364)) (55446 59198 (\COERCEFONT 55456 . 59196)) (59822 65319 ( -\STRINGWIDTH.PRESS 59832 . 60325) (\CHARWIDTH.PRESS 60327 . 60792) (\OUTCHARFN.PRESS 60794 . 65317)) ( -74712 75877 (\NSTOASCIIARRAY 74722 . 75074) (\NSTOASCIITRANSLATION 75076 . 75875))))) -STOP diff --git a/obsolete/lispusers/PRESSFROMNS.TEDIT b/obsolete/lispusers/PRESSFROMNS.TEDIT deleted file mode 100644 index 26a478d1..00000000 Binary files a/obsolete/lispusers/PRESSFROMNS.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/PS-PATCH b/obsolete/lispusers/PS-PATCH deleted file mode 100644 index a0cc1ac3..00000000 --- a/obsolete/lispusers/PS-PATCH +++ /dev/null @@ -1,434 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 8-Nov-90 18:53:15" |{PELE:MV:ENVOS}MEDLEY>POSTSCRIPT>PS-PATCH.;2| 24907 - - changes to%: (VARS PS-PATCHCOMS) - (PROPS (PS-PATCH MAKEFILE-ENVIRONMENT)) - (FNS FIX-SKETCH) - - previous date%: "22-Feb-89 14:11:29" |{PELE:MV:ENVOS}MEDLEY>POSTSCRIPT>PS-PATCH.;1| -) - - -(* ; " -Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved. -") - -(PRETTYCOMPRINT PS-PATCHCOMS) - -(RPAQQ PS-PATCHCOMS - ((PROP (MAKEFILE-ENVIRONMENT FILETYPE) - PS-PATCH) - (FNS ADD.KNOWN.SKETCH.FONT NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST - NEW-SKETCHW-HARDCOPYFN FIX-SKETCH) - [VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT) - (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST) - (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN] - - (* ;; - "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded.") - - (FNS \BUILDSLUGCSINFO \CREATECHARSET) - (ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA) - (TIMESROMAND . TIMESROMAN) - (COURIER . COURIER) - (GACHA . COURIER) - (CLASSIC . TIMESROMAN) - (MODERN . HELVETICA) - (CREAM . HELVETICA) - (TERMINAL . COURIER) - (LOGO . HELVETICA) - (MODERN . HELVETICA))) - (VARS (\KNOWN.SKETCH.FONTSIZES)) - (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES) - POSTSCRIPT.FONT.CONVERSIONS) - - (* ;; "finally actually do the patching of sketch.") - - (P (FIX-SKETCH)))) - -(PUTPROPS PS-PATCH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 - )) - -(PUTPROPS PS-PATCH FILETYPE :TCOMPL) -(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]) - -(NEW-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]) - -(NEW-SK-DECREASING-FONT-LIST - [LAMBDA (FAMILY DEVICETYPE) (* ; "Edited 21-Feb-89 11:26 by snow") - - (* ;; "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.CONVERSIONS)) - 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]) - -(NEW-SKETCHW-HARDCOPYFN - [LAMBDA (SKETCHW OPENIMAGESTREAM) (* ; "Edited 22-Feb-89 13:34 by snow") - (* ; - "dumps the sketch onto OPENIMAGESTREAM.") - (* ; - "centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM") - (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW))) - (PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM)) - (SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW)) - (SCALE (VIEWER.SCALE SKETCHW)) - SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX) - (OR SKETCH (RETURN)) - (SPAWN.MOUSE) - - (* ;; "move the margins out of the way") - - (* ;; - "smallp is to maintain compatibility with koto. For Lute release, this could be increased.") - - (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION)) - OPENIMAGESTREAM) - (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION)) - OPENIMAGESTREAM) - (DSPTOPMARGIN (MAX MAX.SMALLP (fetch (REGION TOP) of PAGEREGION)) - OPENIMAGESTREAM) - (DSPRIGHTMARGIN (MAX MAX.SMALLP (fetch (REGION RIGHT) of PAGEREGION)) - OPENIMAGESTREAM) - - (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.") - - (STATUSPRINT SKETCHW "Hardcopying ...") - [STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE - SKETCHW) - "A Sketch")) - (STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS] - (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM))) - (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR)) - (COND - ((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM) - 'PRESS)) - (NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS) - OF OPENIMAGESTREAM)) - 'NILL)) - (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS) - (fetch WIDTH of PAGEREGION)) - (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS) - (fetch HEIGHT of SKETCHREGIONINPAGECOORDS))) - - (* ;; "we ;have a stream that supports rotation, use it!") - - (DSPROTATE 90 OPENIMAGESTREAM) - (DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION)) - OPENIMAGESTREAM) - (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) - OPENIMAGESTREAM) - - (* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)") - - (* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big. Now it tries to do it on any stream that has a dsprotate function.") - - )) - (SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION) - (fetch (REGION WIDTH) of - SKETCHREGIONINPAGECOORDS - )) - 2)) - (SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION) - (fetch (REGION HEIGHT) of - SKETCHREGIONINPAGECOORDS - )) - 2)) - - (* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.") - - [SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE - (SETQ PAGELEFTSPACE - (PLUS (fetch (REGION LEFT) - of PAGEREGION) - PAGELEFTSPACE)) - (fetch (REGION LEFT) of - - SKETCHREGIONINPAGECOORDS - )) - PAGETOSKETCHFACTOR)) - (MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE - (PLUS (fetch (REGION BOTTOM) - of PAGEREGION) - PAGEBOTTOMSPACE)) - (fetch (REGION BOTTOM) of - SKETCHREGIONINPAGECOORDS - )) - PAGETOSKETCHFACTOR] - (* ; - "calculate the local parts for the interpress sketch.") - (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE - PAGETOSKETCHFACTOR) - (TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR) - (fetch (REGION WIDTH) of - SKETCHREGION - ) - (fetch (REGION HEIGHT) of - SKETCHREGION - )) - PAGETOSKETCHFACTOR OPENIMAGESTREAM)) - (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE - (fetch (REGION WIDTH) of - SKETCHREGIONINPAGECOORDS - ) - (fetch (REGION HEIGHT) of - SKETCHREGIONINPAGECOORDS - ))) - (STATUSPRINT SKETCHW " done.") - (RETURN OPENIMAGESTREAM]) - -(FIX-SKETCH - [LAMBDA NIL (* ; "Edited 8-Nov-90 16:32 by jds") - (COND - ((BOUNDP 'ALL.SKETCHES) - - (* ;; "sketch is loaded") - - (for PATCHED-FN in '(NEW-SK-PICK-FONT NEW-SK-DECREASING-FONT-LIST - NEW-SKETCHW-HARDCOPYFN) as ORIGINAL-FN - in '(SK.PICK.FONT SK.DECREASING.FONT.LIST SKETCHW.HARDCOPYFN) - do (MOVD PATCHED-FN ORIGINAL-FN NIL T)) - (PROMPTPRINT "Sketch has been patched!") - T) - (T (PROMPTPRINT "Sketch doesn't seem to be loaded!") - (PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!") - NIL]) -) - -(RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT) - (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST) - (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN))) - - - -(* ;; "NOTE: to compile the following 2 functions you need FONT loaded prop and EXPORTS.ALL loaded." -) - -(DEFINEQ - -(\BUILDSLUGCSINFO - [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE) (* ; "Edited 14-Feb-89 16:46 by snow") - -(* ;;; "builds a csinfo which contains only the slug (black rectangle) character") - - (SETQ SCALE (OR SCALE 1)) - (PROG ((CSINFO (create CHARSETINFO - CHARSETASCENT _ ASCENT - CHARSETDESCENT _ DESCENT - IMAGEWIDTHS _ (\CREATECSINFOELEMENT))) - WIDTHS OFFSETS BITMAP IMAGEWIDTHS) - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) - (SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) - [SELECTQ DEVICE - (INTERPRESS (* ; - "don't need offsets in INTERPRESS fonts") - NIL) - (PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS ( - \CREATECSINFOELEMENT - ))) - (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0)) - [replace (CHARSETINFO CHARSETBITMAP) of CSINFO - with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE)) - (ROUND (QUOTIENT (IPLUS ASCENT DESCENT) - SCALE] - (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE] - (RETURN CSINFO]) - -(\CREATECHARSET - [LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 14-Feb-89 16:29 by snow") - - (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR") - (* ; - "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") - (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES)) - (AND (IGREATERP CHARSET \MAXCHARSET) - (\ILLEGAL.ARG CHARSET)) - (PROG (CSINFO CREATEFN) - - (* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.") - - (if (OR (AND (IGEQ CHARSET 1) - (ILEQ CHARSET 32)) - (AND (IGEQ CHARSET 127) - (ILEQ CHARSET 160))) - then - - (* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG? is T)") - - [if NOSLUG? - then (RETURN NIL) - else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR - FONTAVGCHARWIDTH) - of FONT) - (FONTPROP FONT 'ASCENT) - (FONTPROP FONT 'DESCENT) - (FONTPROP FONT 'DEVICE) - (FONTPROP FONT 'SCALE] - else [SETQ CREATEFN (COND - ((FMEMB (FONTPROP FONT 'DEVICE) - \DISPLAYSTREAMTYPES) - (FUNCTION \CREATECHARSET.DISPLAY)) - (T (CADR (ASSOC 'CREATECHARSET - (CDR (ASSOC (FONTPROP FONT 'DEVICE) - IMAGESTREAMTYPES] - [if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC) - (LIST CHARSET FONT NOSLUG?] - then (* ; - "the create method returned NIL. so if NOSLUG? return NIL else build a slug charsetinfo") - (RETURN (if NOSLUG? - then (* ; - "the caller just wants NIL back to signal that nothing was found") - NIL - else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR - FONTAVGCHARWIDTH) - of FONT) - (FONTPROP FONT 'ASCENT) - (FONTPROP FONT 'HEIGHT) - (FONTPROP FONT 'DEVICE) - (FONTPROP FONT 'SCALE] - (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of - FONT) - (fetch CHARSETASCENT - of CSINFO))) - (replace \SFDescent of FONT with (IMAX (fetch \SFDescent - of FONT) - (ffetch CHARSETDESCENT - of CSINFO))) - (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent - of FONT) - (ffetch \SFDescent - of FONT))) - (* ; - "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)") - ) - (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT) - CHARSET CSINFO]) -) - -(ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA) - (TIMESROMAND . TIMESROMAN) - (COURIER . COURIER) - (GACHA . COURIER) - (CLASSIC . TIMESROMAN) - (MODERN . HELVETICA) - (CREAM . HELVETICA) - (TERMINAL . COURIER) - (LOGO . HELVETICA) - (MODERN . HELVETICA)) - -(RPAQQ \KNOWN.SKETCH.FONTSIZES NIL) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS (\KNOWN.SKETCH.FONTSIZES) - POSTSCRIPT.FONT.CONVERSIONS) -) - - - -(* ;; "finally actually do the patching of sketch.") - - -(FIX-SKETCH) -(PUTPROPS PS-PATCH COPYRIGHT ("ENVOS Corporation" 1989 1990)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (2086 16850 (ADD.KNOWN.SKETCH.FONT 2096 . 2973) (NEW-SK-PICK-FONT 2975 . 6357) ( -NEW-SK-DECREASING-FONT-LIST 6359 . 8183) (NEW-SKETCHW-HARDCOPYFN 8185 . 16115) (FIX-SKETCH 16117 . -16848)) (17182 23954 (\BUILDSLUGCSINFO 17192 . 19090) (\CREATECHARSET 19092 . 23952))))) -STOP diff --git a/obsolete/lispusers/PS-RS232 b/obsolete/lispusers/PS-RS232 deleted file mode 100644 index fdd7826d..00000000 --- a/obsolete/lispusers/PS-RS232 +++ /dev/null @@ -1,76 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 2-Aug-89 13:35:49" {DSK}PS>PS-RS232.;1 2639 - - changes to%: (VARS PS-RS232COMS) - (PROPS (PS-RS232 MAKEFILE-ENVIRONMENT) - (PS-RS232 PRINTERTYPE) - (PS-RS232 SPOOLFILE)) - (FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT)) - - -(* " -Copyright (c) 1989 by Beckman Instruments, Inc. All rights reserved. -") - -(PRETTYCOMPRINT PS-RS232COMS) - -(RPAQQ PS-RS232COMS ((FILES POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS) - DLRS232C) - (INITVARS (PS-RS232-BAUD 9600) - (PS-RS232-DATABITS 8) - (PS-RS232-PARITY 'NONE) - (PS-RS232-STOPBITS 1) - (PS-RS232-FLOWCONTROL 'XOnXOff)) - (FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT) - (ADDVARS (DEFAULTPRINTINGHOST PS-RS232) - (AROUNDEXITFNS PS-RS232-AFTERLOGOUT)) - (P (PS-RS232-INIT)) - (PROP (MAKEFILE-ENVIRONMENT PRINTERTYPE SPOOLFILE) - PS-RS232))) - -(FILESLOAD POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS) - DLRS232C) - -(RPAQ? PS-RS232-BAUD 9600) - -(RPAQ? PS-RS232-DATABITS 8) - -(RPAQ? PS-RS232-PARITY 'NONE) - -(RPAQ? PS-RS232-STOPBITS 1) - -(RPAQ? PS-RS232-FLOWCONTROL 'XOnXOff) -(DEFINEQ - -(PS-RS232-AFTERLOGOUT - [LAMBDA (EVENT) - (if (EQ EVENT 'AFTERLOGOUT) - then (RS232C.INIT PS-RS232-BAUD PS-RS232-DATABITS PS-RS232-PARITY PS-RS232-STOPBITS - PS-RS232-FLOWCONTROL]) - -(PS-RS232-INIT - [LAMBDA NIL - [PUTPROP 'PS-RS232 'SPOOLOPTIONS `((BaudRate ,PS-RS232-BAUD) - (BitsPerSerialChar ,PS-RS232-DATABITS) - (Parity ,PS-RS232-PARITY) - (NoOfStopBits ,PS-RS232-STOPBITS) - (FlowControl ,PS-RS232-FLOWCONTROL] - (PS-RS232-AFTERLOGOUT 'AFTERLOGOUT) (* ; "Fake it") - NIL]) -) - -(ADDTOVAR DEFAULTPRINTINGHOST PS-RS232) - -(ADDTOVAR AROUNDEXITFNS PS-RS232-AFTERLOGOUT) - -(PS-RS232-INIT) - -(PUTPROPS PS-RS232 MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) - -(PUTPROPS PS-RS232 PRINTERTYPE POSTSCRIPT) - -(PUTPROPS PS-RS232 SPOOLFILE "{RS232}FOO.PS") -(PUTPROPS PS-RS232 COPYRIGHT ("Beckman Instruments, Inc" 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1528 2244 (PS-RS232-AFTERLOGOUT 1538 . 1761) (PS-RS232-INIT 1763 . 2242))))) -STOP diff --git a/obsolete/lispusers/PS-RS232.TEDIT b/obsolete/lispusers/PS-RS232.TEDIT deleted file mode 100644 index dcc1d6ae..00000000 Binary files a/obsolete/lispusers/PS-RS232.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/PS-SKETCH-PATCH b/obsolete/lispusers/PS-SKETCH-PATCH deleted file mode 100644 index 1b8155d7..00000000 --- a/obsolete/lispusers/PS-SKETCH-PATCH +++ /dev/null @@ -1,440 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP") -(FILECREATED " 4-Aug-89 16:46:48" {DSK}LIBRARY>PS-SKETCH-PATCH.;1 25983 - - changes to%: (VARS PS-SKETCH-PATCHCOMS) - (PROPS (PS-SKETCH-PATCH MAKEFILE-ENVIRONMENT)) - (FNS FIX-SKETCH ADD.KNOWN.SKETCH.FONT NEW-SK-DECREASING-FONT-LIST - NEW-SK-PICK-FONT NEW-SKETCHW-HARDCOPYFN \BUILDSLUGCSINFO \CREATECHARSET)) - - -(* " -Copyright (c) 1989 by ENVOS Corporation. All rights reserved. -") - -(PRETTYCOMPRINT PS-SKETCH-PATCHCOMS) - -(RPAQQ PS-SKETCH-PATCHCOMS ((FILES (SYSLOAD FROM LISPUSERS) - SKETCH) - (FNS FIX-SKETCH ADD.KNOWN.SKETCH.FONT NEW-SK-DECREASING-FONT-LIST - NEW-SK-PICK-FONT NEW-SKETCHW-HARDCOPYFN) - - (* ;; - "NOTE: to compile the following 2 functions you need EXPORTS.ALL loaded.") - - (FNS \BUILDSLUGCSINFO \CREATECHARSET) - [VARS (SKETCH-PATCHES '((NEW-SK-PICK-FONT . SK.PICK.FONT) - (NEW-SK-DECREASING-FONT-LIST - . SK.DECREASING.FONT.LIST) - (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN] - (ADDVARS (POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA) - (TIMESROMAND . TIMESROMAN) - (COURIER . COURIER) - (GACHA . COURIER) - (CLASSIC . TIMESROMAN) - (MODERN . HELVETICA) - (CREAM . HELVETICA) - (TERMINAL . COURIER) - (LOGO . HELVETICA) - (MODERN . HELVETICA))) - (VARS (\KNOWN.SKETCH.FONTSIZES)) - (GLOBALVARS (\KNOWN.SKETCH.FONTSIZES) - POSTSCRIPT.FONT.CONVERSIONS) - - (* ;; "finally actually do the patching of sketch.") - - (P (FIX-SKETCH)) - (PROP (MAKEFILE-ENVIRONMENT FILETYPE) - PS-SKETCH-PATCH))) - -(FILESLOAD (SYSLOAD FROM LISPUSERS) - SKETCH) -(DEFINEQ - -(FIX-SKETCH - [LAMBDA NIL (* ; "Edited 7-Jul-89 19:40 by Matt Heffron") - (COND - ((BOUNDP 'ALL.SKETCHES) - - (* ;; "sketch is loaded") - - (for X in SKETCH-PATCHES do (MOVD (CAR X) - (CDR X) - NIL T)) - (PROMPTPRINT "Sketch has been patched!") - T) - (T (PROMPTPRINT "Sketch doesn't seem to be loaded!") - (PROMPTPRINT "When you load sketch, make sure to call the function FIX-SKETCH!") - NIL]) - -(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]) - -(NEW-SK-DECREASING-FONT-LIST - [LAMBDA (FAMILY DEVICETYPE) (* ; "Edited 21-Feb-89 11:26 by snow") - - (* ;; "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.CONVERSIONS)) - 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]) - -(NEW-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]) - -(NEW-SKETCHW-HARDCOPYFN - [LAMBDA (SKETCHW OPENIMAGESTREAM) (* ; "Edited 27-Jul-89 17:52 by Matt Heffron") - (* ; - "dumps the sketch onto OPENIMAGESTREAM.") - (* ; - "centers it within the DSPCLIPPINGREGION of OPENIMAGESTREAM") - (PROG ((SKETCH (INSURE.SKETCH (SKETCH.FROM.VIEWER SKETCHW))) - (PAGEREGION (DSPCLIPPINGREGION NIL OPENIMAGESTREAM)) - (SKETCHREGION (SKETCH.REGION.VIEWED SKETCHW)) - (SCALE (VIEWER.SCALE SKETCHW)) - SKETCHREGIONINPAGECOORDS PAGELEFTSPACE PAGEBOTTOMSPACE PAGETOSKETCHFACTOR SKETCHX) - (OR SKETCH (RETURN)) - (SPAWN.MOUSE) - - (* ;; "move the margins out of the way") - - (DSPLEFTMARGIN (MIN 0 (fetch (REGION LEFT) of PAGEREGION)) - OPENIMAGESTREAM) - (DSPBOTTOMMARGIN (MIN 0 (fetch (REGION BOTTOM) of PAGEREGION)) - OPENIMAGESTREAM) - (DSPTOPMARGIN (MAX (ITIMES MAX.SMALLP MAX.SMALLP) - (fetch (REGION TOP) of PAGEREGION)) - OPENIMAGESTREAM) (* ; - "MAX.SMALLP^2 ought to be big enough...") - (DSPRIGHTMARGIN (MAX (ITIMES MAX.SMALLP MAX.SMALLP) - (fetch (REGION RIGHT) of PAGEREGION)) - OPENIMAGESTREAM) - - (* ;; "PAGETOSKETCHFACTOR is the factor to multiply the page coordinates by to get into sketch coordinates.") - - (STATUSPRINT SKETCHW "Hardcopying ...") - [STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS (APPEND (LIST 'DOCUMENT.NAME (OR (SKETCH.TITLE - SKETCHW) - "A Sketch")) - (STREAMPROP OPENIMAGESTREAM 'PRINTOPTIONS] - (SETQ PAGETOSKETCHFACTOR (FQUOTIENT SCALE (DSPSCALE NIL OPENIMAGESTREAM))) - (SETQ SKETCHREGIONINPAGECOORDS (SCALE.REGION.OUT SKETCHREGION PAGETOSKETCHFACTOR)) - (COND - ((AND (NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM) - 'PRESS)) - (NOT (EQ (FETCH (IMAGEOPS IMROTATE) OF (FETCH (STREAM IMAGEOPS) - OF OPENIMAGESTREAM)) - 'NILL)) - (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS) - (fetch WIDTH of PAGEREGION)) - (GREATERP (fetch WIDTH of SKETCHREGIONINPAGECOORDS) - (fetch HEIGHT of SKETCHREGIONINPAGECOORDS))) - - (* ;; "we have a stream that supports rotation, use it!") - - (DSPROTATE 90 OPENIMAGESTREAM) - (COND - ((NOT (EQ (IMAGESTREAMTYPE OPENIMAGESTREAM) - 'POSTSCRIPT)) - - (* ;; "Since PostScript's DSPROTATE does the translate also..., dont't do it here. --HACK! HACK! HACK! --Matt.") - - (DSPTRANSLATE 0 (MINUS (FETCH (REGION HEIGHT) OF PAGEREGION)) - OPENIMAGESTREAM))) - (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) - OPENIMAGESTREAM) - - (* ;; "(ROTATE.IP OPENIMAGESTREAM 90) (CONCATT.IP OPENIMAGESTREAM) (TRANSLATE.IP OPENIMAGESTREAM 0 -21590) (CONCATT.IP OPENIMAGESTREAM) (DSPCLIPPINGREGION (SETQ PAGEREGION (SK.SWITCH.REGION.X.AND.Y PAGEREGION)) OPENIMAGESTREAM)") - - (* ;; "this was an incredibly bogus hack to make INTERPRESS only streams rotate the sketch image if they were too big. Now it tries to do it on any stream that has a dsprotate function.") - - )) - (SETQ PAGELEFTSPACE (QUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of PAGEREGION) - (fetch (REGION WIDTH) of - SKETCHREGIONINPAGECOORDS - )) - 2)) - (SETQ PAGEBOTTOMSPACE (QUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of PAGEREGION) - (fetch (REGION HEIGHT) of - SKETCHREGIONINPAGECOORDS - )) - 2)) - - (* ;; "translate the sketch so that the lower left corner of the sketch region is at the lower left corner of the image on the page.") - - [SETQ SKETCHX (TRANSLATE.SKETCH SKETCH (MINUS (TIMES (DIFFERENCE - (SETQ PAGELEFTSPACE - (PLUS (fetch (REGION LEFT) - of PAGEREGION) - PAGELEFTSPACE)) - (fetch (REGION LEFT) of - - SKETCHREGIONINPAGECOORDS - )) - PAGETOSKETCHFACTOR)) - (MINUS (TIMES (DIFFERENCE (SETQ PAGEBOTTOMSPACE - (PLUS (fetch (REGION BOTTOM) - of PAGEREGION) - PAGEBOTTOMSPACE)) - (fetch (REGION BOTTOM) of - SKETCHREGIONINPAGECOORDS - )) - PAGETOSKETCHFACTOR] - (* ; - "calculate the local parts for the interpress sketch.") - (SETQ SKETCHX (MAKE.LOCAL.SKETCH SKETCHX (CREATEREGION (TIMES PAGELEFTSPACE - PAGETOSKETCHFACTOR) - (TIMES PAGEBOTTOMSPACE PAGETOSKETCHFACTOR) - (fetch (REGION WIDTH) of - SKETCHREGION - ) - (fetch (REGION HEIGHT) of - SKETCHREGION - )) - PAGETOSKETCHFACTOR OPENIMAGESTREAM)) - (DRAW.LOCAL.SKETCH SKETCHX OPENIMAGESTREAM (CREATEREGION PAGELEFTSPACE PAGEBOTTOMSPACE - (fetch (REGION WIDTH) of - SKETCHREGIONINPAGECOORDS - ) - (fetch (REGION HEIGHT) of - SKETCHREGIONINPAGECOORDS - ))) - (STATUSPRINT SKETCHW " done.") - (RETURN OPENIMAGESTREAM]) -) - - - -(* ;; "NOTE: to compile the following 2 functions you need EXPORTS.ALL loaded.") - -(DEFINEQ - -(\BUILDSLUGCSINFO - [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE) (* ; "Edited 14-Feb-89 16:46 by snow") - -(* ;;; "builds a csinfo which contains only the slug (black rectangle) character") - - (SETQ SCALE (OR SCALE 1)) - (PROG ((CSINFO (create CHARSETINFO - CHARSETASCENT _ ASCENT - CHARSETDESCENT _ DESCENT - IMAGEWIDTHS _ (\CREATECSINFOELEMENT))) - WIDTHS OFFSETS BITMAP IMAGEWIDTHS) - (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) - (SETQ IMAGEWIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) - (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) - [SELECTQ DEVICE - (INTERPRESS (* ; - "don't need offsets in INTERPRESS fonts") - NIL) - (PROGN (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS ( - \CREATECSINFOELEMENT - ))) - (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0)) - [replace (CHARSETINFO CHARSETBITMAP) of CSINFO - with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE)) - (ROUND (QUOTIENT (IPLUS ASCENT DESCENT) - SCALE] - (BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE] - (RETURN CSINFO]) - -(\CREATECHARSET - [LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 14-Feb-89 16:29 by snow") - - (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR") - (* ; - "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") - (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES)) - (AND (IGREATERP CHARSET \MAXCHARSET) - (\ILLEGAL.ARG CHARSET)) - (PROG (CSINFO CREATEFN) - - (* ;; "For other charsets, create a font descriptor of info for that charset, and use it to fill things in.") - - (if (OR (AND (IGEQ CHARSET 1) - (ILEQ CHARSET 32)) - (AND (IGEQ CHARSET 127) - (ILEQ CHARSET 160))) - then - - (* ;; "this is an illegal NS character set (reserved for control codes) so just return a slug (unless NOSLUG? is T)") - - [if NOSLUG? - then (RETURN NIL) - else (SETQ CSINFO (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR - FONTAVGCHARWIDTH) - of FONT) - (FONTPROP FONT 'ASCENT) - (FONTPROP FONT 'DESCENT) - (FONTPROP FONT 'DEVICE) - (FONTPROP FONT 'SCALE] - else [SETQ CREATEFN (COND - ((FMEMB (FONTPROP FONT 'DEVICE) - \DISPLAYSTREAMTYPES) - (FUNCTION \CREATECHARSET.DISPLAY)) - (T (CADR (ASSOC 'CREATECHARSET - (CDR (ASSOC (FONTPROP FONT 'DEVICE) - IMAGESTREAMTYPES] - [if [NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC) - (LIST CHARSET FONT NOSLUG?] - then (* ; - "the create method returned NIL. so if NOSLUG? return NIL else build a slug charsetinfo") - (RETURN (if NOSLUG? - then (* ; - "the caller just wants NIL back to signal that nothing was found") - NIL - else (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR - FONTAVGCHARWIDTH) - of FONT) - (FONTPROP FONT 'ASCENT) - (FONTPROP FONT 'HEIGHT) - (FONTPROP FONT 'DEVICE) - (FONTPROP FONT 'SCALE] - (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of - FONT) - (fetch CHARSETASCENT - of CSINFO))) - (replace \SFDescent of FONT with (IMAX (fetch \SFDescent - of FONT) - (ffetch CHARSETDESCENT - of CSINFO))) - (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent - of FONT) - (ffetch \SFDescent - of FONT))) - (* ; - "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)") - ) - (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT) - CHARSET CSINFO]) -) - -(RPAQQ SKETCH-PATCHES ((NEW-SK-PICK-FONT . SK.PICK.FONT) - (NEW-SK-DECREASING-FONT-LIST . SK.DECREASING.FONT.LIST) - (NEW-SKETCHW-HARDCOPYFN . SKETCHW.HARDCOPYFN))) - -(ADDTOVAR POSTSCRIPT.FONT.CONVERSIONS (HELVETICA . HELVETICA) - (TIMESROMAND . TIMESROMAN) - (COURIER . COURIER) - (GACHA . COURIER) - (CLASSIC . TIMESROMAN) - (MODERN . HELVETICA) - (CREAM . HELVETICA) - (TERMINAL . COURIER) - (LOGO . HELVETICA) - (MODERN . HELVETICA)) - -(RPAQQ \KNOWN.SKETCH.FONTSIZES NIL) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS (\KNOWN.SKETCH.FONTSIZES) - POSTSCRIPT.FONT.CONVERSIONS) -) - - - -(* ;; "finally actually do the patching of sketch.") - - -(FIX-SKETCH) - -(PUTPROPS PS-SKETCH-PATCH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP")) - -(PUTPROPS PS-SKETCH-PATCH FILETYPE :TCOMPL) -(PUTPROPS PS-SKETCH-PATCH COPYRIGHT ("ENVOS Corporation" 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (2758 17798 (FIX-SKETCH 2768 . 3382) (ADD.KNOWN.SKETCH.FONT 3384 . 4261) ( -NEW-SK-DECREASING-FONT-LIST 4263 . 6087) (NEW-SK-PICK-FONT 6089 . 9471) (NEW-SKETCHW-HARDCOPYFN 9473 - . 17796)) (17888 24660 (\BUILDSLUGCSINFO 17898 . 19796) (\CREATECHARSET 19798 . 24658))))) -STOP diff --git a/obsolete/lispusers/PS-SKETCH-PATCH.LCOM b/obsolete/lispusers/PS-SKETCH-PATCH.LCOM deleted file mode 100644 index 7e130c6a..00000000 Binary files a/obsolete/lispusers/PS-SKETCH-PATCH.LCOM and /dev/null differ diff --git a/obsolete/lispusers/PS-SKETCH-PATCH.TEDIT b/obsolete/lispusers/PS-SKETCH-PATCH.TEDIT deleted file mode 100644 index 2a0f2937..00000000 Binary files a/obsolete/lispusers/PS-SKETCH-PATCH.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/PS-patch.tedit b/obsolete/lispusers/PS-patch.tedit deleted file mode 100644 index e5e51519..00000000 Binary files a/obsolete/lispusers/PS-patch.tedit and /dev/null differ diff --git a/obsolete/lispusers/PSCFONT-FIX-FILENAME b/obsolete/lispusers/PSCFONT-FIX-FILENAME deleted file mode 100644 index 50368244..00000000 --- a/obsolete/lispusers/PSCFONT-FIX-FILENAME +++ /dev/null @@ -1,84 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "11-May-87 16:33:49" {DSK}PS>PSCFONT-FIX-FILENAME.\;1 5877 - - |changes| |to:| (VARS PSCFONT-FIX-FILENAMECOMS) - (FNS PSCFONT-FILENAME-FIX) - (FILEVARS PSCFONT-FIX-FILENAMECOMS)) - - -; Copyright (c) 1987 by Beckman Instruments, Inc. All rights reserved. - -(PRETTYCOMPRINT PSCFONT-FIX-FILENAMECOMS) - -(RPAQQ PSCFONT-FIX-FILENAMECOMS ((FNS PSCFONT-FILENAME-FIX) - (VARS POSTSCRIPT-FONT-FILENAME-FIXLIST))) -(DEFINEQ - -(PSCFONT-FILENAME-FIX - (LAMBDA NIL (* \; "Edited 11-May-87 15:34 by Matt Heffron") - - (FOR D IN POSTSCRIPTFONTDIRECTORIES - DO (FOR F IN POSTSCRIPT-FONT-FILENAME-FIXLIST - DO (LET (FN) - (CL:WHEN (SETQ FN (INFILEP (CONCAT D (CAR F)))) - (PRINTOUT T FN " => " (RENAMEFILE FN (CONCAT D (\\FONTFILENAME - (CADR F) - 1 - (CADDR F) - '.PSCFONT))) - T))))))) -) - -(RPAQQ POSTSCRIPT-FONT-FILENAME-FIXLIST (("AVANTGARDE-BOOK1" AVANTGARDE-BOOK (MEDIUM REGULAR REGULAR) - ) - ("AVANTGARDE-BOOK1I" AVANTGARDE-BOOK (MEDIUM ITALIC REGULAR) - ) - ("AVANTGARDE-DEMI1" AVANTGARDE-DEMI (MEDIUM REGULAR REGULAR) - ) - ("AVANTGARDE-DEMI1I" AVANTGARDE-DEMI (MEDIUM ITALIC REGULAR) - ) - ("BOOKMAN-DEMI1" BOOKMAN-DEMI (MEDIUM REGULAR REGULAR)) - ("BOOKMAN-DEMI1I" BOOKMAN-DEMI (MEDIUM ITALIC REGULAR)) - ("BOOKMAN-LIGHT1" BOOKMAN-LIGHT (MEDIUM REGULAR REGULAR)) - ("BOOKMAN-LIGHT1I" BOOKMAN-LIGHT (MEDIUM ITALIC REGULAR)) - ("COURIER1" COURIER (MEDIUM REGULAR REGULAR)) - ("COURIER1B" COURIER (BOLD REGULAR REGULAR)) - ("COURIER1BI" COURIER (BOLD ITALIC REGULAR)) - ("COURIER1I" COURIER (MEDIUM ITALIC REGULAR)) - ("HELVETICA-NARROW1" HELVETICA-NARROW (MEDIUM REGULAR - REGULAR)) - ("HELVETICA-NARROW1B" HELVETICA-NARROW (BOLD REGULAR REGULAR - )) - ("HELVETICA-NARROW1BI" HELVETICA-NARROW (BOLD ITALIC REGULAR - )) - ("HELVETICA-NARROW1I" HELVETICA-NARROW (MEDIUM ITALIC - REGULAR)) - ("HELVETICA1" HELVETICA (MEDIUM REGULAR REGULAR)) - ("HELVETICA1B" HELVETICA (BOLD REGULAR REGULAR)) - ("HELVETICA1BI" HELVETICA (BOLD ITALIC REGULAR)) - ("HELVETICA1I" HELVETICA (MEDIUM ITALIC REGULAR)) - ("NEWCENTURYSCHLBK1" NEWCENTURYSCHLBK (MEDIUM REGULAR - REGULAR)) - ("NEWCENTURYSCHLBK1B" NEWCENTURYSCHLBK (BOLD REGULAR REGULAR - )) - ("NEWCENTURYSCHLBK1BI" NEWCENTURYSCHLBK (BOLD ITALIC REGULAR - )) - ("NEWCENTURYSCHLBK1I" NEWCENTURYSCHLBK (MEDIUM ITALIC - REGULAR)) - ("PALATINO1" PALATINO (MEDIUM REGULAR REGULAR)) - ("PALATINO1B" PALATINO (BOLD REGULAR REGULAR)) - ("PALATINO1BI" PALATINO (BOLD ITALIC REGULAR)) - ("PALATINO1I" PALATINO (MEDIUM ITALIC REGULAR)) - ("SYMBOL1" SYMBOL (MEDIUM REGULAR REGULAR)) - ("TIMES1" TIMES (MEDIUM REGULAR REGULAR)) - ("TIMES1B" TIMES (BOLD REGULAR REGULAR)) - ("TIMES1BI" TIMES (BOLD ITALIC REGULAR)) - ("TIMES1I" TIMES (MEDIUM ITALIC REGULAR)) - ("ZAPFCHANCERY-MEDIUM1I" ZAPFCHANCERY-MEDIUM - (MEDIUM REGULAR REGULAR)) - ("ZAPFCHANCERY1I" ZAPFCHANCERY (MEDIUM ITALIC REGULAR)) - ("ZAPFDINGBATS1" ZAPFDINGBATS (MEDIUM REGULAR REGULAR)))) -(PUTPROPS PSCFONT-FIX-FILENAME COPYRIGHT ("Beckman Instruments, Inc" 1987)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (572 1404 (PSCFONT-FILENAME-FIX 582 . 1402))))) -STOP diff --git a/obsolete/lispusers/READDISPLAYFONT b/obsolete/lispusers/READDISPLAYFONT deleted file mode 100644 index d2f895b1..00000000 --- a/obsolete/lispusers/READDISPLAYFONT +++ /dev/null @@ -1,110 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "15-Jul-88 16:33:54" |{MCS:MCS:STANFORD}READDISPLAYFONT.;2| 4644 - - changes to%: (VARS READDISPLAYFONTCOMS) - - previous date%: " 3-May-88 10:33:05" |{MCS:MCS:STANFORD}READDISPLAYFONT.;1|) - - -(* " -Copyright (c) 1988 by Stanford University. All rights reserved. -") - -(PRETTYCOMPRINT READDISPLAYFONTCOMS) - -(RPAQQ READDISPLAYFONTCOMS ((* Redefinition of DISPLAY font functions to facilitate addition of - new font types) - (FNS \READDISPLAYFONTFILE FONTFILEFORMAT) - (ADDVARS (DISPLAYFONTTYPES (AC \READACFONTFILE) - (STRIKE \READSTRIKEFONTFILE))) - (GLOBALVARS DISPLAYFONTTYPES) - (DECLARE%: DONTCOPY (RECORDS DISPLAYFONTTYPE)))) - - - -(* Redefinition of DISPLAY font functions to facilitate addition of new font types) - -(DEFINEQ - -(\READDISPLAYFONTFILE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 3-May-88 10:31 by cdl") - - (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES)) - (bind FONTFILE FONTTYPE CSINFO STREAM for EXTENSION inside DISPLAYFONTEXTENSIONS - when (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET - DISPLAYFONTDIRECTORIES (LIST EXTENSION))) - do (* Use CLOSE? to avoid redundant CLOSEF in AC font file case) - (RESETLST [RESETSAVE NIL `(CLOSEF? ,(SETQ STREAM (OPENSTREAM FONTFILE 'INPUT] - (if (SETQ FONTTYPE (ASSOC (FONTFILEFORMAT STREAM T) - DISPLAYFONTTYPES)) - then (SETQ CSINFO (with DISPLAYFONTTYPE FONTTYPE (APPLY* READFN STREAM FAMILY - SIZE FACE))) - else (SHOULDNT))) - (RETURN CSINFO]) - -(FONTFILEFORMAT - [LAMBDA (STREAM LEAVEOPEN) (* ; "Edited 3-May-88 10:26 by cdl") - (* Returns the font format of STREAM) - [OR (OPENP STREAM 'INPUT) - (SETQ STREAM (OPENSTREAM STREAM 'INPUT] - (PROG1 (OR (LET [(EXTENSION (FILENAMEFIELD (FULLNAME STREAM) - 'EXTENSION] - - (* AC and Strike files count on side effects of this function so we have to - handle them separately for now) - - (if (AND [NOT (FMEMB EXTENSION '(AC STRIKE] - (ASSOC EXTENSION DISPLAYFONTTYPES)) - then EXTENSION)) - (SELECTC (\WIN STREAM) - ((LIST (LLSH 1 15) - (LOGOR (LLSH 1 15) - (LLSH 1 13))) - - (* If high bit of type is on, then must be strike. - If 2nd bit is on, must be strike-index, and we punt. - We don't care about the 3rd bit) - - - - (* first word has high bits (onebit index fixed)%. - Onebit means "new-style font" %, index is 0 for simple strike, 1 for index, and - fixed is if all chars have max width. Lisp doesn't care about "fixed") - - 'STRIKE) - ((LOGOR (LLSH 16 8) - 12) - - (* This is the length of a standard index header. - Other files could also have this value, but it's a pretty good discriminator) - - - - (* Skip to byte 25; do it with BINS so works for non-randaccessp devices. - This skips the standard name header, then look for type 3 in the following - header) - - (FRPTQ 22 (\BIN STREAM)) (* (SETFILEPTR STREAM 25)) - (AND (EQ 3 (LRSH (\BIN STREAM) - 4)) - 'AC)) - NIL)) - (OR LEAVEOPEN (CLOSEF STREAM]) -) - -(ADDTOVAR DISPLAYFONTTYPES (AC \READACFONTFILE) - (STRIKE \READSTRIKEFONTFILE)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS DISPLAYFONTTYPES) -) -(DECLARE%: DONTCOPY -(DECLARE%: EVAL@COMPILE - -(RECORD DISPLAYFONTTYPE (TYPE READFN)) -) -) -(PUTPROPS READDISPLAYFONT COPYRIGHT ("Stanford University" 1988)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1028 4280 (\READDISPLAYFONTFILE 1038 . 2081) (FONTFILEFORMAT 2083 . 4278))))) -STOP diff --git a/obsolete/lispusers/READDISPLAYFONT.LCOM b/obsolete/lispusers/READDISPLAYFONT.LCOM deleted file mode 100644 index 89e0d0d3..00000000 Binary files a/obsolete/lispusers/READDISPLAYFONT.LCOM and /dev/null differ diff --git a/obsolete/lispusers/READDISPLAYFONT.TEDIT b/obsolete/lispusers/READDISPLAYFONT.TEDIT deleted file mode 100644 index 2b774494..00000000 Binary files a/obsolete/lispusers/READDISPLAYFONT.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/REGISTER-MACHINE b/obsolete/lispusers/REGISTER-MACHINE deleted file mode 100644 index 0604b026..00000000 --- a/obsolete/lispusers/REGISTER-MACHINE +++ /dev/null @@ -1,101 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - -(FILECREATED " 1-Feb-2022 16:51:58"  -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>REGISTER-MACHINE.;2 4416 - - :CHANGES-TO (FNS Requst-NS-Registry) - - :PREVIOUS-DATE " 8-Jan-88 18:02:00" -{DSK}kaplan>Local>medley3.5>my-medley>lispusers>REGISTER-MACHINE.;1) - - -(* ; " -Copyright (c) 1986-1988 by Xerox Corporation. -") - -(PRETTYCOMPRINT REGISTER-MACHINECOMS) - -(RPAQQ REGISTER-MACHINECOMS - ( - -(* ;;; "Add a Lafite form that will request that the current machine be registered with the local Clearinghouse") - - (FNS Requst-NS-Registry AmIRegistered) - (ADDVARS (LAFITESPECIALFORMS ("Clearinghouse registry request" 'Requst-NS-Registry - "Make a form to request that the current machine be registered on the local Clearinghouse" - ))) - (P (UNMARKASCHANGED 'LAFITESPECIALFORMS 'VARS) - (SETQ LAFITEFORMSMENU NIL)))) - - - -(* ;;; -"Add a Lafite form that will request that the current machine be registered with the local Clearinghouse" -) - -(DEFINEQ - -(Requst-NS-Registry - [LAMBDA NIL (* ; "Edited 1-Feb-2022 16:46 by rmk") - (* ; "Edited 8-Jan-88 18:00 by Masinter") - -(* ;;; -"Format a nice note requsting that the current machine be registered on the local Clearinghouse.") - - (LET ((*STANDARD-OUTPUT* (OPENTEXTSTREAM NIL NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT))) - (netNumber (fetch NSNET \MY.NSADDRESS)) - (me (FULLUSERNAME)) - (CURRENTLY (AmIRegistered))) - (CL:FORMAT T "To: UserAdministration~A~A~&" (SELECTQ (LAFITEMODE) - (GV ".") - ":") - CH.DEFAULT.DOMAIN) - (CL:FORMAT T "Cc: ~A~%%Reply-to: ~A~%%~%%" me me) - (if CURRENTLY - then (CL:FORMAT T ">>This machine is already registered as ~A <<~%%~%%" CURRENTLY)) - (printout NIL "Primary User: " me T T) - (printout NIL "Name: %"" (OR (ETHERHOSTNAME) - ">>Desired machine name<<") - "%"" T) - (CL:FORMAT T "Network Number: ~5,,'-:D~&" (fetch NSNET \MY.NSADDRESS)) - (CL:FORMAT T "Processor Number: ~5,,'-:D~&" (+ (LSH (fetch NSHNM0 \MY.NSADDRESS) - 32) - (LSH (fetch NSHNM1 \MY.NSADDRESS) - 16) - (fetch NSHNM2 \MY.NSADDRESS))) - (printout NIL "Description: A " (L-CASE (MACHINETYPE) - T) - " (typically running Lisp)" T) - (printout NIL T T "Thank you." T T "-- " FIRSTNAME T) - (LET ((field (TEDIT.FIND *STANDARD-OUTPUT* ">>*<<" 1 NIL T))) - (if field - then (TEDIT.SETSEL *STANDARD-OUTPUT* (CAR field) - (ADD1 (DIFFERENCE (CADR field) - (CAR field))) - 'LEFT T))) - *STANDARD-OUTPUT*]) - -(AmIRegistered - [LAMBDA NIL (* ; "Edited 8-Jan-88 18:00 by Masinter") - - (CL:FLET [(OK (NAMES) - (for wsn in (CH.LIST.OBJECTS NAMES 'WORKSTATION) when (EQUALALL \MY.NSADDRESS - (LOOKUP.NS.SERVER - wsn)) - do (RETURN (LIST wsn] - (OR (AND (ETHERHOSTNAME) - (OK (ETHERHOSTNAME))) - (OK "*"]) -) - -(ADDTOVAR LAFITESPECIALFORMS ("Clearinghouse registry request" 'Requst-NS-Registry - "Make a form to request that the current machine be registered on the local Clearinghouse" - )) - -(UNMARKASCHANGED 'LAFITESPECIALFORMS 'VARS) - -(SETQ LAFITEFORMSMENU NIL) -(PUTPROPS REGISTER-MACHINE COPYRIGHT ("Xerox Corporation" 1986 1987 1988)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1131 4015 (Requst-NS-Registry 1141 . 3416) (AmIRegistered 3418 . 4013))))) -STOP diff --git a/obsolete/lispusers/SINGLEFILEINDEX b/obsolete/lispusers/SINGLEFILEINDEX deleted file mode 100644 index 98ff537c..00000000 --- a/obsolete/lispusers/SINGLEFILEINDEX +++ /dev/null @@ -1,1057 +0,0 @@ -(FILECREATED "15-Apr-88 09:50:23" {ERINYES}KOTO>SINGLEFILEINDEX.;2 41909 - - changes to: (FNS \SFI.CENTERPRINT) - - previous date: "31-Mar-86 17:15:30" {ERINYES}KOTO>LISPUSERS>SINGLEFILEINDEX.;1) - - -(* Copyright (c) 1984, 1985, 1986, 1988 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT SINGLEFILEINDEXCOMS) - -(RPAQQ SINGLEFILEINDEXCOMS [(COMS (* * -"Created by Christopher Tong and JonL White, February 1984. Heavily revised by Bill van Melle, March 1986." - ) - (* SINGLEFILEINDEX) - (FNS SINGLEFILEINDEX \SFI.Q1UP \FILELISTING SINGLEFILEINDEX2 - SINGLEFILEINDEX1 \SFI.AnalyzeLine \SFI.FLUSHFONTCHANGE - PrintFnDef INDEXCOPYBYTES INDEXNEWLINE INDEXNEWPAGE - \SFI.SORTINDEX UALPHORDERCAR \SFI.FILTER.INDEX) - (FNS PrintFileTitle \SFI.PRINT.INDEX PrintIndex - \SFI.PrintIndexFactors PrintRelativeFunctionIndex - \SFI.CENTERPRINT PRINTDOTS \SFI.LISTINGHEADER \SFI.BreakLine) - ) - (INITVARS (PRINTERDEVICEFILENAME (QUOTE {LPT})) - (RELATIVEINDEXFLG) - (SINGLEFILEINDEX.TWOSIDED) - (SINGLEFILEINDEX.DONTSPAWN) - (\SFI.PROCESS.COMMANDS) - (\SFI.PROCESSLOCK (CREATE.MONITORLOCK "SINGLEFILEINDEX")) - (\SFI.PROCESS) - (ERRORMESSAGESTREAM T)) - (ADDVARS (SINGLEFILEINDEX.TYPES (MACRO DEFMACRO) - (VAR (RPAQ RPAQ? RPAQQ ADDTOVAR) - TestForVar T) - (VAR READVARS TestForUglyVars) - (BITMAP RPAQ TestForBitmap) - (CONSTANTS CONSTANTS TestForConstants) - (RECORD (eval CLISPRECORDTYPES)) - (PROPERTY PUTPROPS TestForProp) - (COURIERPROGRAM COURIERPROGRAM) - (TEMPLATE SETTEMPLATE TestForQuotedType) - (I.S.OPR I.S.OPR TestForQuotedType) - (RESOURCES PUTDEF TestForResource) - (ADVICE READVISE)) - (SINGLEFILEINDEX.PROPERTIES (COPYRIGHT) - (READVICE ADVICE)) - (SINGLEFILEINDEX.FILTERS (VAR . CONSTANTS) - (VAR . BITMAP))) - (COMS (* "Functions that find types") - (FNS TestForType TestForQuotedType TestForVar TestForBitmap TestForProp TestForResource - TestForUglyVars TestForGenericDefinition TestForConstants SFI.WHOLE.EXPRESSION - SFI.LOOKUP.NAME)) - (DECLARE: EVAL@COMPILE DONTCOPY (MACROS .ERRORSTREAM.) - (RECORDS SFITYPE) - (FILES (IMPORT) - FILEIO) - (GLOBALVARS DEFAULTFONT NOTLISTEDFILES) - (GLOBALVARS FILERDTBL RELATIVEINDEXFLG) - (GLOBALVARS SINGLEFILEINDEX.DONTSPAWN \SFI.PROCESS.COMMANDS \SFI.PROCESSLOCK - \SFI.PROCESS SINGLEFILEINDEX.TWOSIDED SINGLEFILEINDEX.TYPES - SINGLEFILEINDEX.PROPERTIES SINGLEFILEINDEX.FILTERS FILELINELENGTH - MACROPROPS PRINTERDEVICEFILENAME) - DONTEVAL@LOAD - (SPECVARS . T)) - (COMS (FNS SFI.LISTFILES1) - (DECLARE: DOCOPY DONTEVAL@LOAD (P (MOVD? (QUOTE LISTFILES1) - (QUOTE OLDLISTFILES1)) - (/MOVD (QUOTE SFI.LISTFILES1) - (QUOTE LISTFILES1))) - (INITVARS (LINESPERPAGE 65]) - (* * -"Created by Christopher Tong and JonL White, February 1984. Heavily revised by Bill van Melle, March 1986." -) - - - - -(* SINGLEFILEINDEX) - -(DEFINEQ - -(SINGLEFILEINDEX - [LAMBDA (INF OUTF mergedIndexFlg PRINTOPTIONS) (* bvm: "28-Mar-86 17:31") - (LET ((FULL (FINDFILE INF T))) - (COND - ((NOT FULL) (* When called by LISTFILES INF will already be a full - file name) - (printout (.ERRORSTREAM.) - T INF " not found.")) - (SINGLEFILEINDEX.DONTSPAWN (SINGLEFILEINDEX2 FULL OUTF mergedIndexFlg PRINTOPTIONS)) - (T (\SFI.Q1UP (FUNCTION SINGLEFILEINDEX2) - FULL OUTF mergedIndexFlg PRINTOPTIONS) - (* Used to return NIL so that LISTFILES won't try  - removing from NOTLISTEDFILES) - FULL]) - -(\SFI.Q1UP - [LAMBDA (FUN FULL OUTF mergedIndexFlg PRINTOPTIONS) (* bvm: "15-Mar-86 17:11") - - (* * Add a command to list file FULL to OUTF applying FUN) - - - (WITH.MONITOR \SFI.PROCESSLOCK (* Lock protects \SFI.PROCESS.COMMANDS and  - \SFI.PROCESS) - [COND - ((AND \SFI.PROCESS (NOT (FIND.PROCESS \SFI.PROCESS))) - (* Process died, flush handle and any old listing  - requests) - (SETQ \SFI.PROCESS (SETQ \SFI.PROCESS.COMMANDS NIL] - (SETQ \SFI.PROCESS.COMMANDS (NCONC1 \SFI.PROCESS.COMMANDS - (LIST FUN FULL OUTF mergedIndexFlg - PRINTOPTIONS))) - (COND - ((NULL \SFI.PROCESS) - (SETQ \SFI.PROCESS (ADD.PROCESS (LIST (FUNCTION \FILELISTING)) - (QUOTE BEFOREEXIT) - (QUOTE DON'T]) - -(\FILELISTING - [LAMBDA NIL (* bvm: "15-Mar-86 16:58") - - (* * Process that takes listing commands from \SFI.PROCESS.COMMANDS and performs them) - - - (WITH.MONITOR \SFI.PROCESSLOCK (* Lock protects \SFI.PROCESS.COMMANDS and  - \SFI.PROCESS) - (while \SFI.PROCESS.COMMANDS bind FORM - do (SETQ FORM (pop \SFI.PROCESS.COMMANDS)) - (RELEASE.MONITORLOCK \SFI.PROCESSLOCK) - (* Release lock while listing so that others can add  - to my queue) - (APPLY (CAR FORM) - (CDR FORM)) - (OBTAIN.MONITORLOCK \SFI.PROCESSLOCK) - finally (* Nothing left to do, so exit) - (SETQ \SFI.PROCESS NIL]) - -(SINGLEFILEINDEX2 - [LAMBDA (FULL OUTF mergedIndexFlg PRINTOPTIONS) (* bvm: "28-Mar-86 17:44") - - (* * Process a single file FULL to OUTF with options. SINGLEFILEINDEX should have already computed the fullname of  - the input file) - - - (COND - ((COND - ((SINGLEFILEINDEX1 FULL OUTF mergedIndexFlg PRINTOPTIONS) - (AND (NULL OUTF) - (printout (.ERRORSTREAM.) - T "indexed version of " FULL " => " PRINTERDEVICEFILENAME)) - T) - (OUTF (printout (.ERRORSTREAM.) - T FULL " is not LISPSOURCEFILEP -- COPYFILE being called")) - (T (OLDLISTFILES1 FULL PRINTOPTIONS))) (* Do this here since there is little coordination  - between the various multiple processes which are  - listing files) - (SETQ NOTLISTEDFILES (REMOVE (ROOTFILENAME FULL) - NOTLISTEDFILES)) - NIL]) - -(SINGLEFILEINDEX1 - [LAMBDA (FULL OUTF RETINDEXFLG PRINTOPTIONS) (* bvm: "31-Mar-86 15:53") - - (* Makes an indexed file (default is the line printer). The index file will have a number of indices, one for each  - type in INDEXEDTYPESLIST. Each type index will list all the items of that type NIL in alphabetical order and the  - page number of where that item's definition is in the file. - - NOTE1: The indices will be printed last. - - NOTE2: The index file is not "loadable" into LISP.) - - - (DECLARE (SPECVARS FULL) - (USEDFREE LINESPERPAGE)) - (RESETLST (PROG ((LINESPERPAGE LINESPERPAGE) - [typesLST (OR (NULL RELATIVEINDEXFLG) - (EQ RELATIVEINDEXFLG (QUOTE BOTH] - (FNUM 0) - (SOURCESTREAM) - (PAGECOUNT) - (LINECOUNT 1) - (ItemPages) - (INDICES) - lastPage MAP FULLEOLC COMS currentItem nextFnGroup nextFnStart FNSMAPSL TEM) - (DECLARE (SPECVARS MAP LINECOUNT PAGECOUNT LINESPERPAGE SOURCESTREAM - ItemPages typesLST FNUM currentItem linePos newPos - INDICES)) - - (* * Specials are as follows - - SOURCESTREAM -- stream on the input file being formatted - - currentItem -- function, etc currently being printed - - FNUM -- ordinal number of function currently being printed, when RELATIVEINDEXFLG - - PAGECOUNT -- number of current page - - LINECOUNT -- number of current line on page - - ItemPages -- list of (name type page#) constituting the actual index) - - - [RESETSAVE (SETQ SOURCESTREAM (OPENSTREAM FULL (QUOTE INPUT) - (QUOTE OLD))) - (QUOTE (PROGN (CLOSEF? OLDVALUE] - (SETQ FULL (FULLNAME SOURCESTREAM)) - (COND - ([EQ FULL (CAR (SETQ TEM (LISTP (GETP (ROOTFILENAME FULL) - (QUOTE FILEMAP] - (* It appears as though the file has already been  - loaded in some way so that the MAP is already loaded) - (SETQ MAP (CADR TEM))) - ((NULL USEMAPFLG) - (RESETSAVE NIL (QUOTE (SETQ USEMAPFLG))) - (* Really should bind USEMAPFLG to T but this works if - the system still thinks it's a globalvar) - (SETQ USEMAPFLG T))) - (COND - ([OR (AND (NOT (RANDACCESSP SOURCESTREAM)) - (OR typesLST (NULL MAP))) - (AND (NULL MAP) - (NULL (SETQ MAP (GETFILEMAP FULL))) - (NOT (LISPSOURCEFILEP FULL] - (* We just let the "old" listfiles do it when the file - isn't RANDACCESSP or when it's probably some kind of  - binary file) - (RETURN))) - (OR OUTF (SETQ OUTF PRINTERDEVICEFILENAME)) - [COND - [(OPENP OUTF (QUOTE OUTPUT)) - (RESETSAVE (OUTPUT (SETQ OUTF (GETSTREAM OUTF (QUOTE OUTPUT] - (T (RESETSAVE [OUTPUT (SETQ OUTF (OPENSTREAM OUTF (QUOTE OUTPUT) - (QUOTE NEW] - (QUOTE (PROGN (CLOSEF? (OUTPUT OLDVALUE] - [STREAMPROP OUTF (QUOTE PRINTOPTIONS) - (APPEND PRINTOPTIONS (LIST (QUOTE DOCUMENT.NAME) - FULL) - (STREAMPROP OUTF (QUOTE PRINTOPTIONS] - (* Make sure printer knows original name of file) - (RESETSAVE (RADIX 10)) - (SETQ LINESPERPAGE (OR (GETFILEINFO OUTF (QUOTE PAGEHEIGHT)) - LINESPERPAGE)) - (* Determine printing parameters.) - (RESETSAVE (LINELENGTH 1000 OUTF)) - (COND - (RELATIVEINDEXFLG (* All index info up front, derived from file map, no  - absolute page numbers) - (PrintFileTitle FULL (GETFILEINFO SOURCESTREAM - (QUOTE - CREATIONDATE))) - (PrintRelativeFunctionIndex MAP))) - [COND - (typesLST (SETQ typesLST - (for ENTRY in SINGLEFILEINDEX.TYPES - collect (COND - ((EQ (CAR (LISTP (fetch (SFITYPE - PATTERNS) - of ENTRY))) - (QUOTE eval)) - (create SFITYPE - PATTERNS _(EVAL - (CADR (fetch (SFITYPE PATTERNS) - of ENTRY))) - reusing ENTRY)) - (T ENTRY] - (PROGN (SETQ FNSMAPSL (CDR MAP)) - (SETQ FULLEOLC (fetch EOLCONVENTION of SOURCESTREAM)) - (SETQ PAGECOUNT 1) - (SETQ nextFnGroup (CDDR (CAR FNSMAPSL))) - (SETQ nextFnStart (CADAR nextFnGroup))) - - (* * Locate and print definitions for each item.) - - - (bind linePos newPos (currentPos _ 0) - [EOL _(SELECTC FULLEOLC - [CR.EOLC (CONCATCODES (CHARCODE (CR] - [LF.EOLC (CONCATCODES (CHARCODE (LF] - (CONCATCODES (CHARCODE (CR LF] - while (SETQ newPos (FILEPOS EOL SOURCESTREAM currentPos)) - do (* currentPos = how far we have copied; - linePos = start of current line; - newPos = start of next line) - (SETFILEPTR SOURCESTREAM (SETQ linePos currentPos)) - (COND - ([COND - [(EQ (PEEKCCODE SOURCESTREAM) - (CHARCODE ^F)) - (* Line might start with a fontchange sequence) - (\SFI.FLUSHFONTCHANGE SOURCESTREAM) - (* Advance linePos to after any font change chars) - (AND nextFnStart (OR (IEQP linePos nextFnStart) - (IEQP currentPos nextFnStart] - (T (AND nextFnStart (IEQP linePos nextFnStart] - (* Index and print function group.) - (for function in nextFnGroup do (SETQ newPos - (PrintFnDef function - OUTF))) - (* Should point us at the first of two closing parens) - (pop FNSMAPSL) - (SETQ nextFnGroup (CDDAR FNSMAPSL)) - (SETQ nextFnStart (CADAR nextFnGroup))) - (T (* Print and index (when appropriate) next line.) - (SELECTC FULLEOLC - (CRLF.EOLC (READC SOURCESTREAM) - (add newPos 1)) - 0) - (COND - (typesLST (\SFI.AnalyzeLine SOURCESTREAM typesLST))) - (INDEXCOPYBYTES SOURCESTREAM OUTF currentPos newPos) - (* Print the line.) - (INDEXNEWLINE))) - (SETQ currentPos (ADD1 newPos))) - (SETQ lastPage PAGECOUNT) - - (* * Print file index or indices.) - - - (COND - ((OR (NULL RELATIVEINDEXFLG) - (EQ RELATIVEINDEXFLG (QUOTE BOTH))) - (SETQ INDICES (\SFI.SORTINDEX ItemPages)) - [LET ((VARS (ASSOC (QUOTE VAR) - INDICES))) - (* Manually filter out the filecoms var) - (RPLACD VARS (DREMOVE (ASSOC (FILECOMS FULL) - (CDR VARS)) - (CDR VARS] - (\SFI.FILTER.INDEX INDICES) - (INDEXNEWPAGE T) - (COND - ((AND (EVENP PAGECOUNT) - SINGLEFILEINDEX.TWOSIDED) - (* Ensure that the index will not be on the back-side  - of a two-sided listing) - (INDEXNEWPAGE T))) - (PrintFileTitle FULL (GETFILEINFO SOURCESTREAM (QUOTE CREATIONDATE)) - ) - (\SFI.PRINT.INDEX INDICES))) - (RETURN (COND - (RETINDEXFLG (CONS FULL INDICES)) - (T FULL]) - -(\SFI.AnalyzeLine - [LAMBDA (SOURCESTREAM TYPETRIPLES FLG) (* bvm: "30-Mar-86 15:07") - - (* * Retrieve line as string, beginning with first character that isn't a font change char,) - - - (DECLARE (USEDFREE ItemPages)) - (SELECTQ (GETSYNTAX (READCCODE SOURCESTREAM) - FILERDTBL) - [(LEFTPAREN LEFTBRACKET) (* Note that if the first character on the line isn't  - a parens then this line can't be the start of anything - interesting) - (COND - ((EQ (PEEKCCODE SOURCESTREAM) - (CHARCODE ^F)) - - (* It is possible to have a fontchange sequence just after the open parens, though most forms reserve the font  - change for the named object, coming up next) - - - (\SFI.FLUSHFONTCHANGE SOURCESTREAM))) - (LET ((FN (READ SOURCESTREAM FILERDTBL)) - HERE PAT MOVED? ITEMNAME) - (SETQ HERE (GETFILEPTR SOURCESTREAM)) - (for ENTRY in TYPETRIPLES when (COND - ((EQ (SETQ PAT (fetch - (SFITYPE PATTERNS) - of ENTRY)) - T) - (* Matches anything -- TESTFN must be doing all the  - work) - T) - ((LISTP PAT) - (MEMB FN PAT)) - (T (EQ FN PAT))) - do (* ENTRY thinks this line might be interesting) - (COND - (MOVED? (* Previous test may have moved the file pointer, so  - bring it back) - (SETFILEPTR SOURCESTREAM HERE) - (SETQ MOVED? NIL))) - [COND - ([SETQ ITEMNAME (CAR (NLSETQ - (APPLY* (OR (fetch (SFITYPE TESTFN) - of ENTRY) - (FUNCTION TestForType)) - SOURCESTREAM FN ENTRY] - [COND - ((NLISTP ITEMNAME) (* Single object to be indexed as the type in ENTRY) - (push ItemPages (LIST (LET ((TYPE (fetch (SFITYPE NAME) - of ENTRY))) - (OR (CAR (LISTP TYPE)) - TYPE)) - ITEMNAME PAGECOUNT))) - (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 ItemPages (LIST (CAR PAIR) - NAME PAGECOUNT] - (COND - ((NOT (fetch (SFITYPE AMBIGUOUS?) of ENTRY)) - (RETURN] - (SETQ MOVED? T] - ((RIGHTPAREN RIGHTBRACKET) (* Well, some lines will be the closing of a DEFINEQ  - or a DECLARE: or whatever) - NIL) - NIL]) - -(\SFI.FLUSHFONTCHANGE - [LAMBDA (STREAM) (* bvm: "15-Mar-86 17:41") - (while (EQ (PEEKCCODE STREAM) - (CHARCODE ^F)) - do (READCCODE STREAM) - (READCCODE STREAM) - (add linePos 2]) - -(PrintFnDef - [LAMBDA (FNDEF OUTSTREAM) - (DECLARE (USEDFREE ItemPages FNUM SOURCESTREAM PAGECOUNT LINESPERPAGE LINECOUNT) - (SPECVARS currentItem)) (* bvm: "28-Mar-86 17:41") - - (* * Prints a FNDEF definition on the file OUTSTREAM - - FNDEF is map entry of form (name start . end)) - - - (PROG ((END (CDDR FNDEF)) - (currentItem (CAR FNDEF))) - (add FNUM 1) - (INDEXNEWLINE) - (COND - (RELATIVEINDEXFLG (printout NIL .SP (IDIFFERENCE FILELINELENGTH (IPLUS - 2 - (NCHARS FNUM))) - .FONT BOLDFONT "[" FNUM "]" .FONT DEFAULTFONT .RESET))) - (INDEXNEWLINE) - (COND - ((NOT (ILEQ (IPLUS LINECOUNT 3) - LINESPERPAGE)) - (INDEXNEWPAGE))) - (push ItemPages (LIST (QUOTE FUNCTION) - currentItem PAGECOUNT)) - (* Print out function.) - (INDEXCOPYBYTES SOURCESTREAM OUTSTREAM (CADR FNDEF) - END) - (RETURN END]) - -(INDEXCOPYBYTES - [LAMBDA (IN OUT START END) - (DECLARE (USEDFREE LINECOUNT LINESPERPAGE)) (* bvm: "15-Mar-86 17:50") - - (* This is similar to COPYBYTES except that, INDEXNEWLINE is called whenever an EOL is read, and IndexNewPage is  - called whenever a form feed is read) - - - (SETFILEPTR IN START) - [PROG ((INSTRM (GETSTREAM IN (QUOTE INPUT))) - (OUTSTRM (GETSTREAM OUT (QUOTE OUTPUT))) - EOLC NLFLG LOOKFORLF CH) - (SETQ EOLC (fetch EOLCONVENTION of INSTRM)) - (FRPTQ (IDIFFERENCE END START) - (SELCHARQ (SETQ CH (BIN INSTRM)) - [CR (SELECTC EOLC - [CR.EOLC (SETQ LOOKFORLF NIL) - (COND - ((AND NLFLG (IGREATERP LINECOUNT - (IDIFFERENCE - LINESPERPAGE 5)) - ) - (* double cr near end of page) - (INDEXNEWPAGE) - (SETQ NLFLG NIL)) - (T (INDEXNEWLINE) - (SETQ NLFLG T] - (CRLF.EOLC - - (* Flag says that EOLC is CRLF and we are looking for next char to be LF. Expanded out this way so that we can keep - track of the character counts accurately) - - - (SETQ LOOKFORLF T)) - (PROGN (SETQ LOOKFORLF NIL) - (\OUTCHAR OUTSTRM (CHARCODE CR] - (LF [COND - [(OR LOOKFORLF (EQ EOLC LF.EOLC)) - (COND - ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE - LINESPERPAGE 5))) - (* double cr near end of page) - (INDEXNEWPAGE) - (SETQ NLFLG NIL)) - (T (INDEXNEWLINE) - (SETQ NLFLG T] - (T (\OUTCHAR OUTSTRM (CHARCODE LF)) - (* If LF comes thru, it is just a vertical tab. - Want to keep horizontal position the same, but update  - line-counts) - (COND - ((AND NLFLG (IGREATERP LINECOUNT (IDIFFERENCE - LINESPERPAGE 5))) - (* double cr near end of page) - (INDEXNEWPAGE) - (SETQ NLFLG NIL)) - (T (COND - ((IGREATERP (add LINECOUNT 1) - LINESPERPAGE) - (INDEXNEWPAGE))) - (SETQ NLFLG T] - (SETQ LOOKFORLF NIL)) - (FF (INDEXNEWPAGE) - (SETQ NLFLG NIL) - (SETQ LOOKFORLF NIL)) - (PROGN (\BOUT OUTSTRM CH) - (SETQ NLFLG NIL) - (SETQ LOOKFORLF NIL] - T]) - -(INDEXNEWLINE - [LAMBDA (DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:04") - (TERPRI) - (COND - ((IGREATERP (add LINECOUNT 1) - LINESPERPAGE) - (INDEXNEWPAGE DontPrintPageNbrFlg]) - -(INDEXNEWPAGE - [LAMBDA (DontPrintPageNbrFlg) (* JonL "13-Mar-84 22:04") - (PRIN3 (FCHARACTER (CHARCODE FF))) - (POSITION NIL 0) - (SETQ LINECOUNT 0) - (COND - (PAGECOUNT (add PAGECOUNT 1))) - (\SFI.LISTINGHEADER DontPrintPageNbrFlg]) - -(\SFI.SORTINDEX - [LAMBDA (TRIPLES) (* bvm: "29-Mar-86 17:26") - - (* * Sort 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), with each entry looking like (name . pagenumbers)) - - - (LET ([TYPENAMES (CONS (QUOTE FUNCTION) - (for X in SINGLEFILEINDEX.TYPES collect (CAR X] - RESULT INDEX OLDNAME) - [for TRIP in TRIPLES - do [COND - ((NULL (SETQ INDEX (ASSOC (CAR TRIP) - RESULT))) - (push RESULT (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] - (for PAIR in RESULT do (SORT (CDR PAIR) - (FUNCTION UALPHORDERCAR))) - (SORT RESULT (FUNCTION (LAMBDA (X Y) (* X is before Y if its car appears before Y's in  - TYPENAMES) - (FMEMB (CAR Y) - (CDR (FMEMB (CAR X) - TYPENAMES]) - -(UALPHORDERCAR - [LAMBDA (A B) (* JonL " 7-Mar-84 19:52") - (* does case independent sort on the CAR of two  - elements.) - (UALPHORDER (CAR A) - (CAR B]) - -(\SFI.FILTER.INDEX - [LAMBDA (INDICES) (* bvm: "30-Mar-86 14:11") - - (* * Remove redundancies from the prepared INDICES) - - - (DECLARE (SPECVARS INDICES)) (* For SFI.LOOKUP.NAME) - (for TYPEPAIR in INDICES bind FILTERS when [SETQ FILTERS (for FILTER in - SINGLEFILEINDEX.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) - (SFI.LOOKUP.NAME - (CAR PAIR) - F)) - (T (APPLY* (CAR F) - PAIR]) -) -(DEFINEQ - -(PrintFileTitle - [LAMBDA (FILENAME DATE) (* bvm: "15-Mar-86 17:17") - - (* * Print FILENAME title. Should not be called unless FILENAME is essentially "at the top of the page") - - - (\SFI.CENTERPRINT (CONCAT FILENAME " " DATE) - T) - (\SFI.CENTERPRINT (CONCAT "-- Listed on " (DATE) - " --")) - (INDEXNEWLINE]) - -(\SFI.PRINT.INDEX - [LAMBDA (INDICES) (* bvm: "30-Mar-86 15:52") - - (* * For each (type . entries) pair in INDICES print a pretty index for the items of the type) - - - (for PAIR in INDICES when (CDR PAIR) - do (PrintIndex (CDR PAIR) - lastPage - (CAR PAIR)) - (INDEXNEWLINE T)) - (\SFI.BreakLine]) - -(PrintIndex - [LAMBDA (INDEXPAIRS MaxIndexNo TYPE) (* bvm: "30-Mar-86 15:34") - - (* * print index of items in IndexedList.) - - - (DECLARE (USEDFREE LINESPERPAGE LINECOUNT)) - (PROG ([INDEXNOWIDTH (COND - ((ILESSP MaxIndexNo 10) - 1) - ((ILESSP MaxIndexNo 100) - 2) - (T (NCHARS MaxIndexNo] - NCOLUMNS NROWS WIDTH LEFT SPACING NROWSREMAINING LastItem) - (DECLARE (SPECVARS NCOLUMNS LEFT WIDTH SPACING NROWS)) - (SETQ WIDTH (IPLUS (for PAIR in INDEXPAIRS bind - largest (PLUS (NCHARS (CAR PAIR)) - (COND - ((CDDR PAIR) - (* When multiple page nos, must count the extra pages, - plus an additional char each for the separating comma) - (ITIMES (LENGTH (CDDR PAIR)) - (IPLUS 1 INDEXNOWIDTH))) - (T 0))) - finally (RETURN $$EXTREME)) - INDEXNOWIDTH 1)) (* WIDTH is the widest any entry gets: name plus page  - numbers) - (\SFI.PrintIndexFactors INDEXPAIRS) (* Compute NCOLUMNS LEFT WIDTH SPACING NROWS) - (SETQ NROWSREMAINING NROWS) - (AND TYPE (\SFI.BreakLine)) (* When TYPE is non-null, call is from  - PrintOneTypeIndex) - (INDEXNEWLINE T) - (COND - (TYPE [COND - ((AND (IGREATERP (IPLUS NROWS 3) - (IDIFFERENCE LINESPERPAGE LINECOUNT)) - (IGREATERP LINECOUNT (LRSH LINESPERPAGE 1))) - - (* * Don't start an indexing on the bottom half of a page which is going to cross a page boundary before the  - "breaker") - - - (INDEXNEWPAGE T) - (AND TYPE (\SFI.BreakLine] - (\SFI.CENTERPRINT (CONCAT TYPE " INDEX") - T T) - (INDEXNEWLINE T))) - (while INDEXPAIRS - do (SETQ NROWS (IMIN NROWSREMAINING (IDIFFERENCE LINESPERPAGE LINECOUNT))) - (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)) - (LET* ((ITEM (CAR LastItem)) - (LABEL (CAR ITEM)) - (PAGENO (CDR ITEM))) - [SETQ PAGENO - (COND - [(LISTP PAGENO) - (* More than one occurrence) - (CONCATLIST (CDR (for P in PAGENO - join (LIST "," P] - (T (MKSTRING PAGENO] - (printout NIL .FONT DEFAULTFONT LABEL ,) - (PRINTDOTS (IDIFFERENCE (IDIFFERENCE - WIDTH - (ADD1 (NCHARS LABEL))) - (NCHARS PAGENO))) - (PRIN1 PAGENO) - (COND - ((NEQ COLUMN NCOLUMNS) - (SPACES SPACING] - (add NEXTINDEX NROWS)) - (INDEXNEWLINE T)) - (COND - ((SETQ INDEXPAIRS (CDR LastItem)) - (INDEXNEWPAGE T) - (SETQ NROWSREMAINING (ADD1 (IQUOTIENT (LENGTH INDEXPAIRS) - NCOLUMNS]) - -(\SFI.PrintIndexFactors - [LAMBDA (IndexedList) (* bvm: "30-Mar-86 15:00") - (DECLARE (USEDFREE NCOLUMNS LEFT WIDTH SPACING NROWS)) - (LET ((LEN (LENGTH IndexedList))) - [SETQ NCOLUMNS (IMAX 1 (IMIN LEN (IQUOTIENT FILELINELENGTH (IPLUS WIDTH 2] - (* Number of columns that fit if you allow 2 spaces  - between columns) - (SETQ NROWS (IQUOTIENT (IPLUS LEN (SUB1 NCOLUMNS)) - NCOLUMNS)) - (SETQ NCOLUMNS (IQUOTIENT (IPLUS LEN (SUB1 NROWS)) - NROWS)) (* This might reduce the number of columns if all the  - items, printed in NROWS rows, take fewer columns than  - originally allocated) - (SETQ LEFT (IDIFFERENCE FILELINELENGTH (ITIMES (IPLUS WIDTH 2) - NCOLUMNS))) - (* LEFT is number of spaces remaining after allocating - the columns) - (COND - ((EQ NCOLUMNS 1) (* Only one column, so either make it half the page  - width or the full width) - [SETQ WIDTH (COND - ((GREATERP WIDTH (IQUOTIENT FILELINELENGTH 2)) - FILELINELENGTH) - (T (IQUOTIENT FILELINELENGTH 2] - (SETQ SPACING 0)) - (T (SETQ WIDTH (IMIN (IPLUS WIDTH (IQUOTIENT LEFT 2)) - (IDIFFERENCE (IQUOTIENT FILELINELENGTH NCOLUMNS) - 2))) (* Spaces LEFT gets divided between the dots an the  - between-column spaces.) - (SETQ SPACING (COND - ((EQ NCOLUMNS 1) - 0) - (T (IQUOTIENT (IDIFFERENCE FILELINELENGTH (ITIMES WIDTH NCOLUMNS)) - (SUB1 NCOLUMNS]) - -(PrintRelativeFunctionIndex - [LAMBDA (MAP) (* bvm: "31-Mar-86 15:59") - - (* * Create and print an index for the functions on the file.) - - - (PROG ((MaxIndexNo 0) - IndexedList currentItem) - [SETQ IndexedList (for DFQ in MAP join (for function in (CDDR DFQ) - collect (LIST (CAR function) - (add MaxIndexNo 1] - (* Printout function index.) - (COND - ((NOT IndexedList) - (INDEXNEWLINE T) - (INDEXNEWLINE T) - (printout NIL .FONT BOLDFONT "No Functions." .FONT DEFAULTFONT)) - (T (PrintIndex (SORT IndexedList (FUNCTION UALPHORDERCAR)) - MaxIndexNo))) - (INDEXNEWPAGE T) - (RETURN MAP]) - -(\SFI.CENTERPRINT - [LAMBDA (STR BOLDFLG DontPrintPageNbrFlg) (* //Z\\ "15-Apr-88 09:49") - (* JonL "13-Mar-84 22:07") - (* Be sure to only TAB with a positive index) - (TAB (IQUOTIENT (if (IGREATERP FILELINELENGTH (NCHARS STR)) - then (IDIFFERENCE FILELINELENGTH (NCHARS STR)) - else 0) - 2)) - (COND - (BOLDFLG (printout NIL .FONT BOLDFONT STR .FONT DEFAULTFONT)) - (T (printout NIL STR))) - (INDEXNEWLINE DontPrintPageNbrFlg]) - -(PRINTDOTS - [LAMBDA (N FILE) (* bvm: "15-Mar-86 16:28") - (LET [(STRM (GETSTREAM FILE (QUOTE OUTPUT] - (FRPTQ N (\OUTCHAR STRM (CHARCODE %.]) - -(\SFI.LISTINGHEADER - [LAMBDA (dontPrintPageNumberFlg) (* cht: " 5-JAN-84 15:15") - (COND - (FULL (PRIN1 FULL))) - (COND - ((AND currentItem FNUM RELATIVEINDEXFLG) - (printout NIL " (" .P2 currentItem "[" FNUM "] cont.)")) - (currentItem (printout NIL " (" .P2 currentItem " cont.)"))) - (TAB (IDIFFERENCE FILELINELENGTH 9) - T) - (COND - ((AND PAGECOUNT (NOT dontPrintPageNumberFlg)) - (PRIN1 "Page ") - (PRINTNUM (QUOTE (FIX 4)) - PAGECOUNT))) - (INDEXNEWLINE) - (INDEXNEWLINE]) - -(\SFI.BreakLine - [LAMBDA NIL (* bvm: "15-Mar-86 16:28") - (INDEXNEWLINE T) - [LET [(STRM (GETSTREAM NIL (QUOTE OUTPUT] - (FRPTQ FILELINELENGTH (\OUTCHAR STRM (CHARCODE ~] - (INDEXNEWLINE T]) -) - -(RPAQ? PRINTERDEVICEFILENAME (QUOTE {LPT})) - -(RPAQ? RELATIVEINDEXFLG ) - -(RPAQ? SINGLEFILEINDEX.TWOSIDED ) - -(RPAQ? SINGLEFILEINDEX.DONTSPAWN ) - -(RPAQ? \SFI.PROCESS.COMMANDS ) - -(RPAQ? \SFI.PROCESSLOCK (CREATE.MONITORLOCK "SINGLEFILEINDEX")) - -(RPAQ? \SFI.PROCESS ) - -(RPAQ? ERRORMESSAGESTREAM T) - -(ADDTOVAR SINGLEFILEINDEX.TYPES (MACRO DEFMACRO) - (VAR (RPAQ RPAQ? RPAQQ ADDTOVAR) - TestForVar T) - (VAR READVARS TestForUglyVars) - (BITMAP RPAQ TestForBitmap) - (CONSTANTS CONSTANTS TestForConstants) - (RECORD (eval CLISPRECORDTYPES)) - (PROPERTY PUTPROPS TestForProp) - (COURIERPROGRAM COURIERPROGRAM) - (TEMPLATE SETTEMPLATE TestForQuotedType) - (I.S.OPR I.S.OPR TestForQuotedType) - (RESOURCES PUTDEF TestForResource) - (ADVICE READVISE)) - -(ADDTOVAR SINGLEFILEINDEX.PROPERTIES (COPYRIGHT) - (READVICE ADVICE)) - -(ADDTOVAR SINGLEFILEINDEX.FILTERS (VAR . CONSTANTS) - (VAR . BITMAP)) - - - -(* "Functions that find types") - -(DEFINEQ - -(TestForType - [LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 13:20") - - (* * Default testfn for types that are dumped in a form whose second element is the object's name) - - - (LET ((NAME (READ STREAM FILERDTBL))) - (AND NAME (LITATOM NAME) - NAME]) - -(TestForQuotedType - [LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 13:29") - - (* * Like TestForType, but tests for something where the second element of the form is the quoted name.) - - - (LET ((NAME (READ STREAM FILERDTBL))) - (AND (EQ (CAR (LISTP NAME)) - (QUOTE QUOTE)) - (CADR NAME]) - -(TestForVar - [LAMBDA (STREAM FN TRIPLE) (* bvm: "29-Mar-86 17:02") - - (* * Called for expressions whose car is one of RPAQ, RPAQQ, RPAQ?, ADDTOVAR -- read the variable name following  - it. Filters after the fact will remove duplications with other variable types) - - - (LET (NAME) - (COND - ([AND (SETQ NAME (READ STREAM FILERDTBL)) - (LITATOM NAME) - (NEQ NAME T) - (NOT (FMEMB NAME (QUOTE (GLOBALVARS SPECVARS LOCALVARS NLAMA NLAML LAMA] - (* Ignore compiler-internal vars) - NAME]) - -(TestForBitmap - [LAMBDA (STREAM FN TRIPLE) (* bvm: "28-Mar-86 17:06") - - (* * Called on (RPAQ --) in case the expression is (RPAQ var (READBITMAP))) - - - (LET ((NAME (READ STREAM FILERDTBL)) - CHAR) - (COND - ([AND NAME (LITATOM NAME) - (EQ (SETQ CHAR (SKIPSEPRCODES STREAM FILERDTBL)) - (CHARCODE "(")) - (PROGN (READCCODE STREAM) (* After the VARS name is the form  - (READBITMAP ...)) - (EQ (RATOM STREAM FILERDTBL) - (QUOTE READBITMAP] - NAME]) - -(TestForProp - [LAMBDA (STREAM FN TRIPLE) (* bvm: "31-Mar-86 12:13") - - (* * Called when given a PUTPROPS expression. Determine what type it is by looking at the property name. - If no more specific type known, then index it as a PROPERTY) - - - (LET ((NAME (READ STREAM FILERDTBL)) - (PROP (READ STREAM FILERDTBL))) (* See if PROP means something more specific than  - "property") - (COND - ((MEMB PROP MACROPROPS) (* Do macros in line so that MACRONAMES can be  - dynamically changed.) - (LIST (QUOTE MACRO) - NAME)) - (T (for PAIR in SINGLEFILEINDEX.PROPERTIES when (EQ (CAR PAIR) - PROP) - do (* Index it under this other type) - (RETURN (AND (CADR PAIR) - (LIST (CADR PAIR) - NAME))) - finally (* Nothing better, so index it as having a property) - (RETURN NAME]) - -(TestForResource - [LAMBDA (STREAM FN TRIPLE) (* bvm: "28-Mar-86 17:08") - (TestForGenericDefinition STREAM FN (QUOTE ((RESOURCES GLOBALRESOURCES]) - -(TestForUglyVars - [LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 15:42") - - (* * Uglyvars are dumped as (READVARS var1 var2 ...)) - - - (CONS (QUOTE VAR) - (CDR (SFI.WHOLE.EXPRESSION STREAM]) - -(TestForGenericDefinition - [LAMBDA (STREAM FN TRIPLE) (* bvm: "31-Mar-86 12:02") - - (* * Tests to see if expression is of the form (PUTDEF (QUOTE name) (QUOTE type) (QUOTE value)) where type is one  - specified in TRIPLE) - - - (LET ((DESIREDTYPE (CAR TRIPLE)) - NAME TYPE) - (COND - ([AND (PROGN (* After the PUTDEF should find  - (QUOTE name)) - (EQ [CAR (LISTP (SETQ NAME (READ STREAM FILERDTBL] - (QUOTE QUOTE))) - (PROGN (* then (QUOTE DESIREDTYPE)) - (EQ [CAR (LISTP (SETQ TYPE (READ STREAM FILERDTBL] - (QUOTE QUOTE))) - (OR (EQ [SETQ TYPE (CAR (LISTP (CDR TYPE] - DESIREDTYPE) - (AND (LISTP DESIREDTYPE) - (MEMB TYPE DESIREDTYPE] - (CADR NAME]) - -(TestForConstants - [LAMBDA (STREAM FN TRIPLE) (* bvm: "30-Mar-86 14:17") - - (* * 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 (SFI.WHOLE.EXPRESSION STREAM)) collect (COND - ((LISTP X) - (CAR X)) - (T X]) - -(SFI.WHOLE.EXPRESSION - [LAMBDA (STREAM) (* bvm: "30-Mar-86 13:34") - (DECLARE (USEDFREE linePos)) - - (* * Called by testfns that want to see the whole expression) - - - (SETFILEPTR STREAM linePos) - (READ STREAM FILERDTBL]) - -(SFI.LOOKUP.NAME - [LAMBDA (NAME TYPE) (* bvm: "30-Mar-86 13:44") - (ASSOC NAME (CDR (ASSOC TYPE INDICES]) -) -(DECLARE: EVAL@COMPILE DONTCOPY -(DECLARE: EVAL@COMPILE -(PUTPROPS .ERRORSTREAM. MACRO (NIL (SELECTQ ERRORMESSAGESTREAM (T PROMPTWINDOW) - ERRORMESSAGESTREAM))) -) - -[DECLARE: EVAL@COMPILE - -(RECORD SFITYPE (NAME PATTERNS TESTFN AMBIGUOUS?)) -] - -(FILESLOAD (IMPORT) - FILEIO) - -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS DEFAULTFONT NOTLISTEDFILES) -) - -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS FILERDTBL RELATIVEINDEXFLG) -) - -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS SINGLEFILEINDEX.DONTSPAWN \SFI.PROCESS.COMMANDS \SFI.PROCESSLOCK \SFI.PROCESS - SINGLEFILEINDEX.TWOSIDED SINGLEFILEINDEX.TYPES SINGLEFILEINDEX.PROPERTIES - SINGLEFILEINDEX.FILTERS FILELINELENGTH MACROPROPS PRINTERDEVICEFILENAME) -) -DONTEVAL@LOAD -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(SPECVARS . T) -) -) -(DEFINEQ - -(SFI.LISTFILES1 - [LAMBDA (FILE PRINTOPTIONS) (* rmk: "26-Feb-85 10:36") - (SINGLEFILEINDEX FILE NIL NIL PRINTOPTIONS]) -) -(DECLARE: DOCOPY DONTEVAL@LOAD -(MOVD? (QUOTE LISTFILES1) - (QUOTE OLDLISTFILES1)) -(/MOVD (QUOTE SFI.LISTFILES1) - (QUOTE LISTFILES1)) - - -(RPAQ? LINESPERPAGE 65) -) -(PUTPROPS SINGLEFILEINDEX COPYRIGHT ("Xerox Corporation" 1984 1985 1986 1988)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (3020 25431 (SINGLEFILEINDEX 3030 . 3773) (\SFI.Q1UP 3775 . 4729) (\FILELISTING 4731 . -5618) (SINGLEFILEINDEX2 5620 . 6523) (SINGLEFILEINDEX1 6525 . 14860) (\SFI.AnalyzeLine 14862 . 17966) -(\SFI.FLUSHFONTCHANGE 17968 . 18246) (PrintFnDef 18248 . 19344) (INDEXCOPYBYTES 19346 . 22103) ( -INDEXNEWLINE 22105 . 22350) (INDEXNEWPAGE 22352 . 22669) (\SFI.SORTINDEX 22671 . 24007) (UALPHORDERCAR - 24009 . 24309) (\SFI.FILTER.INDEX 24311 . 25429)) (25432 34128 (PrintFileTitle 25442 . 25842) ( -\SFI.PRINT.INDEX 25844 . 26259) (PrintIndex 26261 . 29594) (\SFI.PrintIndexFactors 29596 . 31498) ( -PrintRelativeFunctionIndex 31500 . 32356) (\SFI.CENTERPRINT 32358 . 33005) (PRINTDOTS 33007 . 33228) ( -\SFI.LISTINGHEADER 33230 . 33837) (\SFI.BreakLine 33839 . 34126)) (35163 40656 (TestForType 35173 . -35494) (TestForQuotedType 35496 . 35877) (TestForVar 35879 . 36548) (TestForBitmap 36550 . 37165) ( -TestForProp 37167 . 38291) (TestForResource 38293 . 38490) (TestForUglyVars 38492 . 38754) ( -TestForGenericDefinition 38756 . 39712) (TestForConstants 39714 . 40177) (SFI.WHOLE.EXPRESSION 40179 - . 40485) (SFI.LOOKUP.NAME 40487 . 40654)) (41455 41631 (SFI.LISTFILES1 41465 . 41629))))) -STOP diff --git a/obsolete/lispusers/TEDITDORADOKEYS b/obsolete/lispusers/TEDITDORADOKEYS deleted file mode 100644 index 5c6597df..00000000 --- a/obsolete/lispusers/TEDITDORADOKEYS +++ /dev/null @@ -1,124 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) - -(FILECREATED "26-Feb-2024 11:19:15" |{WMEDLEY}TEDITDORADOKEYS.;8| 5385 - - :EDIT-BY |rmk| - - :CHANGES-TO (VARS TEDITDORADOKEYSCOMS) - - :PREVIOUS-DATE "15-Sep-2022 10:10:07" |{WMEDLEY}TEDITDORADOKEYS.;4|) - - -(PRETTYCOMPRINT TEDITDORADOKEYSCOMS) - -(RPAQQ TEDITDORADOKEYSCOMS - ((DECLARE\: EVAL@COMPILE DONTCOPY (FILES TEDIT-EXPORTS.ALL)) - (COMS - (* |;;| "Specialized functions for this module") - - (FNS \\TEDIT.DK.ABORT \\TEDIT.DK.INSERT-PARENS \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES - \\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES)) - (VARS (\\TEDIT.DORADO.KEYS '(("Meta,x" EXPAND) - ("Meta,X" EXPAND) - ("Meta,c" FN \\TEDIT.CENTER.SEL) - ("Meta,C" FN \\TEDIT.CENTER.SEL.REV) - ("Meta,b" FN \\TEDIT.BOLD.SEL.ON) - ("Meta,B" FN \\TEDIT.BOLD.SEL.OFF) - ("Meta,i" FN \\TEDIT.ITALIC.SEL.ON) - ("Meta,I" FN \\TEDIT.ITALIC.SEL.OFF) - ("Meta,=" FN \\TEDIT.STRIKEOUT.SEL.ON) - ("Meta,+" FN \\TEDIT.STRIKEOUT.SEL.OFF) - ("Meta,-" FN \\TEDIT.UNDERLINE.SEL.ON) - ("Meta,_" FN \\TEDIT.UNDERLINE.SEL.OFF) - ("Meta,^" FN \\TEDIT.SUBSCRIPTSEL) - ("Meta,|" FN \\TEDIT.SUPERSCRIPTSEL) - ("Meta,SPACE" FN \\TEDIT.DEFAULTSSEL) - ("Meta,?" FN \\TEDIT.SHOWCARETLOOKS) - ("Meta,(" FN \\TEDIT.DK.INSERT-PARENS) - ("Meta,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES) - ("Meta,'" 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))))))) -(DECLARE\: EVAL@COMPILE DONTCOPY - -(FILESLOAD TEDIT-EXPORTS.ALL) -) - - - -(* |;;| "Specialized functions for this module") - -(DEFINEQ - -(\\TEDIT.DK.ABORT - (LAMBDA (TEXTOBJ) - (TEDIT.GET TEXTOBJ))) - -(\\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 - (("Meta,x" EXPAND) - ("Meta,X" EXPAND) - ("Meta,c" FN \\TEDIT.CENTER.SEL) - ("Meta,C" FN \\TEDIT.CENTER.SEL.REV) - ("Meta,b" FN \\TEDIT.BOLD.SEL.ON) - ("Meta,B" FN \\TEDIT.BOLD.SEL.OFF) - ("Meta,i" FN \\TEDIT.ITALIC.SEL.ON) - ("Meta,I" FN \\TEDIT.ITALIC.SEL.OFF) - ("Meta,=" FN \\TEDIT.STRIKEOUT.SEL.ON) - ("Meta,+" FN \\TEDIT.STRIKEOUT.SEL.OFF) - ("Meta,-" FN \\TEDIT.UNDERLINE.SEL.ON) - ("Meta,_" FN \\TEDIT.UNDERLINE.SEL.OFF) - ("Meta,^" FN \\TEDIT.SUBSCRIPTSEL) - ("Meta,|" FN \\TEDIT.SUPERSCRIPTSEL) - ("Meta,SPACE" FN \\TEDIT.DEFAULTSSEL) - ("Meta,?" FN \\TEDIT.SHOWCARETLOOKS) - ("Meta,(" FN \\TEDIT.DK.INSERT-PARENS) - ("Meta,\"" FN \\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES) - ("Meta,'" 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)))) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (2626 4130 (\\TEDIT.DK.ABORT 2636 . 2703) (\\TEDIT.DK.INSERT-PARENS 2705 . 3092) ( -\\TEDIT.DK.INSERT-NEUTRAL-DOUBLEQUOTES 3094 . 3586) (\\TEDIT.DK.INSERT-REAL-DOUBLEQUOTES 3588 . 4128)) -))) -STOP diff --git a/obsolete/lispusers/TEDITDORADOKEYS.LCOM b/obsolete/lispusers/TEDITDORADOKEYS.LCOM deleted file mode 100644 index d65bf602..00000000 Binary files a/obsolete/lispusers/TEDITDORADOKEYS.LCOM and /dev/null differ diff --git a/obsolete/lispusers/TEDITDORADOKEYS.TEDIT b/obsolete/lispusers/TEDITDORADOKEYS.TEDIT deleted file mode 100644 index 3399430c..00000000 Binary files a/obsolete/lispusers/TEDITDORADOKEYS.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/TEDITKEY b/obsolete/lispusers/TEDITKEY deleted file mode 100644 index a5761430..00000000 --- a/obsolete/lispusers/TEDITKEY +++ /dev/null @@ -1,1862 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) - -(FILECREATED "14-Oct-2023 14:53:17" {WMEDLEY}TEDITKEY.;4 93014 - - :EDIT-BY rmk - - :CHANGES-TO (FNS \SEL.LINEDESC) - - :PREVIOUS-DATE "24-Oct-2022 15:25:58" {WMEDLEY}TEDITKEY.;2) - - -(* ; " -Copyright (c) 1985-1987 by Xerox Corporation. -") - -(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) (* ; "Edited 14-Oct-2023 14:53 by rmk") - (* ; "Edited 24-Oct-2022 15:24 by rmk") - (* 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 (SELECTION POINT) of SEL) - 'LEFT) - then (fetch (SELECTION L1) of SEL) - else (fetch (SELECTION LN) of SEL)) - (\TEXTOBJ.WINDEX (fetch (SELECTION SELTEXTOBJ) 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 (15387 27818 (NTHCAR 15397 . 15526) (\TEXTOBJ.WINDEX 15528 . 16085) (\TK.PREVSCREEN -16087 . 17997) (\TK.UNDERLINE.SEL.ON 17999 . 18479) (\TK.UNDERLINE.SEL.OFF 18481 . 18964) ( -\TK.BOLD.SEL.ON 18966 . 19558) (\TK.BOLD.SEL.OFF 19560 . 20156) (\TK.ITALIC.SEL.ON 20158 . 20506) ( -\TK.ITALIC.SEL.OFF 20508 . 20859) (\TK.SMALLERSEL 20861 . 21498) (\TK.LARGERSEL 21500 . 22131) ( -\TK.SUPERSCRIPTSEL 22133 . 22778) (\TK.SUBSCRIPTSEL 22780 . 23429) (\TK.DEFAULTSSEL 23431 . 24150) ( -\TK.DEL.WORD.FORWARD 24152 . 25748) (\TK.UCASE.SEL 25750 . 26316) (\TK.CAPITALISE.SEL 26318 . 26932) ( -\CAPITALISE 26934 . 27248) (\TK.LCASE.SEL 27250 . 27816)) (27890 32567 (\TK.CENTER.SEL 27900 . 29168) -(\TK.CENTER.SEL.REV 29170 . 30348) (\TK.NEST 30350 . 31330) (\TK.UNNEST 31332 . 32565)) (32651 42379 ( -\TK.SHOWCARETLOOKS 32661 . 33972) (\TK.BOLD.CARET.ON 33974 . 34537) (\TK.BOLD.CARET.OFF 34539 . 35105) - (\TK.ITALIC.CARET.ON 35107 . 35672) (\TK.ITALIC.CARET.OFF 35674 . 36242) (\TK.UNDERLINE.CARET.ON -36244 . 36683) (\TK.UNDERLINE.CARET.OFF 36685 . 37127) (\TK.SUPERSCRIPT.CARET 37129 . 37771) ( -\TK.SUBSCRIPT.CARET 37773 . 38431) (\TK.SMALLER.CARET 38433 . 39075) (\TK.LARGER.CARET 39077 . 39664) -(\TK.DEFAULTS.CARET 39666 . 39991) (\TK.FONT1 39993 . 40165) (\TK.FONT2 40167 . 40339) (\TK.FONT3 -40341 . 40513) (\TK.SETCARETFONT 40515 . 41507) (\TK.FONT4 41509 . 41681) (\TK.FONT5 41683 . 41855) ( -\TK.FONT6 41857 . 42029) (\TK.FONT7 42031 . 42203) (\TK.FONT8 42205 . 42377)) (42468 44800 ( -\TK.BOLDTOGGLE 42478 . 43353) (\TK.ITALICTOGGLE 43355 . 44166) (\TK.UNDERLINETOGGLE 44168 . 44798)) ( -44858 45320 (\TK.SETDEFAULTLOOKS 44868 . 45318)) (45381 58503 (GOTONEXTTTYWINDOW 45391 . 47670) ( -\TK.NEXTLINE 47672 . 49560) (\TK.PREVLINE 49562 . 51662) (\TK.GOTODOCBEGIN 51664 . 52022) ( -\TK.GOTODOCEND 52024 . 52375) (\TK.GOTOLINEBEGIN 52377 . 53161) (\TK.GOTOLINEEND 53163 . 53987) ( -\TK.PREVCHAR 53989 . 54518) (\TK.NEXTCHAR 54520 . 55084) (\TK.FORWARD.WORD 55086 . 56623) ( -\TK.BACK.WORD 56625 . 58193) (\TK.SELECT.ALL 58195 . 58501)) (58536 61575 (\TK.FIND 58546 . 58817) ( -\TK.REDISPLAY 58819 . 59077) (\TK.DELLINEFORWARD 59079 . 59619) (\TK.OPENLINE 59621 . 59828) ( -\TK.DELCHARFORWARD 59830 . 60217) (\TK.TRANSPOSECHARS 60219 . 61573)) (61644 63231 (\SEL.LIMIT 61654 - . 62069) (\TK.SETFILEPTR.TO.CARET 62071 . 62498) (\SEL.LINEDESC 62500 . 63229)) (64698 81534 ( -\SHIFTACTION 64708 . 64954) (\ACTION 64956 . 65198) (TEDITKEY.INSTALL 65200 . 72641) ( -TEDITKEY.DEINSTALL 72643 . 72906) (\TK.ACTIONTOCHARCODE 72908 . 73371) (\TK.BUILD.MENU 73373 . 74689) -(\TK.HELP 74691 . 75002) (\TK.SETFONTINLOOKS 75004 . 77479) (WRITE.CHARDESC.AUX 77481 . 78237) ( -CHARDESC 78239 . 78545) (TEDITKEY.CONFIGURE 78547 . 78702) (\TK.ADDKEY 78704 . 78904) (\TK.CHANGEKEY -78906 . 79101) (\TK.APPLYPENDING 79103 . 81209) (\TK.NTHFONT 81211 . 81532)) (81579 82740 (METASHIFT -81589 . 82738)) (82986 85812 (TEDIT.FULL.FIND 82996 . 85810))))) -STOP diff --git a/obsolete/lispusers/TEDITKEY.LCOM b/obsolete/lispusers/TEDITKEY.LCOM deleted file mode 100644 index a303ab73..00000000 Binary files a/obsolete/lispusers/TEDITKEY.LCOM and /dev/null differ diff --git a/obsolete/lispusers/TEDITKEY.TEDIT b/obsolete/lispusers/TEDITKEY.TEDIT deleted file mode 100644 index a7347104..00000000 --- a/obsolete/lispusers/TEDITKEY.TEDIT +++ /dev/null @@ -1,149 +0,0 @@ -en·vÅos TEDITKEY 2 4 1 TEDITKEY 1 4 By: Greg Nuyens Supported by: Jan Pedersen (Pedersen.pa@Xerox.com) Uses: KEYOBJ, DLIONFNKEYS TEditKey is a module that provides a keyboard interface to TEdit. On a Dandelion, the interface takes advantage of the special keys to the left, top, and right of the main keyboard. On a Dorado or Dolphin, a window mimicking the Dandelion function keys provides some of the same abilities. The abilities provided include allowing the user to alter the caret looks (the looks of characters typed in) or the selection looks. These commands are given using the Dandelion function keys and/or metacodes. (Metacodes are keys typed while a meta key is held down. The default meta key is the tab key; to alter this see "User Switches" below.) Other metacodes and control codes move the cursor within the document (beginning/end of line, back/forward a character, up/down a line, etc.). Thus, many of the special Dandelion keys are made to function in TEdit the way they are labeled. The following keys change their behavior once TEditKey is loaded. CENTER modifies the justification of the paragraph(s) containing the current selection. If the selection was left justified, then hitting the CENTER key makes it centered. Hitting it again produces right and left justification. BOLD boldfaces the selection. All other properties remain unchanged. Holding the shift key down while hitting BOLD will make the selection become un-bold. ITALICS italicizes the selection. Shift-ITALICS is the opposite. UNDERLINE underlines the selection. Shift-UNDERLINE is the opposite. SUPERSCRIPT superscripts the selection by a constant amount. Any relative superscripts (or subscripts) are maintained. Thus if "Xi" is selected in "the set Xi is empty" then pressing the SUPERSCRIPT button produces "the set Xi is empty." See "User Switches" below for how to set the increment. Shift-SUPERSCRIPT is the same as SUBSCRIPT. SUBSCRIPT is analogous to SUPERSCRIPT. SMALLER decreases the font size of the selection. All relative size differences are maintained. E.g.,"this is bigger than that" produces "this is bigger than that." Shift-SMALLER (labeled LARGER) does the opposite. DEFAULTS makes the selection have default looks. N.B.: The default looks can be set to the current caret looks by typing shift-DEFAULTS. The above keys all affect the caret looks if the keyboard key is held down when they are hit. Thus holding down KEYBOARD and then hitting UNDERLINE makes the caret looks be underlined. FONT changes the font of the selection or caret looks according to the following table (to alter this table see "User Switches" below): 1 Times Roman 2 Helvetica 3 Gacha 4 Modern 5 Classic 6 Terminal 7 Symbol 8 Hippo Thus, to change the font of the selection to Classic, hold down FONT and hit 5. To change the caret font to Classic, hold down FONT (to signal the font change) and KEYBOARD (to direct the change to the caret looks) then hit 5. Note that this table is part of the menu displayed when the HELP button is pressed. On a Dorado, middle-blank is the FONT key. KEYBOARD applies any changes that occur while this key is down to the caret looks instead of the selection. On a Dorado, bottom-blank is the KEYBOARD key. AGAIN invokes the redo facility in TEdit. A wide variety of operations can be repeated very simply by making a selection, performing an operation (for instance, an insertion), then picking a new selection and hitting the AGAIN key. The AGAIN key is an ESCape key, which acts as the TEdit REDO syntax class. (See page 20.22 of the Interlisp Reference Manual.) OPEN opens a blank line at the current cursor position. OPEN is also used to type a linefeed outside of TEdit (for example to the function FILES?). FIND prompts the user for a target string, then searches from the selection forward. NEXT acts as the TEdit NEXT syntax class. (It goes to the next field to be filled in. These fields are marked as follows: >>text to be substituted<< .) shift-NEXT transfers the TTY (which window will receive typed characters) to the next window which can accept typein. Thus one can cycle through the open text windows (mail windows, top level lisp windows, TEdit windows, etc.) without using the mouse. EXPAND expands TEdit abbreviations. (See page 20.31 of the Interlisp Reference Manual.) HELP displays a menu of the keybindings until a mouse key is clicked. UNDO acts as the TEdit UNDO syntax class. Note that it still retains its TELERAID function as does STOP. There are TEditKey operations (such as Transpose Characters) that are implemented with multiple TEdit operations. Since TEdit will UNDO only single operations, it does not fully UNDO these operations. RightArrow enters \, and | when shifted. (Recall that AGAIN is an escape key.) MARGINS indents the margins of the paragraph selected. Shift-MARGINS exdents the margins. If the right margin is a floating margin, it is left unchanged. To control the amount by which the margins are moved, see "User Switches." As well as the previous functions available on the Dandelion's special keys, the following functions are available on the standard keyboard (thus usable on the Dandelion, Dolphin, and Dorado). Each function is shown with the key that invokes it (in conjunction with the control (denoted ^) or meta (denoted #) key). Thus, for the sixth entry, holding down the metakey and hitting f (or "F") would move the caret one word forward. (To find out how to get a metakey see "User Switches" below.) #/ defaults the caret looks #= queries caret looks #9 smaller caret font #0 larger caret font ^b back character ^f forward character #b back word #f forward word ^p previous line ^n next line ^a beginning of line ^e end of line #< beginning of document #> end of document #s select whole document ^k kills line (delete from caret to end of line) ^o opens line ^d deletes character forward (also on shift backspace) #d deletes word forward (as always ^w deletes word backward) ^t transposes characters #[ indents paralooks. Also available on the MARGINS key #] exdents paralooks. Also available as shift-MARGINS #j justification change (same as CENTER key) #u uppercases selection #c capitalizes selection #l lowercases selection #o inserts object into document #? shows keybindings (same as HELP) #r restores the display Note that the positions of any of these functions can be individually changed using TEDIT.SETFUNCTION (see page 20.30 of the Interlisp Reference Manual). For wholesale customization see "User Switches" below. INTERRUPTS Any operation can be aborted by typing the STOP key. This can be used to abort font changes, GETs, PUTs, etc. A stronger form of interrupt is available as shift-STOP, which prompts the user for a menu of processes to interrupt. ^G is available as a synonym for hitting the STOP key within TEditKey. Outside of TEdit, however, ^G will continue to have the meaning specified in the user's init file. This is often the HELP interrupt, which acts as shift-STOP. Users who are accustomed to typing ^E as a soft interrupt should note that ^E moves to the end of the line. As discussed above, hitting the STOP key (or equivalently, typing ^G) accomplishes what ^E did. Since ^H is defined to be the Backspace action in TEditKey, users cannot type ^A to erase characters even outside of TEditKey (Interlisp-D currently does not allow multiple backspace characters). In addition to the changed functionality mentioned above (provided courtesy of TEditKey), the user should be aware of the following standard Interlisp-D/TEdit behavior: SAME operates as a LooksCopy mode key. First make a selection. Now to copy the looks from some other text simply hold down the SAME key, then select the source for the looks. (Paragraph looks can be copied the same way, but by making the final selection while in the left margin. This is the standard way to select a whole paragraph in TEdit.) MOVE and COPY act as mode keys for the selection mechanism. Thus the user can select the destination, then hold down the MOVE key and make a second selection. This selection will be moved (or COPY'd depending on the mode key used) to the (original) caret position. CONTROL operates as a mode key to signal deletion. This means that holding down the CONTROL key and selecting some text will delete that text when the CONTROL key is released. DELETE deletes the current selection when pressed. DORADO EQUIVALENTS Dandelion Key: Equivalent key on Dorado: OPEN ^o ( or ^O) SAME META FIND finds item in TEdit menu AGAIN ESC DELETE DEL COPY SHIFT MOVE CTRL-SHIFT PROP'S META or LOCK depending on switches NEXT #n ( or #N) EXPAND ^x (or ^X) HELP #? MARGINS #[ (unnest (which is shift-MARGINS on the Dandelion) is #] ) FONT top blank KEYBOARD middle blank UNDO bottom blank STOP ^G shift-STOP #^S (intentionally difficult to type accidentally) The function keys (CENTER, BOLD, etc.) are all available on the function key window brought up when TEditKey is loaded on a Dorado. Note that the function key window can be rebuilt on a Dorado by selecting "Function Keys" in the default TEdit menu (obtained by buttoning in the title bar of a TEdit window). USER SWITCHES TEDITKEY.METAKEY The user must choose a metakey to make use of TEditKey. The value of the variable TEDITKEY.METAKEY is the name of the key that will be your metakey. For instance to make TAB (the default) your metakey, (SETQ TEDITKEY 'TAB) before loading TEditKey. (Note that even in the standard system, TAB is available as Control-I). NOTE: METASHIFT (see page 18.9 of the Interlisp Reference Manual) is redefined to operate on TEDITKEY.METAKEY instead of on the bottom-blank key of the Dorado. The operation of TEditKey is controlled by the following (INITVARed) variables: TEDITKEY.LOCKTOGGLEKEY is the key that will be turned into a lock-toggle. If it is non-NIL, that key is set to act as a lock-toggle. Thus hitting this switches the case of the type-in. For those users who have removed the spring from their lock key, TEDITKEY.LOCKTOGGLEKEY is usually PROP'S. The action of LOCK is then made to be '(CTRLDOWN. CTRLUP) providing the user with a control key where LOCK is located and a lock toggle where PROP'S is located. TEDITKEY.FONTS is an eight-element list of the fonts that are invoked by meta-1 through meta-8. The defaults are listed above. TEDIT.DEFAULT.CHARLOOKS defines the looks that result when the DEFAULTS key is pressed or when default caret looks are requested. It is an instance of the CHARLOOKS datatype. To preset it, for instance, to TIMESROMAN 10 type the following to the Lisp top level. (SETQ TEDIT.DEFAULT.CHARLOOKS (CHARLOOKS.FROM.FONT (FONTCREATE 'TIMESROMAN 10))) However, a much simpler method is to select an instance of the desired looks and type shift-DEFAULTS. TEDITKEY.VERBOSE if T (the default), the functions that modify the caret looks print feedback in the (TEdit) prompt window. TEDITKEY.NESTWIDTH is the distance (in points) that the indent and exdent functions move the margins. Initially 36 points (0.5 inches). \TK.SIZEINCREMENT is the amount (in points) which the LARGER function increases the selection (and conversely for SMALLER). Initially 2 points. TEDITKEY.OFFSETINCREMENT is the amount (in points) which the SUBSCRIPT function raises the selection (and conversely for SUPERSCRIPT). Initially 3 points. TEDITKEY.KEYBINDINGS is the list that controls the mapping of keys to functions for the functions that are common to the Dandelion, Dorado, and Dolphin. It consists of triples of function name, list of CHARCODE-style character specifications, and a comment describing what the function does. (The comments are used by the automated menu-building tools and their inclusion is encouraged.) TEDITKEY.DLION.KEYACTIONS is the list that specifies the key actions of the non-Alto keys (to the left and right) on the Dandelion. It is the format acceptable to MODIFY.KEYACTIONS (see page 18.9 of the Interlisp Reference Manual). TEDITKEY.DLION.KEYBINDINGS is the list specifying the functions to be tied to the characters generated from above. The keynames in the CAR of each element are comments. Note that TEDIT.DLION.KEYACTIONS and TEDIT.DLION.KEYBINDINGS must be coordinated (similarly for TEDITKEY.FNKEYACTIONS and TEDITKEY.FNKEYBINDINGS). TEDIT.DLION.KEYSYNTAX is the list of syntax classes to be applied to the Dandelion keys. TEDITKEY.FNKEYACTIONS is the list that specifies the keyactions of the function keys (center, bold, etc.). TEDITKEY.FNKEYBINDINGS is analogous to TEDIT.DLION.KEYBINDINGS but for the function keys. TEDITKEY.DORADO.KEYACTIONS are the keyactions unique to the Dorado (and Dolphin). TEDITKEY.DORADO.KEYSYNTAX is analogous to TEDIT.DLION.KEYSYNTAX. The previous variables in conjunction with the following functions specify the effect of TEditKey. (TEDITKEY.INSTALL readtable) invokes the keyactions and bindings as specified by the above variables on readtable. (Readtable defaults to TEDIT.READTABLE). (\TK.BUILD.MENU) is a function that automagically builds the help menu from the values of the above variables. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "" "") STARTINGPAGE# 267) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "" "")) (174 36 288 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 528 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT MEDIUM)) (282 42 72 36) NIL) (HEADING NIL (HEADINGTYPE RUNNINGHEAD) (84 744 444 36) NIL) (TEXT NIL NIL (84 96 456 600) NIL))))) -ÈT,È2ÈÈ2È02Èx,È,È ,È,ŠŠ8,ŠŠ8HÈÈ PAGEHEADING RUNNINGHEADCLASSICCLASSICCLASSIC -TIMESROMAN -MODERNMODERN MODERN -ÿüMODERN -ÿþMODERN -ÿþMODERN -MODERN -MODERN MODERNMODERN -    HRULE.GETFNMODERN -  - HRULE.GETFNMODERN -  - HRULE.GETFNMODERN -    HRULE.GETFNMODERN   - HRULE.GETFNMODERN   3   -& > #  -~ ¢  - -ß  - -–  - -9  - -  -0  - -x   B  C  -+  - -  - -a $ -5  - -‚ ¹  - -…      -    9 *  - -“  - -G   - -‘  - -P  - -”  - - -ñ  -5   - -@  - -1  - - -E  - -à ð       -           1  7 =  9 7 .    ! $  } :  - - - ç è Í Æ ¨  - -X  - -  -þ  - -ª  - --  -(  - -  - -  - -  - -  - -  - -  - - -  - -#  - -  - -  - -  - -=  - -  - -  - -  - -   -4 „ ¯  - - -T  -á & ` O  - -²  - -q  - -ñ Q d  - -k  - -v  - -  - -ƒ  - -r  - -²   - -#  - -C  - -U  - -C  - -7  - -' b  - - M    - -]  -3f³zº \ No newline at end of file diff --git a/obsolete/lispusers/TKDORADO b/obsolete/lispusers/TKDORADO deleted file mode 100644 index 58923d3f..00000000 --- a/obsolete/lispusers/TKDORADO +++ /dev/null @@ -1,243 +0,0 @@ -(DEFINE-FILE-INFO §PACKAGE "INTERLISP" §READTABLE "INTERLISP" §BASE 10) -(FILECREATED "16-Apr-87 17:28:48" {ERIS}LYRIC>TKDORADO.;5 14764 - - changes to%: (VARS TKDORADOCOMS) - (FNS \TKD.SETLOOKS) - - previous date%: "14-Apr-87 17:10:44" {ERIS}LYRIC>TKDORADO.;4) - - -(* " -Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT TKDORADOCOMS) - -(RPAQQ TKDORADOCOMS [(FILES TEDITKEY) - (FNS \TKD.SETLOOKS) - (P [SETQ TEDITKEY.KEYBINDINGS - (UNION (APPEND TEDITKEY.KEYBINDINGS '(NIL)) - '(([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (if (ZEROP (fetch DCH of SEL)) - then - (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.DEFAULTSSEL TEXTSTREAM TEXTOBJ SEL] - (%##^V) - "default looks") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(OVERLINE ON] - (%##^D) - "overbar on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(OVERLINE OFF] - (%##^F) - "overbar off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(STRIKEOUT ON] - (%##^G) - "strikethru on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(STRIKEOUT OFF] - (%##^H) - "strikethru off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(UNDERLINE ON] - (%##^J) - "underlining on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(UNDERLINE OFF] - (%##^K) - "underlining off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(WEIGHT BOLD] - (%##^B) - "bold on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(WEIGHT MEDIUM] - (%##^N) - "bold off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(SLOPE ITALIC] - (%##^I) - "italics on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL - '(SLOPE REGULAR] - (%##^O) - "italics off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (IF (ZEROP (FETCH DCH OF SEL)) - then - (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.SMALLERSEL TEXTSTREAM TEXTOBJ SEL] - (|##^[|) - "smaller font") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (IF (ZEROP (FETCH DCH OF SEL)) - then - (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.LARGERSEL TEXTSTREAM TEXTOBJ SEL] - (|##^]|) - "larger font") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (IF (ZEROP (FETCH DCH OF SEL)) - then - (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.SUPERSCRIPTSEL TEXTSTREAM TEXTOBJ SEL] - (%##^^) - "superscript") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (IF (ZEROP (FETCH DCH OF SEL)) - then - (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.SUBSCRIPTSEL TEXTSTREAM TEXTOBJ SEL] - (%##^_) - "subscript") - (\TK.CENTER.SEL (%##^C) - "center, justify, ... "] - (\TK.BUILD.MENU) - (TEDITKEY.INSTALL) - (AND (BOUNDP 'DLIONFNKEYS) - (OPENWP DLIONFNKEYS) - (CLOSEW DLIONFNKEYS)) - (TEDIT.SETSYNTAX (CHARCODE ESC) - 'REDO]) -(FILESLOAD TEDITKEY) -(DEFINEQ - -(\TKD.SETLOOKS - [LAMBDA (TEXTSTREAM TEXTOBJ SEL LOOKS) (* ; "Edited 16-Apr-87 17:26 by mdd") - (if (ZEROP (fetch DCH of SEL)) - then [LET [(charlooks (create CHARLOOKS using (fetch CARETLOOKS of TEXTOBJ] - [REPLACEFIELD (LISTGET [CONSTANT (LIST 'UNDERLINE (CADADR (RECORDACCESSFORM - 'CLULINE)) - 'OVERLINE - (CADADR (RECORDACCESSFORM 'CLOLINE)) - 'STRIKEOUT - (CADADR (RECORDACCESSFORM 'CLSTRIKE)) - 'SLOPE - (CADADR (RECORDACCESSFORM 'CLITAL)) - 'WEIGHT - (CADADR (RECORDACCESSFORM 'CLBOLD] - (CAR LOOKS)) - charlooks - (FMEMB (CADR LOOKS) - '(ITALIC BOLD ON] - (if (OR (AND (NEQ (CAR LOOKS) - 'SLOPE) - (NEQ (CAR LOOKS) - 'WEIGHT)) - (\TK.SETFONTINLOOKS TEXTSTREAM charlooks)) - then (TEDIT.CARETLOOKS TEXTSTREAM charlooks) - (if TEDITKEY.VERBOSE - then (\TK.SHOWCARETLOOKS TEXTSTREAM TEXTOBJ SEL] - else (TEDIT.LOOKS TEXTSTREAM LOOKS SEL]) -) -[SETQ TEDITKEY.KEYBINDINGS (UNION (APPEND TEDITKEY.KEYBINDINGS '(NIL)) - '(([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (if (ZEROP (fetch DCH of SEL)) - then - (\TK.DEFAULTS.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.DEFAULTSSEL TEXTSTREAM TEXTOBJ SEL] - (%##^V) - "default looks") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(OVERLINE ON] - (%##^D) - "overbar on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(OVERLINE OFF] - (%##^F) - "overbar off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(STRIKEOUT ON] - (%##^G) - "strikethru on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(STRIKEOUT OFF] - (%##^H) - "strikethru off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(UNDERLINE ON] - (%##^J) - "underlining on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(UNDERLINE OFF] - (%##^K) - "underlining off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(WEIGHT BOLD] - (%##^B) - "bold on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(WEIGHT MEDIUM] - (%##^N) - "bold off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(SLOPE ITALIC] - (%##^I) - "italics on") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (\TKD.SETLOOKS TEXTSTREAM TEXTOBJ SEL '(SLOPE REGULAR] - (%##^O) - "italics off") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (IF (ZEROP (FETCH DCH OF SEL)) - then - (\TK.SMALLER.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.SMALLERSEL TEXTSTREAM TEXTOBJ SEL] - (|##^[|) - "smaller font") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (IF (ZEROP (FETCH DCH OF SEL)) - then - (\TK.LARGER.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.LARGERSEL TEXTSTREAM TEXTOBJ SEL] - (|##^]|) - "larger font") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (IF (ZEROP (FETCH DCH OF SEL)) - then - (\TK.SUPERSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.SUPERSCRIPTSEL TEXTSTREAM TEXTOBJ SEL] - (%##^^) - "superscript") - ([LAMBDA (TEXTSTREAM TEXTOBJ SEL) - (IF (ZEROP (FETCH DCH OF SEL)) - then - (\TK.SUBSCRIPT.CARET TEXTSTREAM TEXTOBJ SEL) - else - (\TK.SUBSCRIPTSEL TEXTSTREAM TEXTOBJ SEL] - (%##^_) - "subscript") - (\TK.CENTER.SEL (%##^C) - "center, justify, ... "] -(\TK.BUILD.MENU) -(TEDITKEY.INSTALL) -(AND (BOUNDP 'DLIONFNKEYS) - (OPENWP DLIONFNKEYS) - (CLOSEW DLIONFNKEYS)) -(TEDIT.SETSYNTAX (CHARCODE ESC) - 'REDO) -(PUTPROPS TKDORADO COPYRIGHT ("Xerox Corporation" 1986 1987)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (7206 9013 (\TKD.SETLOOKS 7216 . 9011))))) -STOP diff --git a/obsolete/lispusers/TKDORADO.TEDIT b/obsolete/lispusers/TKDORADO.TEDIT deleted file mode 100644 index a667eec2..00000000 Binary files a/obsolete/lispusers/TKDORADO.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/UPCSTATS b/obsolete/lispusers/UPCSTATS deleted file mode 100644 index 90daba92..00000000 --- a/obsolete/lispusers/UPCSTATS +++ /dev/null @@ -1,297 +0,0 @@ -(FILECREATED "11-Oct-84 14:34:16" {ERIS}LIBRARY>UPCSTATS.;3 9157 - - changes to: (FNS UPCSTATS) - - previous date: "12-NOV-82 12:47:49" {ERIS}LIBRARY>UPCSTATS.;1) - - -(* Copyright (c) by NIL. All rights reserved.) - -(PRETTYCOMPRINT UPCSTATSCOMS) - -(RPAQQ UPCSTATSCOMS ((VARS IMSIZE) - (FNS GATHERUPCSTATS PRINTCUMULATIVEPERCENT PRINTUPC UPCSTATS) - (FNS READMBFILE READNAME) - (FNS PLOTPCS) - (INITVARS (STATSBUFFER) - (VIRTOREAL) - (VIRTONAME)) - (VARS (UPCTHRESHOLD 0 (* lower threshold for percentage to show up on Microcode - PC Sample histogram))) - (MACROS BIN2 UPCCOUNT))) - -(RPAQQ IMSIZE 4096) -(DEFINEQ - -(GATHERUPCSTATS - [LAMBDA (FORM) (* lmm "12-NOV-82 12:45") - (DECLARE (GLOBALVARS STATSBUFFER)) - (OR STATSBUFFER (SETQ STATSBUFFER (\ALLOCLOCKED IMSIZE))) - [\ZEROWORDS STATSBUFFER (\ADDBASE STATSBUFFER (SUB1 (ITIMES IMSIZE (PROG1 2 - (* words per fixp)] - [RESETVARS ((STRF T) - (LCFIL)) - (COMPILE1 (QUOTE STATSDUMMYFUNCTION) - (BQUOTE (LAMBDA NIL ((OPCODES UPCTRACE) - STATSBUFFER) - , FORM ((OPCODES UPCTRACE) - NIL] - (STATSDUMMYFUNCTION]) - -(PRINTCUMULATIVEPERCENT - [LAMBDA NIL (* lmm "29-SEP-80 15:56") - (PROGN (PRIN1 "(" NIL) - (PRIN1 (FQUOTIENT (FPLUS (FTIMES 65536. CUHI) - CULO) - TOTAL) - NIL) - (PRIN1 ")" NIL]) - -(PRINTUPC - [LAMBDA NIL (* lmm "12-NOV-82 11:40") - (COND - (UPCSEEN (do (PRIN1 "Use .MB file: " T) - (SETQ MBFILE (READ T T)) repeatuntil (OR (EQ (NTHCHAR MBFILE 1) - (QUOTE {)) - (EQ MBFILE (QUOTE NIL:)) - (INFILEP MBFILE))) - (READMBFILE MBFILE) - (PRIN1 "Microcode PC Sample: ") - (PLOTPCS))) - (STATSDUMMYFUNCTION]) - -(UPCSTATS - [LAMBDA (FORM DOLISTFLG) (* gbn "11-Oct-84 14:33") - (PROG ((STRF T) - (LCFIL)) - (DECLARE (SPECVARS STRF LCFIL)) - (IF (NOT (EQ (MACHINETYPE) - (QUOTE DORADO))) - THEN (PRINTOUT T " UPCSTATS only runs on Dorados") - (RETURN)) - (GATHERUPCSTATS FORM) - (READMBFILE) - (PLOTPCS]) -) -(DEFINEQ - -(READMBFILE - [LAMBDA (MBFILE) (* lmm "12-NOV-82 12:31") - (OR MBFILE (do (PRIN1 "Use .MB file: " T) - (SETQ MBFILE (READ T T)) repeatuntil (INFILEP MBFILE))) - (PROG ((INX (GETOFD (SETQ MBFILE (OPENFILE MBFILE (QUOTE INPUT) - (QUOTE OLD) - 8)) - (QUOTE INPUT))) - (CURMEMWIDTH 0) - (CURMEM 0) - (CURLOC 0) - IM BLOCKTYPE) - (SETQ MEMORIES) - (OR VIRTOREAL (SETQ VIRTOREAL (ARRAY IMSIZE (QUOTE SMALLP) - 0 0))) - (OR VIRTONAME (SETQ VIRTONAME (ARRAY IMSIZE (QUOTE POINTER) - NIL 0))) - LP (SELECTQ (SETQ BLOCKTYPE (BIN2 INX)) - (0 (RETURN)) - [1 (COND - ((EQ CURMEM IM) - (BIN2 INX) (* source line #) - (BIN2 INX) (* bits 0 to 15) - (BIN2 INX) (* bits 16 to 31) - (BIN2 INX) (* bits 32 to 47) - (FASTSETAW VIRTOREAL (PROG1 CURLOC (add CURLOC 1)) - (LOGAND (BIN2 INX) - 4095)) (* bits 48 to 63) - ) - (T (BIN2 INX) - (FRPTQ CURMEMWIDTH (BIN2 INX] - (2 (SETQ CURMEM (BIN2 INX)) - (SETQ CURLOC (BIN2 INX)) - (SETQ CURMEMWIDTH (IQUOTIENT (IPLUS (CADR (OR (FASSOC CURMEM MEMORIES) - (HELP))) - 15) - 16))) - [3 (* FIXUP MEM# LOC FIRSTBIT,,LASTBIT VALUE) - (COND - ((EQ (BIN2 INX) - IM) - (HELP)) - (T (BIN2 INX) - (BIN2 INX) - (BIN2 INX] - [4 (push MEMORIES (LIST (BIN2 INX) - (BIN2 INX) - (READNAME INX))) - (COND - ((EQ (CADDR (CAR MEMORIES)) - (QUOTE IM)) - (SETQ IM (CAAR MEMORIES)) - (OR (EQ (CADAR MEMORIES) - 64) - (HELP (QUOTE IM) - "wrong # bits"] - [5 (* symbol location) - (COND - ((EQ (BIN2 INX) - IM) - (FASTSETA VIRTONAME (BIN2 INX) - (READNAME INX))) - (T (BIN2 INX) - (READNAME INX T] - (6 (BIN2 INX) - (BIN2 INX) - (BIN2 INX) - (READNAME INX T)) - (HELP)) - (GO LP)) - (CLOSEF MBFILE]) - -(READNAME - [LAMBDA (J FLG) (* lmm "16-MAY-81 16:51") - (bind EVENBYTE CH CHARS do (COND - [(ZEROP (SETQ CH (\BIN J))) - (RETURN (PROG1 (OR FLG (PACKC (DREVERSE CHARS))) - (COND - ((NOT EVENBYTE) - (\BIN J] - (T (SETQ EVENBYTE (NOT EVENBYTE)) - (push CHARS CH]) -) -(DEFINEQ - -(PLOTPCS - [LAMBDA (ALLFLG) (* lmm "12-NOV-82 12:29") - (PROG (NAME (INC 0) - LASTPRINTEDNAME V CNTPERSTAR (BIGGEST 0) - (2NDBIGGEST 0) - (3RDBIGGEST 0) - (TOTHI 0) - (TOTLO 0) - CUM HALFSTAR MAXSTARS LASTSTARPOS NSTARS TABPOS THRESHOLD TOTAL (CUHI 0) - (CULO 0)) - (PRIN1 "Microcode PC Sample: ") - [for I from 0 to (SUB1 IMSIZE) do (COND - ((NEQ (SETQ V (UPCCOUNT I)) - 0) - (add TOTHI (LRSH V 16)) - (add TOTLO (LOGAND V 65535)) - (COND - ((IGREATERP V 3RDBIGGEST) - (COND - [(IGREATERP V 2NDBIGGEST) - (COND - ((IGREATERP V BIGGEST) - (SETQ BIGGEST V)) - (T (SETQ 2NDBIGGEST V] - (T (SETQ 3RDBIGGEST V] - (* Each line has (NAME 14) (+nnn 4)  - (%| 1) stars ((nn.nnnn%%) 10) + 2 for luck) - (SETQ MAXSTARS (IDIFFERENCE [SETQ LASTSTARPOS (IDIFFERENCE (LINELENGTH) - (COND - (ALLFLG 20) - (T 12] - 20)) - (SETQ CNTPERSTAR (IQUOTIENT 3RDBIGGEST MAXSTARS)) - (SETQ HALFSTAR (IQUOTIENT CNTPERSTAR 2)) - (SETQ TOTAL (FPLUS TOTLO (FTIMES TOTHI 65536.0))) - [SETQ THRESHOLD (COND - (ALLFLG 0) - (T (IMAX HALFSTAR (FIX (QUOTIENT (TIMES UPCTHRESHOLD CNTPERSTAR) - TOTAL] - (SETQ TOTAL (FQUOTIENT TOTAL 100.0)) - (printout NIL " Each * = " CNTPERSTAR " count, or " .F8.2 (FQUOTIENT CNTPERSTAR TOTAL) - "%%") - [for VPC from 0 to (SUB1 IMSIZE) - do [COND - ((SETQ V (FASTELT VIRTONAME VPC)) - (SETQ NAME V) - (SETQ INC 0)) - (T (SETQ INC (ADD1 INC] - (SETQ V (UPCCOUNT (FASTELTW VIRTOREAL VPC))) - (COND - (ALLFLG (COND - [(NEQ NAME LASTPRINTEDNAME) - (COND - (LASTPRINTEDNAME (* don't do it the first time) - (TAB LASTSTARPOS) - (PRINTCUMULATIVEPERCENT))) - (TERPRI) - (PRIN1 (COND - ((IGREATERP (SETQ TABPOS (NCHARS (SETQ LASTPRINTEDNAME NAME))) - 14) - (SUBSTRING NAME 1 (SETQ TABPOS 14))) - (T NAME] - (T (TERPRI) - (SPACES TABPOS))) - (add CUHI (LRSH V 16)) - (add CULO (LOGAND V 65535)) - (COND - ((NEQ INC 0) - (printout NIL "+" .I3...T INC))) - (TAB 18) - (printout NIL "#" .I8.4 (FASTELTW VIRTOREAL VPC) - " " .I10 V)) - ((IGREATERP V THRESHOLD) - (COND - [(NEQ NAME LASTPRINTEDNAME) - (COND - (LASTPRINTEDNAME (* don't do it the first time) - (TAB LASTSTARPOS) - (PRINTCUMULATIVEPERCENT))) - (TERPRI) - (PRIN1 (COND - ((IGREATERP (SETQ TABPOS (NCHARS (SETQ LASTPRINTEDNAME NAME))) - 14) - (SUBSTRING NAME 1 (SETQ TABPOS 14))) - (T NAME] - (T (TERPRI) - (SPACES TABPOS))) - (add CUHI (LRSH V 16)) - (add CULO (LOGAND V 65535)) - (COND - ((NEQ INC 0) - (printout NIL "+" .I3...T INC))) - (TAB 18) - (PRIN1 "|") - (FRPTQ (COND - ((IGEQ (SETQ NSTARS (IQUOTIENT (IPLUS V HALFSTAR) - CNTPERSTAR)) - MAXSTARS) - (printout NIL "(" .I4 NSTARS ")") - (IDIFFERENCE MAXSTARS 6)) - (T NSTARS)) - (PRIN1 "*"] - (TAB LASTSTARPOS) - (PRINTCUMULATIVEPERCENT) - (TERPRI) - (SETQ CUHI (IDIFFERENCE TOTHI CUHI)) - (SETQ CULO (IDIFFERENCE TOTLO CULO)) - (printout NIL T T "Not shown: ") - (PRINTCUMULATIVEPERCENT) - (TERPRI]) -) - -(RPAQ? STATSBUFFER ) - -(RPAQ? VIRTOREAL ) - -(RPAQ? VIRTONAME ) - -(RPAQ UPCTHRESHOLD 0 (* lower threshold for percentage to show up on Microcode PC Sample histogram)) -(DECLARE: EVAL@COMPILE - -(PUTPROPS BIN2 MACRO ((INX) - (IPLUS (LLSH (\BIN INX) - 8) - (\BIN INX)))) - -(PUTPROPS UPCCOUNT MACRO [OPENLAMBDA (N) - (\MAKENUMBER (\GETBASE STATSBUFFER (ADD1 (LLSH N 1))) - (\GETBASE STATSBUFFER (LLSH N 1]) -) -(DECLARE: DONTCOPY - (FILEMAP (NIL (698 2431 (GATHERUPCSTATS 708 . 1305) (PRINTCUMULATIVEPERCENT 1307 . 1533) (PRINTUPC -1535 . 1979) (UPCSTATS 1981 . 2429)) (2432 4989 (READMBFILE 2442 . 4644) (READNAME 4646 . 4987)) (4990 - 8641 (PLOTPCS 5000 . 8639))))) -STOP diff --git a/obsolete/lispusers/UPCSTATS.TEDIT b/obsolete/lispusers/UPCSTATS.TEDIT deleted file mode 100644 index f45c716c..00000000 Binary files a/obsolete/lispusers/UPCSTATS.TEDIT and /dev/null differ diff --git a/obsolete/lispusers/XORCURSORPATCH b/obsolete/lispusers/XORCURSORPATCH deleted file mode 100644 index 29181f2d..00000000 --- a/obsolete/lispusers/XORCURSORPATCH +++ /dev/null @@ -1,34 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "19-Jul-88 11:37:37" {ERINYES}LYRIC>XORCURSORPATCH.\;1 1455 - - |changes| |to:| (VARS XORCURSORPATCHCOMS) - - |previous| |date:| " 7-Oct-86 18:56:37" {PHYLUM}KOTO>XORCURSORPATCH.\;1) - - -; Copyright (c) 1988 by Xerox Corporation. All rights reserved. - -(PRETTYCOMPRINT XORCURSORPATCHCOMS) - -(RPAQQ XORCURSORPATCHCOMS ((FNS DOVE.XOR.CURSOR) (INITVARS (|\\DoveDisplay.VideoColor| 1)) (GLOBALVARS |\\DoveDisplay.VideoColor|) (ADVISE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR)))) -(DEFINEQ - -(DOVE.XOR.CURSOR -(LAMBDA (FLG) (* |cdl| " 7-Oct-86 18:56") (SELECTQ (MACHINETYPE) (DOVE (|if| (EQP |\\DoveDisplay.VideoColor| 1) |then| (|if| FLG |then| (SETQ |\\DoveDisplay.VideoColor| (|if| (NUMBERP FLG) |then| FLG |else| 9))) |else| (|if| (NULL FLG) |then| (SETQ |\\DoveDisplay.VideoColor| 1))) (|\\DoveDisplay.SetCursorMix| |\\DoveDisplay.VideoColor|) T) NIL)) -) -) - -(RPAQ? |\\DoveDisplay.VideoColor| 1) -(DECLARE\: DOEVAL@COMPILE DONTCOPY - - -(GLOBALVARS |\\DoveDisplay.VideoColor|) -) - -(XCL:REINSTALL-ADVICE (QUOTE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR)) :AFTER (QUOTE ((:LAST (SELECTQ (MACHINETYPE) (DOVE (|if| (NOT INVERSE?) |then| (|\\DoveDisplay.SetCursorMix| |\\DoveDisplay.VideoColor|))) NIL))))) - -(READVISE (|\\DoveDisplay.SetVideoColor| :IN VIDEOCOLOR)) -(PUTPROPS XORCURSORPATCH COPYRIGHT ("Xerox Corporation" 1988)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (585 967 (DOVE.XOR.CURSOR 595 . 965))))) -STOP diff --git a/obsolete/lispusers/XORCursorPatch.TEdit b/obsolete/lispusers/XORCursorPatch.TEdit deleted file mode 100644 index 80acd855..00000000 Binary files a/obsolete/lispusers/XORCursorPatch.TEdit and /dev/null differ diff --git a/obsolete/lispusers/XREF b/obsolete/lispusers/XREF deleted file mode 100644 index 7e5f195a..00000000 --- a/obsolete/lispusers/XREF +++ /dev/null @@ -1,311 +0,0 @@ -(FILECREATED "18-Feb-87 15:48:37" {SUMEX-AIM}PS:XREF.;6 12717 - - changes to: (VARS XREF.DISPLAY.METHODS) - (FNS XREF.IMAGEBOXFN INSERT.REF) - - previous date: " 5-Feb-87 14:57:51" {SUMEX-AIM}PS:XREF.;5) - - -(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.) - -(PRETTYCOMPRINT XREFCOMS) - -(RPAQQ XREFCOMS ((* Developed under support from NIH grant RR-00785.) - (* Written by Frank Gilmurray and Sami Shaio.) - (* An XREF is a general-purpose cross-referencing imageobject. In order to create - an instance of an XREF one simply calls the function XREF with a TAG that is - supposed to link it with some imageobject that it is referencing. In order to - add to the class of imageobjects that can be referenced with XREF one uses the - function XREF.ADD.DISPLAYFN with the type of the imageobject and a function - that operates on it to return some string that XREF will then display in the - document.) - (FNS XREF XREFP XREF.DISPLAYFN XREF.IMAGEBOXFN XREF.PUTFN XREF.GETFN - XREF.BUTTONEVENTINFN XREF.WHENDELETEDFN) - (FNS XREF.GET.DISPLAY.TEXT XREF.GET.TOOBJ TSPOBJ.GETTYPE) - (FNS UPDATE.XREFS REBUILD.TAG.ARRAY INSERT.REF GET.REF TSP.LIST.REFS - XREF.TAG.OBJECT TSP.GET.INCODE TSP.GETCODEVAL TSP.PUTCODE) - (* Functions for adding and retrieving the method for a gven imageobject.) - (FNS XREF.ADD.DISPLAYFN XREF.GET.DISPLAYFN) - (* Examples of some XREF display methods.) - (FNS NGROUP.XREF.DISPLAYFN NOTE.XREF.DISPLAYFN) - (UGLYVARS XREF.DISPLAY.METHODS))) - - - -(* Developed under support from NIH grant RR-00785.) - - - - -(* Written by Frank Gilmurray and Sami Shaio.) - - - - -(* An XREF is a general-purpose cross-referencing imageobject. In order to create an instance -of an XREF one simply calls the function XREF with a TAG that is supposed to link it with some -imageobject that it is referencing. In order to add to the class of imageobjects that can be -referenced with XREF one uses the function XREF.ADD.DISPLAYFN with the type of the imageobject -and a function that operates on it to return some string that XREF will then display in the -document.) - -(DEFINEQ - -(XREF - (LAMBDA (TAG) (* edited: "28-Jan-87 12:53") - - (* Returns a new XREF imageobject. The TAG argument is obligatory and should be the tag that is used to reference  - the object that this XREF object is referencing.) - - - (LET ((NEWOBJ (IMAGEOBJCREATE TAG (IMAGEFNSCREATE (FUNCTION XREF.DISPLAYFN) - (FUNCTION XREF.IMAGEBOXFN) - (FUNCTION XREF.PUTFN) - (FUNCTION XREF.GETFN) - (FUNCTION NILL) - (FUNCTION XREF.BUTTONEVENTINFN) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL) - (FUNCTION NILL))))) - (IMAGEOBJPROP NEWOBJ 'TYPE - 'XREF) - NEWOBJ))) - -(XREFP - (LAMBDA (OBJ) (* edited: "22-Jan-87 21:20") - (* Test whether something is an XREF imageobject.) - (AND (IMAGEOBJP OBJ) - (EQ (IMAGEOBJPROP OBJ 'TYPE) - 'XREF)))) - -(XREF.DISPLAYFN - (LAMBDA (OBJ STREAM) (* edited: "22-Jan-87 21:09") - (* General purpose display function for an XREF  - imageobject. Relies on XREF.GET.DISPLAY.TEXT to get  - the actual text that must be displayed.) - (LET* ((TEXT.TO.DISPLAY (XREF.GET.DISPLAY.TEXT OBJ))) - (PRIN3 TEXT.TO.DISPLAY STREAM)))) - -(XREF.IMAGEBOXFN - (LAMBDA (OBJ STREAM) (* fsg "18-Feb-87 15:35") - (* Returns the size of an XREF imageobject based on  - the string that will be used to display it which is  - found using XREF.GET.DISPLAY.TEXT.) - (DSPFONT (CURRENT.DISPLAY.FONT STREAM) - STREAM) - (create IMAGEBOX - XSIZE _(TEDIT.STRINGWIDTH (XREF.GET.DISPLAY.TEXT OBJ) - STREAM) - YSIZE _(FONTPROP STREAM 'HEIGHT) - YDESC _(FONTPROP STREAM 'DESCENT) - XKERN _ 0))) - -(XREF.PUTFN - (LAMBDA (OBJ STREAM) (* edited: "28-Jan-87 12:54") - (PRIN1 (LIST 'XREF - (fetch OBJECTDATUM of OBJ)) - STREAM))) - -(XREF.GETFN - (LAMBDA (STREAM) (* edited: "28-Jan-87 13:14") - (XREF (CADR (READ STREAM))))) - -(XREF.BUTTONEVENTINFN - (LAMBDA (OBJ STREAM) (* edited: "28-Jan-87 14:51") - (* Bogus buttoneventinfn to tell you what the tag of  - this XREF object is.) - (TEDIT.PROMPTPRINT STREAM (CONCAT "Reference to: " (fetch OBJECTDATUM of OBJ)) - T))) - -(XREF.WHENDELETEDFN - (LAMBDA (IMOBJ TARG.WINDOW.STREAM SOURCE.STR TARG.STR) (* fsg " 4-Feb-87 13:26") - (TSP.PUTCODE (IMAGEOBJPROP IMOBJ 'TAG) - NIL TARG.WINDOW.STREAM) - (AND (UPDATE? TARG.WINDOW.STREAM) - (UPDATE.XREFS TARG.WINDOW.STREAM)))) -) -(DEFINEQ - -(XREF.GET.DISPLAY.TEXT - (LAMBDA (OBJ) (* edited: "22-Jan-87 21:11") - - (* This function will first lookup a "TOOBJ", in other words, the imageobject that the XREF object OBJ is  - referencing. Then, if there is such an object, a suitable XREF display method is found using XREF.GET.DISPLAYFN. - If such a function is found, then it is applied to TOOBJ and a string to be displayed is returned.) - - - (LET ((TOOBJ (XREF.GET.TOOBJ (fetch OBJECTDATUM of OBJ))) - SPECIFIC.DISPLAYFN) - (COND - (TOOBJ (COND - ((SETQ SPECIFIC.DISPLAYFN (XREF.GET.DISPLAYFN TOOBJ)) - (APPLY* SPECIFIC.DISPLAYFN TOOBJ)) - (T (RINGBELLS) - (CONCAT "??? Unknown XREF display method for " (TSPOBJ.GETTYPE TOOBJ) - " ???")))) - (T (CONCAT "")))))) - -(XREF.GET.TOOBJ - (LAMBDA (TAG) (* edited: "22-Jan-87 19:41") - - (* This function is called in a specific context where a reference must be displayed. It is called by an XREF  - object and should return the IMAGEOBJECT that the XREF object is referencing.) - - - (LET ((WINDOW (CAR (fetch \WINDOW of TEXTOBJ)))) - (GETHASH TAG (WINDOWPROP WINDOW 'TSP.CODE.ARRAY))))) - -(TSPOBJ.GETTYPE - (LAMBDA (OBJ) (* edited: "22-Jan-87 20:16") - (IMAGEOBJPROP OBJ 'TYPE))) -) -(DEFINEQ - -(UPDATE.XREFS - (LAMBDA (WINDOW) (* edited: "22-Jan-87 21:05") - (* Update all the XREF objects in the window.) - (LET* ((TEXTOBJ (TEXTOBJ WINDOW)) - (STREAM (TEXTSTREAM WINDOW))) - (TEDIT.PROMPTPRINT STREAM "Updating XRefs..." T) - (for REF in (TSP.LIST.OF.OBJECTS TEXTOBJ (FUNCTION XREFP)) - do (TEDIT.OBJECT.CHANGED STREAM (CAR REF))) - (TEDIT.PROMPTPRINT STREAM "done.")))) - -(REBUILD.TAG.ARRAY - (LAMBDA (WINDOW) (* edited: "28-Jan-87 13:24") - (for TAG in (TSP.LIST.OF.OBJECTS (TEXTOBJ WINDOW) - (FUNCTION (LAMBDA (OBJ) - (AND (NUMBEROBJP OBJ) - (OR (IMAGEOBJPROP OBJ 'TAG) - (EQ (fetch USE - of (fetch OBJECTDATUM - of OBJ)) - 'NGROUP)))))) - do (PROGN (SETQ TAG (CAR TAG)) - (TSP.PUTCODE (OR (IMAGEOBJPROP TAG 'TAG) - (fetch LINK.TO of (fetch OBJECTDATUM of TAG))) - TAG WINDOW))))) - -(INSERT.REF - (LAMBDA (STREAM DISPLAY.PREV) (* edited: "22-Jan-87 21:01") - (LET* ((WINDOW (\TEDIT.MAINW STREAM)) - (CODE (GET.REF WINDOW STREAM "Reference to: " DISPLAY.PREV)) - (REF (XREF CODE))) - (AND CODE (TEDIT.INSERT.OBJECT REF STREAM)) - (TEDIT.PROMPTPRINT STREAM "" T)))) - -(GET.REF - (LAMBDA (WINDOW STREAM PROMPTSTR DISPLAY.PREV) (* ss: " 9-Aug-85 14:49") - (LET ((PREVREFS (TSP.LIST.REFS WINDOW))) - (COND - ((AND PREVREFS DISPLAY.PREV) - (LET ((NMENU (create MENU - TITLE _ "Known Ref Codes" - ITEMS _ PREVREFS))) - (MENU NMENU))) - (T (MKATOM (TEDIT.GETINPUT STREAM "Reference to: "))))))) - -(TSP.LIST.REFS - (LAMBDA (WINDOW) (* fsg "15-Jan-87 14:08") - - (* * Don't collect the Index or IndexEntry references here. Use the INDEX.LIST.REFS function.) - - - (LET ((REFLIST NIL)) - (MAPHASH (WINDOWPROP WINDOW 'TSP.CODE.ARRAY) - (FUNCTION (LAMBDA (VAL KY) - (SETQ REFLIST (CONS KY REFLIST))))) - REFLIST))) - -(XREF.TAG.OBJECT - (LAMBDA (OBJ STREAM TAG) (* fsg " 4-Feb-87 16:35") - - (* TAG an arbitrary imageobject for later cross-referencing. given an imageobject OBJ, a textstream STREAM, and a  - tag TAG. If TAG is nil then the user will be asked for a tag via TSP.GET.INCODE.) - - - (OR TAG (SETQ TAG (TSP.GET.INCODE WINDOW))) - (IMAGEOBJPROP OBJ 'TAG - TAG) - (TSP.PUTCODE TAG OBJ WINDOW))) - -(TSP.GET.INCODE - (LAMBDA (STREAM) (* ss: "24-Apr-86 15:46") - (LET ((CODE (MKATOM (TEDIT.GETINPUT STREAM "Codeword to use as a tag:")))) - (COND - (CODE (COND - ((TSP.GETCODEVAL CODE (\TEDIT.MAINW STREAM)) - (TEDIT.PROMPTPRINT STREAM "[Codeword already in use: Please try again]") - (TSP.GET.INCODE STREAM)) - (T (TEDIT.PROMPTPRINT STREAM "" T) - CODE))) - (T (TEDIT.PROMPTPRINT STREAM "" T)))))) - -(TSP.GETCODEVAL - (LAMBDA (CODE WINDOW) (* fsg " 4-Feb-87 14:32") - (LET ((TSP.CODE.ARRAY (WINDOWPROP WINDOW 'TSP.CODE.ARRAY))) - (GETHASH CODE TSP.CODE.ARRAY)))) - -(TSP.PUTCODE - (LAMBDA (CODE VALUE WINDOW) (* fsg " 4-Feb-87 14:34") - (PUTHASH CODE VALUE (LIST (WINDOWPROP WINDOW 'TSP.CODE.ARRAY))))) -) - - - -(* Functions for adding and retrieving the method for a gven imageobject.) - -(DEFINEQ - -(XREF.ADD.DISPLAYFN - (LAMBDA (OBJTYPE NAME.OF.FUNCTION) (* edited: "22-Jan-87 21:08") - - (* Adds an XREF display method for an imageobject of the given type. This means that the function NAME.OF.FUNCTION  - will be used to display text when an XREF object references an imageobject of type OBJTYPE.) - - - (PUTHASH OBJTYPE NAME.OF.FUNCTION XREF.DISPLAY.METHODS))) - -(XREF.GET.DISPLAYFN - (LAMBDA (OBJ) (* edited: "22-Jan-87 21:11") - (* Returns the XREF display method for an imageobject  - OBJ.) - (GETHASH (fetch USE of (fetch OBJECTDATUM of OBJ)) - XREF.DISPLAY.METHODS))) -) - - - -(* Examples of some XREF display methods.) - -(DEFINEQ - -(NGROUP.XREF.DISPLAYFN - (LAMBDA (NGROUP) (* edited: "29-Jan-87 16:07") - (* A sample XREF display method for NGROUP objects.) - (MKSTRING (fetch NUMSTRING of (fetch OBJECTDATUM of NGROUP))))) - -(NOTE.XREF.DISPLAYFN - (LAMBDA (OBJ) (* edited: "29-Jan-87 16:07") - (* A sample XREF display method for NOTE objects.) - (MKSTRING (fetch NUMSTRING of (fetch OBJECTDATUM of OBJ))))) -) -(READVARS XREF.DISPLAY.METHODS) -({H(20 ERROR) 2 NGROUP.XREF.DISPLAYFN NGROUP NOTE.XREF.DISPLAYFN NOTE }) -(PUTPROPS XREF COPYRIGHT ("Leland Stanford Junior University" 1987)) -(DECLARE: DONTCOPY - (FILEMAP ((7675) (2226 5527 (XREF 2236 . 3078) (XREFP 3080 . 3388) (XREF.DISPLAYFN 3390 . 3854) ( -XREF.IMAGEBOXFN 3856 . 4491) (XREF.PUTFN 4493 . 4693) (XREF.GETFN 4695 . 4851) (XREF.BUTTONEVENTINFN -4853 . 5238) (XREF.WHENDELETEDFN 5240 . 5525)) (5528 7093 (XREF.GET.DISPLAY.TEXT 5538 . 6475) ( -XREF.GET.TOOBJ 6477 . 6940) (TSPOBJ.GETTYPE 6942 . 7091)) (7094 NIL (UPDATE.XREFS 7104 . 7674))))) -STOP -TAG.ARRAY 7854 . 8516) (INSERT.REF 8520 . 8889) (GET.REF 8893 . 9308) (TSP.LIST.REFS 9312 . -9730) (XREF.TAG.OBJECT 9734 . 10217) (TSP.GET.INCODE 10221 . 10753) (TSP.GETCODEVAL 10757 . 10984) ( -TSP.PUTCODE 10988 . 11179)) (11272 12087 (XREF.ADD.DISPLAYFN 11284 . 11708) (XREF.GET.DISPLAYFN 11712 - . 12084)) (12145 12817 (NGROUP.XREF.DISPLAYFN 12157 . 12487) (NOTE.XREF.DISPLAYFN 12491 . 12814))))) -STOP diff --git a/obsolete/lispusers/c150fonts/C150STREAM b/obsolete/lispusers/c150fonts/C150STREAM deleted file mode 100644 index 44366442..00000000 --- a/obsolete/lispusers/c150fonts/C150STREAM +++ /dev/null @@ -1,2193 +0,0 @@ -(FILECREATED " 3-Apr-86 18:16:05" {ERIS}LIBRARY>C150STREAM.;15 139806 - - changes to: (FNS CREATEC150BUFFER) - (VARS C150COLORMAP C150FONTDIRECTORIES) - - previous date: " 3-Apr-86 16:05:11" {ERIS}LIBRARY>C150STREAM.;14) - - -(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT C150STREAMCOMS) - -(RPAQQ C150STREAMCOMS - ((CONSTANTS \C150PointsPerInch \C150RealBPP) - (FNS C150.SEPARATOR C150.SETMARGINS \C150.ALLWHITESPACE \C150.BUFFER.DOT \C150.MICROLINEFEED - \C150.SENDLINE \C150.SENDLINEINFO \C150INIT \CREATECHARSET.C150) - (FNS CREATEC150BUFFER NEWLINE.C150 NEWPAGE.C150 OPENC150STREAM C150.RESET SEND.TO.C150 - STARTPAGE.C150 \BITBLT.C150 \BLTCHAR.C150 \BLTSHADE.C150 \C150.CRLF \CHANGECHARSET.C150 - \CHARWIDTH.C150 \CLOSEFN.C150 \CREATEC150FONT \READC150FONTFILE \DRAWCIRCLE.C150 - \DRAWCURVE.C150 \DRAWELLIPSE.C150 \DRAWLINE.C150 \DSPBACKCOLOR.C150 - \DSPCLIPPINGREGION.C150 \DSPCOLOR.C150 \C150.ASSURE.COLOR \C150.LOOKUPRGB \DSPFONT.C150 - \DSPLEFTMARGIN.C150 \DSPLINEFEED.C150 \DSPOPERATION.C150 \DSPPRINTCHAR.C150 - \DSPPRINTCR/LF.C150 \DSPRESET.C150 \DSPRIGHTMARGIN.C150 \DSPXPOSITION.C150 - \DSPYPOSITION.C150 \DUMPPAGEBUFFER.C150 \FILLCIRCLE.C150 \OUTCHARFN.C150 - \SEARCHC150FONTFILES \STRINGWIDTH.C150) - (VARS MISSINGC150FONTCOERCIONS (\C150COLORTABLE) - (\C150.FRAMEBUFFER) - (\C150STREAM) - C150COLORMAP C150FONTCOERCIONS C150FONTDIRECTORIES C150FONTEXTENSIONS) - (INITVARS (C150.CLIPBUFFER T) - (\C150DEFAULTDEVICE (QUOTE CENTRONICS))) - (FNS COLORMAP.TO.C150TABLE) - (FILES COLOR XXGEOM XXFILL) - [P (IF (NOT (GETD (QUOTE POLYSHADE.BLT))) - THEN - (* A fix for KOTO, which is not necessary in n>) - (MOVD (QUOTE POLYSHADE.DISPLAY) - (QUOTE POLYSHADE.BLT] - (DECLARE: DONTEVAL@LOAD DOCOPY (P (\C150INIT)) - (FILES CENTRONICS)) - (DECLARE: EVAL@LOAD DONTCOPY (FILES (LOADFROM) - ADISPLAY LLDISPLAY)) - (MACROS \C150BackingStream))) -(DECLARE: EVAL@COMPILE - -(RPAQQ \C150PointsPerInch 120) - -(RPAQQ \C150RealBPP 4) - -(CONSTANTS \C150PointsPerInch \C150RealBPP) -) -(DEFINEQ - -(C150.SEPARATOR - [LAMBDA (BACKINGSTREAM) (* hdj - " 5-Sep-85 12:12") - (LET ((SEPR.LENGTH 30)) - (for C instring (CONCAT "g0" SEPR.LENGTH " ") do (BOUT BACKINGSTREAM C)) - (for DASH from 1 to SEPR.LENGTH do (BOUT BACKINGSTREAM 255]) - -(C150.SETMARGINS - [LAMBDA (BACKINGSTREAM C150LEFT C150RIGHT) (* hdj - " 5-Sep-85 12:21") - - (* * Set the left and right margins for the C150 printer) - - (LET [[LEFTCODE (CONCAT (FIX (TIMES 10 (if (OR (EQ C150LEFT NIL) - (LESSP C150LEFT .5) - (GEQ C150LEFT 9.0) - (GEQ C150LEFT C150RIGHT)) - then .5 - else C150LEFT] - (RIGHTCODE (CONCAT (FIX (TIMES 10 (if (OR (EQ C150RIGHT NIL) - (GREATERP C150RIGHT 9) - (LEQ C150RIGHT .5) - (LEQ C150RIGHT C150LEFT)) - then 9 - else C150RIGHT] (* send the left margin) - (BOUT BACKINGSTREAM (CHARCODE ESC)) - (BOUT BACKINGSTREAM (CHARCODE l)) - (for CHAR instring LEFTCODE do (BOUT BACKINGSTREAM CHAR)) - (BOUT BACKINGSTREAM (CHARCODE CR)) (* send the right - margin) - (BOUT BACKINGSTREAM (CHARCODE ESC)) - (BOUT BACKINGSTREAM (CHARCODE r)) - (for CHAR instring RIGHTCODE do (BOUT BACKINGSTREAM CHAR)) - (BOUT BACKINGSTREAM (CHARCODE CR]) - -(\C150.ALLWHITESPACE - [LAMBDA (BITMAP TABLES STARTINGSCAN) (* hdj - " 6-Aug-85 15:50") - (* is there anything to - print on the next 4 - scanlines?) - (LET*((MaxX (SUB1 (BITMAPWIDTH BITMAP))) - [MaxColor (SUB1 (EXPT 2 (BITSPERPIXEL BITMAP] - (COLORUSED? (ARRAY (ADD1 MaxColor) - (QUOTE POINTER) - NIL 0)) - (BlackTable (ELT TABLES 0)) - (MagentaTable (ELT TABLES 1)) - (YellowTable (ELT TABLES 2)) - (CyanTable (ELT TABLES 3))) - (for Scanline from STARTINGSCAN to (IDIFFERENCE STARTINGSCAN 3) by -1 - do (for X from 0 to MaxX do (SETA COLORUSED? (BITMAPBIT BITMAP X Scanline) - T))) - (for Value from 0 to MaxColor never (AND (ELT COLORUSED? Value) - (OR (EQ (ELT BlackTable Value) - 1) - (EQ (ELT MagentaTable Value) - 1) - (EQ (ELT YellowTable Value) - 1) - (EQ (ELT CyanTable Value) - 1]) - -(\C150.BUFFER.DOT - [LAMBDA (DOT X BUFFER) (* hdj - " 3-Aug-85 20:55") - (SETA BUFFER X DOT]) - -(\C150.MICROLINEFEED - [LAMBDA (BACKINGSTREAM) (* hdj - " 5-Sep-85 12:12") - (for CHAR instring "k1" do (BOUT BACKINGSTREAM CHAR]) - -(\C150.SENDLINE - [LAMBDA (BACKINGSTREAM LINE# COLOR BUFFER) (* hdj - " 5-Sep-85 12:13") - (for CHAR instring (CONCAT "g" (CHARACTER (IPLUS (ITIMES 4 COLOR) - (IREMAINDER LINE# 4) - (CHARCODE 0))) - (FOLDHI (ARRAYSIZE BUFFER) - 8) - " ") do (BOUT BACKINGSTREAM CHAR)) - (bind (BYTE.TO.SEND _ 0) for BYTE from 0 to (SUB1 (ARRAYSIZE BUFFER)) by 8 - do [for BIT from 7 to 0 by -1 do (SETQ BYTE.TO.SEND (LOGOR BYTE.TO.SEND - (LLSH (ELT BUFFER (IPLUS BYTE BIT)) - BIT] - (BOUT BACKINGSTREAM BYTE.TO.SEND]) - -(\C150.SENDLINEINFO - [LAMBDA (BACKINGSTREAM COLOR LENGTHINBYTES LINE#) (* hdj - " 5-Sep-85 12:13") - (for CHAR instring (CONCAT "g" (CHARACTER (IPLUS (UNFOLD COLOR 4) - LINE# - (CHARCODE 0))) - LENGTHINBYTES " ") do (BOUT BACKINGSTREAM CHAR]) - -(\C150INIT - [LAMBDA NIL (* gbn - " 5-Nov-85 19:34") - (* Initializes global - variables for the C150) - (DECLARE (GLOBALVARS \C150IMAGEOPS)) - (SETQ \C150IMAGEOPS (create IMAGEOPS - IMAGETYPE _(QUOTE C150) - IMFONT _(FUNCTION \DSPFONT.C150) - IMLEFTMARGIN _(FUNCTION \DSPLEFTMARGIN.C150) - IMRIGHTMARGIN _(FUNCTION \DSPRIGHTMARGIN.C150) - IMLINEFEED _(FUNCTION \DSPLINEFEED.C150) - IMXPOSITION _(FUNCTION \DSPXPOSITION.C150) - IMYPOSITION _(FUNCTION \DSPYPOSITION.C150) - IMCLOSEFN _(FUNCTION \CLOSEFN.C150) - IMDRAWCURVE _(FUNCTION \DRAWCURVE.C150) - IMFILLCIRCLE _(QUOTE \FILLCIRCLE.C150) - IMDRAWLINE _(FUNCTION \DRAWLINE.C150) - IMDRAWELLIPSE _(FUNCTION \DRAWELLIPSE.C150) - IMDRAWCIRCLE _(FUNCTION \DRAWCIRCLE.C150) - IMBITBLT _(FUNCTION \BITBLT.C150) - IMBLTSHADE _(FUNCTION \BLTSHADE.C150) - IMNEWPAGE _(FUNCTION NEWPAGE.C150) - IMSCALE _[FUNCTION (LAMBDA NIL - (FQUOTIENT 120 72] - IMSPACEFACTOR _(FUNCTION NILL) - IMFONTCREATE _(QUOTE C150) - IMCOLOR _(FUNCTION \DSPCOLOR.C150) - IMBACKCOLOR _(FUNCTION \DSPBACKCOLOR.C150) - IMOPERATION _(FUNCTION \DSPOPERATION.C150) - IMSTRINGWIDTH _(FUNCTION \STRINGWIDTH.C150) - IMCHARWIDTH _(FUNCTION \CHARWIDTH.C150) - IMCLIPPINGREGION _(FUNCTION \DSPCLIPPINGREGION.C150) - IMRESET _(FUNCTION \DSPRESET.C150) - IMFILLPOLYGON _(FUNCTION POLYSHADE.BLT))) - [push IMAGESTREAMTYPES (LIST (QUOTE C150) - (LIST (QUOTE OPENSTREAM) - (FUNCTION OPENC150STREAM)) - (LIST (QUOTE FONTCREATE) - (FUNCTION \CREATEC150FONT)) - (LIST (QUOTE FONTSAVAILABLE) - (FUNCTION \SEARCHC150FONTFILES)) - (LIST (QUOTE CREATECHARSET) - (FUNCTION \CREATECHARSET.C150] - (push PRINTERTYPES (LIST (LIST (QUOTE C150)) - (LIST (QUOTE CANPRINT) - (LIST (QUOTE C150))) - (LIST (QUOTE STATUS) - (FUNCTION TRUE)) - (LIST (QUOTE PROPERTIES) - (FUNCTION NILL)) - (LIST (QUOTE SEND) - (FUNCTION SEND.TO.C150)) - (LIST (QUOTE BITMAPSCALE) - NIL) - (LIST (QUOTE BITMAPFILE) - NIL))) - (ADDTOVAR DEFAULTPRINTINGHOST (C150 C150)) - (PUTPROP (QUOTE C150) - (QUOTE PRINTERTYPE) - (QUOTE C150)) - [push PRINTFILETYPES (LIST (QUOTE C150) - (LIST (QUOTE TEST) - (FUNCTION NILL)) - (LIST (QUOTE EXTENSION) - (LIST (QUOTE C150] - (DEFAULTFONT (QUOTE C150) - (QUOTE (CLASSIC 10 MRR)) - (QUOTE NEW)) - T]) - -(\CREATECHARSET.C150 - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* gbn - " 9-Jan-86 13:00") - - (* * tries to build the csinfo required for CHARSET. - Does the necessary coercions. Returns NIL when unsuccessful - (\CREATECHARSET will do the same)) - - (* * NOSLUG? means don't create an empty - (slug) csinfo if the charset is not found, just return NIL) - - (DECLARE (GLOBALVARS C150FONTCOERCIONS MISSINGC150FONTCOERCIONS)) - - (* C150FONTCOERCIONS is a list of font coercions, in the form - ((user-font real-font) (user-font real-font) ...)%. - Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, - (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a - similar list.) - - (COND - ((PROG1 (for TRANSL in C150FONTCOERCIONS bind NEWCSINFO USERFONT REALFONT - when (AND (SETQ USERFONT (CAR TRANSL)) - (EQ FAMILY (CAR USERFONT)) - (OR (NOT (CADR USERFONT)) - (EQ SIZE (CADR USERFONT))) - (OR (NOT (CADDR USERFONT)) - (EQ CHARSET (CADDR USERFONT))) - (SETQ REALFONT (CADR TRANSL)) - (SETQ NEWCSINFO (\CREATECHARSET.C150 (OR (CAR REALFONT) - FAMILY) - (OR (CADR REALFONT) - SIZE) - FACE ROTATION DEVICE (OR (CADDR REALFONT) - CHARSET) - FONTDESC NOSLUG?))) do (RETURN NEWCSINFO)) - (* Just recursively - call ourselves to - handle entries in - C150FONTCOERCIONS) - )) - ((AND (EQ ROTATION 0) (* If it is available, - this will force the - appropriate file to be - read to fill in the - charset entry) - (\READC150FONTFILE FAMILY SIZE FACE ROTATION (QUOTE C150) - CHARSET))) - (T - (* * if we get here, the font is not directly available, either it needs - to be rotated, boldified, or italicised "by hand") - - (PROG (NEWFONT XFONT XLATEDFAM) - (RETURN (COND - [(NEQ ROTATION 0) - - (* to make a rotated font (even if it is bold or whatnot), recursively - call fontcreate to get the unrotated font - (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo.) - - (OR (MEMB ROTATION (QUOTE (90 270))) - (ERROR "only implemented rotations are 0, 90 and 270." ROTATION)) - (COND - ((SETQ XFONT (FONTCREATE FAMILY SIZE FACE 0 (QUOTE C150) - T CHARSET)) - - (* actually call FONTCREATE here, rather than \CREATEC150FONT or - \CREATECHARSET.C150 so that the vanilla font that is built in this process - will be cached and not repeated.) - - (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) - then (\SFROTATECSINFO CSINFO ROTATION) - else NIL] - ((AND (EQ (fetch WEIGHT of FACE) - (QUOTE BOLD)) - (SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE - using FACE WEIGHT _(QUOTE - MEDIUM)) - 0 - (QUOTE C150) - T CHARSET))) (* if we want a bold - font, and the medium - weight font is - available, build the - medium weight version - then call \SFMAKEBOLD - on the csinfo) - (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) - then (\SFMAKEBOLD CSINFO) - else NIL)) - ((AND (EQ (fetch SLOPE of FACE) - (QUOTE ITALIC)) - (SETQ XFONT (FONTCREATE FAMILY SIZE (create FONTFACE - using FACE SLOPE _(QUOTE - REGULAR)) - 0 - (QUOTE C150) - T CHARSET))) - (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) - then (\SFMAKEITALIC CSINFO) - else NIL)) - ((for TRANSL in MISSINGC150FONTCOERCIONS bind NEWCSINFO USERFONT REALFONT - when (AND (SETQ USERFONT (CAR TRANSL)) - (EQ FAMILY (CAR USERFONT)) - (OR (NOT (CADR USERFONT)) - (EQ SIZE (CADR USERFONT))) - (OR (NOT (CADDR USERFONT)) - (EQ CHARSET (CADDR USERFONT))) - (SETQ REALFONT (CADR TRANSL)) - (SETQ NEWCSINFO (\CREATECHARSET.C150 (OR (CAR REALFONT) - FAMILY) - (OR (CADR REALFONT) - SIZE) - FACE ROTATION DEVICE - (OR (CADDR REALFONT) - CHARSET) - FONTDESC NOSLUG?))) - do (RETURN NEWCSINFO))) - ((NOT NOSLUG?) - (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTDESC) - (FONTPROP FONTDESC (QUOTE ASCENT)) - (FONTPROP FONTDESC (QUOTE DESCENT)) - (FONTPROP FONTDESC (QUOTE DEVICE]) -) -(DEFINEQ - -(CREATEC150BUFFER - [LAMBDA (WIDTH HEIGHT) (* FS " 3-Apr-86 18:14") - (LET*((BITWIDTH (ITIMES WIDTH \C150RealBPP)) - (RASTERWIDTH (FOLDHI BITWIDTH BITSPERWORD)) - (PAGES (FOLDHI (ITIMES RASTERWIDTH HEIGHT) - WORDSPERPAGE))) - - (* * (create BITMAP BITMAPBITSPERPIXEL _ \C150RealBPP BITMAPRASTERWIDTH _ - RASTERWIDTH BITMAPWIDTH _ BITWIDTH BITMAPHEIGHT _ HEIGHT BITMAPBASE _ - (OR (\ALLOCPAGEBLOCK PAGES) (HELP - "Can't allocate C150 buffer - pages needed = " PAGES)))) - - (* * Don't think code above is correct, commented out and added below, - changing BITMAPWIDTH, and ignoring \MaxBitMapWords - (safe?????) * *) - - (create BITMAP - BITMAPBITSPERPIXEL _ \C150RealBPP - BITMAPRASTERWIDTH _ RASTERWIDTH - BITMAPWIDTH _ WIDTH - BITMAPHEIGHT _ HEIGHT - BITMAPBASE _(OR (\ALLOCPAGEBLOCK PAGES) - (HELP "Can't allocate C150 buffer - pages needed = " PAGES]) - -(NEWLINE.C150 - [LAMBDA (C150STREAM) (* hdj - " 6-Jun-85 14:01") - (* Go to next line - (or next page if on - last line)) - (LET*[(C150DATA (fetch IMAGEDATA of C150STREAM)) - (NEWYPOS (IPLUS (ffetch DDYPOSITION of C150DATA) - (ffetch DDLINEFEED of C150DATA] - (COND - ((ILESSP NEWYPOS (ffetch DDClippingBottom of C150DATA)) - (NEWPAGE.C150 C150STREAM)) - (T (\DSPXPOSITION.C150 C150STREAM (ffetch DDLeftMargin of C150DATA)) - (\DSPYPOSITION.C150 C150STREAM NEWYPOS]) - -(NEWPAGE.C150 - [LAMBDA (C150STREAM) (* hdj - " 7-Aug-85 16:48") - (LET ((DD (fetch (STREAM IMAGEDATA) of C150STREAM))) - [\DUMPPAGEBUFFER.C150 (fetch DDDestination of DD) - C150STREAM - (OR \C150COLORTABLE (SETQ \C150COLORTABLE (COLORMAP.TO.C150TABLE C150COLORMAP] - (STARTPAGE.C150 C150STREAM]) - -(OPENC150STREAM - [LAMBDA (C150FILE OPTIONS) (* gbn - " 6-Nov-85 19:08") - (* Opens a C150 stream) - - (* open a C150 stream. keep a permanent pointer to the frame buffer, - because it can never be gc'ed any way, and we want to recycle it -- - only allow one of them to be open at a time, due to global frame buffer) - - (DECLARE (GLOBALVARS \C150IMAGEOPS C150BAUDRATE \C150STREAM)) - (if (AND (STREAMP \C150STREAM) - (OPENP \C150STREAM)) - then (ERROR "Sorry - you can only have one C150 stream open at one time" \C150STREAM) - else (if (EQ (FILENAMEFIELD C150FILE (QUOTE HOST)) - (QUOTE LPT)) - then (* if the hardcopy - interface is opening to - the LPT pseudodevice, - change it to be the - device that the printer - is actually connected - to.) - (SETQ C150FILE (PACKFILENAME (QUOTE HOST) - \C150DEFAULTDEVICE - (QUOTE BODY) - C150FILE))) - (LET*[(WIDTH (FIX (TIMES 8.5 \C150PointsPerInch))) - (HEIGHT (FIX (TIMES 11 \C150PointsPerInch))) - (BACKINGSTREAM (OPENSTREAM C150FILE (QUOTE OUTPUT))) - (C150STREAM (SETQ \C150STREAM (DSPCREATE (OR \C150.FRAMEBUFFER (SETQ - \C150.FRAMEBUFFER - (CREATEC150BUFFER - WIDTH HEIGHT] - (replace (STREAM F1) of C150STREAM with BACKINGSTREAM) - (replace (STREAM OUTCHARFN) of C150STREAM with (FUNCTION \OUTCHARFN.C150)) - (replace (STREAM STRMBOUTFN) of C150STREAM with (FUNCTION \DSPPRINTCHAR.C150)) - (replace (STREAM USERCLOSEABLE) of C150STREAM with T) - (replace (STREAM IMAGEOPS) of C150STREAM with \C150IMAGEOPS) - (replace (\DISPLAYDATA DDClippingRegion) of (\GETDISPLAYDATA C150STREAM) - with (CREATEREGION 0 0 WIDTH HEIGHT)) - (STREAMPROP C150STREAM (QUOTE COLORMAPCACHE) - (LIST NIL)) - (DSPLEFTMARGIN 0 C150STREAM) - (DSPRIGHTMARGIN WIDTH C150STREAM) - (DSPCOLOR 0 C150STREAM) - (DSPBACKCOLOR 7 C150STREAM) - (STARTPAGE.C150 C150STREAM) - C150STREAM]) - -(C150.RESET - [LAMBDA NIL (* gbn - " 7-Nov-85 22:42") - - (* * just does things that the user prob doesn't know about.) - - (SETQ \C150STREAM) - (CLOSEF? (QUOTE {CENTRONICS})) - (CENTRONICS.RESET]) - -(SEND.TO.C150 - [LAMBDA (HOST FILE PRINTOPTIONS) (* hdj - " 6-Jun-85 15:37") - (COPYFILE FILE (PACKFILENAME (QUOTE HOST) - (QUOTE LPT) - (QUOTE NAME) - HOST - (QUOTE EXTENSION) - (QUOTE C150]) - -(STARTPAGE.C150 - [LAMBDA (C150STREAM) (* hdj - " 6-Aug-85 11:20") - (LET*((DD (\GETDISPLAYDATA C150STREAM)) - (CREG (fetch DDClippingRegion of DD)) - (FONTASCENT (FONTASCENT (fetch DDFONT of DD))) - (PAGEBUFFER (fetch DDDestination of DD))) - (BLTSHADE (DSPBACKCOLOR NIL C150STREAM) - PAGEBUFFER) - (\DSPXPOSITION.C150 C150STREAM (fetch DDLeftMargin of DD)) - (\DSPYPOSITION.C150 C150STREAM (ADD1 (IDIFFERENCE (fetch TOP of CREG) - FONTASCENT]) - -(\BITBLT.C150 - [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH - HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT - CLIPPEDSOURCEBOTTOM) (* hdj - " 6-Jun-85 16:17") - (DECLARE (LOCALVARS . T)) - (PROG (stodx stody left top bottom right DESTBITMAP DESTINATIONNBITS (SOURCENBITS - (fetch (BITMAP - BITMAPBITSPERPIXEL - ) - of SOURCEBITMAP)) - (DESTDD (fetch IMAGEDATA of DESTSTRM))) - (SETQ DESTBITMAP (fetch DDDestination of DESTDD)) - [PROGN (* compute limits based - on clipping regions.) - (SETQ left (fetch DDClippingLeft of DESTDD)) - (SETQ bottom (fetch DDClippingBottom of DESTDD)) - (SETQ right (fetch DDClippingRight of DESTDD)) - (SETQ top (fetch 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 (fetch LEFT of CLIPPINGREGION] - [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (fetch BOTTOM of - CLIPPINGREGION - ] - [SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH of CLIPPINGREGION - ] - (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT of CLIPPINGREGION] - (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP)) - (* 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 (\PIXELOFBITADDRESS SOURCENBITS (ffetch BITMAPWIDTH of - SOURCEBITMAP - )) - (IDIFFERENCE right stodx) - (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* compute top margin) - (SETQ top (IMIN (ffetch BITMAPHEIGHT of SOURCEBITMAP) - (IDIFFERENCE top stody) - (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] - (COND - ((AND (IGREATERP right left) - (IGREATERP top bottom))) - (T (* there is nothing to - move.) - (RETURN))) - (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))) - - (* 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.) - - (COND - [(EQ SOURCENBITS DESTINATIONNBITS) (* going from one to - another of the same - size.) - (* use LLSH with - constant value rather - than multiple because - it compiles into - opcodes.) - [COND - ((EQ DESTINATIONNBITS 4) - (SETQ left (LLSH left 2)) - (SETQ right (LLSH right 2)) - (SETQ stodx (LLSH stodx 2))) - (T (SETQ left (LLSH left 3)) - (SETQ right (LLSH right 3)) - (SETQ stodx (LLSH stodx 3] (* set texture if it - will ever get looked - at.) - (AND (EQ SOURCETYPE (QUOTE MERGE)) - (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS))) - (* easy case of color - to color) - (PROG ([PILOTBBT (COND - ((type? PILOTBBT \SYSPILOTBBT) - \SYSPILOTBBT) - (T (SETQ \SYSPILOTBBT (create PILOTBBT] - (HEIGHT (IDIFFERENCE top bottom)) - (WIDTH (IDIFFERENCE right left)) - (DTY (\SFInvert DESTBITMAP (IPLUS top stody))) - (DLX (IPLUS left stodx)) - (STY (\SFInvert SOURCEBITMAP top)) - (SLX left)) - (replace PBTWIDTH of PILOTBBT with WIDTH) - (replace PBTHEIGHT of PILOTBBT with HEIGHT) - (COND - ((EQ SOURCETYPE (QUOTE MERGE)) - (\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT - OPERATION TEXTURE)) - (T (\BITBLTSUB PILOTBBT 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 (NEQ SOURCETYPE (QUOTE INPUT)) - (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE)) - (PROG ((HEIGHT (IDIFFERENCE top bottom)) - (WIDTH (IDIFFERENCE right left)) - (DBOT (IPLUS bottom stody)) - (DLFT (IPLUS left stodx))) - (SELECTQ OPERATION - ((NIL REPLACE) - (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH - HEIGHT (COLORNUMBERP (fetch (\DISPLAYDATA DDBACKGROUNDCOLOR) - of DESTDD)) - (COLORNUMBERP (fetch (\DISPLAYDATA DDFOREGROUNDCOLOR) - of DESTDD)) - 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]) - -(\BLTCHAR.C150 - [LAMBDA (CHARCODE C150STREAM C150DATA) (* hdj - "19-Jul-85 13:32") - - (* * puts a character on a C150STREAM. - Since a C150STREAM is based on a color bitmap stream, we can use - \SLOWBLTCHAR) - - [COND - ((NEQ (ffetch DDCHARSET of C150DATA) - (\CHARSET CHARCODE)) (* The charset has - changed.) - (\CHANGECHARSET.C150 C150DATA (\CHARSET CHARCODE] - (LET [(CHAR8CODE (\CHAR8CODE CHARCODE)) - (ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of (ffetch DDFONT of C150DATA] - (COND - [(EQ 0 ROTATION) - (PROG (NEWX LEFT RIGHT (CURX (ffetch DDXPOSITION of C150DATA))) - [COND - ((IGREATERP (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE C150DATA))) - (ffetch DDRightMargin of C150DATA)) (* past RIGHT margin, - force eol) - (\DSPPRINTCR/LF.C150 (CHARCODE EOL) - C150STREAM) - (SETQ CURX (ffetch DDXPOSITION of C150DATA)) - (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE C150DATA] - (* update the x - position.) - (freplace DDXPOSITION of C150DATA with NEWX) - (SETQ LEFT (IMAX (ffetch DDClippingLeft of C150DATA) - CURX)) - (SETQ RIGHT (IMIN (ffetch DDClippingRight of C150DATA) - NEWX)) - (COND - ((AND (ILESSP LEFT RIGHT) - (NEQ (ffetch PBTHEIGHT of (SETQ NEWX (ffetch DDPILOTBBT of C150DATA))) - 0)) - (SELECTQ (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA - DDDestination) - of C150DATA)) - (1 (freplace PBTDESTBIT of NEWX with LEFT) - (freplace PBTWIDTH of NEWX with (IDIFFERENCE RIGHT LEFT)) - (freplace PBTSOURCEBIT of NEWX with (IDIFFERENCE (IPLUS ( - \DSPGETCHAROFFSET - CHAR8CODE - C150DATA) - LEFT) - CURX)) - (\PILOTBITBLT NEWX 0)) - (4 (freplace PBTDESTBIT of NEWX with (SETQ LEFT (LLSH LEFT 2))) - (freplace PBTWIDTH of NEWX with (IDIFFERENCE (LLSH RIGHT 2) - LEFT)) - (freplace PBTSOURCEBIT of NEWX - with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET CHAR8CODE C150DATA - ) - 2) - LEFT) - (LLSH CURX 2))) - (\PILOTBITBLT NEWX 0)) - (8 (freplace PBTDESTBIT of NEWX with (SETQ LEFT (LLSH LEFT 3))) - (freplace PBTWIDTH of NEWX with (IDIFFERENCE (LLSH RIGHT 3) - LEFT)) - (freplace PBTSOURCEBIT of NEWX - with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET CHAR8CODE C150DATA - ) - 3) - LEFT) - (LLSH CURX 3))) - (\PILOTBITBLT NEWX 0)) - (SHOULDNT)) - T] - (T (* handle rotated fonts) - (LET [(YPOS (ffetch DDYPOSITION of C150DATA)) - (HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE C150DATA)) - (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) - (ffetch DDFONT of C150DATA] - (COND - ((EQ ROTATION 90) (* don't force CR for - rotated fonts.) - (\DSPYPOSITION.C150 C150STREAM (IPLUS YPOS HEIGHTMOVED)) - (* update the display - stream x position.) - (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) - 0 - (\DSPGETCHAROFFSET CHAR8CODE C150DATA) - C150STREAM - (ADD1 (IDIFFERENCE (ffetch DDXPOSITION of C150DATA) - (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO))) - YPOS - (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) - (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) - HEIGHTMOVED)) - ((EQ ROTATION 270) - (\DSPYPOSITION.C150 C150STREAM (IDIFFERENCE YPOS HEIGHTMOVED)) - (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) - 0 - (\DSPGETCHAROFFSET CHAR8CODE C150DATA) - C150STREAM - (IDIFFERENCE (ffetch DDXPOSITION of C150DATA) - (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) - (ffetch DDYPOSITION of C150STREAM) - (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"]) - -(\BLTSHADE.C150 - [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) - (* gbn - " 5-Nov-85 18:42") - (* BLTSHADE to C150 - color printer) - (DECLARE (LOCALVARS . T)) - (PROG (left top bottom right DESTINATIONNBITS DESTINATIONBITMAP (DESTDD (fetch IMAGEDATA - of STREAM))) - (SETQ DESTINATIONLEFT DESTINATIONLEFT) - (SETQ DESTINATIONBOTTOM DESTINATIONBOTTOM) - [PROGN (* compute limits based - on clipping regions.) - (SETQ left (fetch DDClippingLeft of DESTDD)) - (SETQ bottom (fetch DDClippingBottom of DESTDD)) - (SETQ right (fetch DDClippingRight of DESTDD)) - (SETQ top (fetch 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 (fetch LEFT of CLIPPINGREGION] - [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (fetch BOTTOM of - CLIPPINGREGION - ] - [SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH of CLIPPINGREGION - ] - (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT of CLIPPINGREGION] - [SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of (SETQ DESTINATIONBITMAP - (fetch DDDestination - of DESTDD] - (* SETQ right - (\PIXELOFBITADDRESS - DESTINATIONNBITS right)) - (* 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 (COND - ((NULL TEXTURE) - (DSPBACKCOLOR NIL STREAM)) - [(FIXP TEXTURE) (* 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 (COND - ((EQ DESTINATIONNBITS 4) - 15) - (T 255] - (T (\C150.ASSURE.COLOR TEXTURE STREAM] (* filling an area with - a texture.) - (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.) - - (* 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.) - - (PROG ([PILOTBBT (COND - ((type? PILOTBBT \SYSPILOTBBT) - \SYSPILOTBBT) - (T (SETQ \SYSPILOTBBT (create PILOTBBT] - (HEIGHT (IDIFFERENCE top bottom))) - (replace PBTWIDTH of PILOTBBT with (IDIFFERENCE right left)) - (replace PBTHEIGHT of PILOTBBT with HEIGHT) - (\BITBLTSUB PILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert DESTINATIONBITMAP - top) - HEIGHT - (QUOTE TEXTURE) - (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)) - TEXTURE)) - (RETURN T]) - -(\C150.CRLF - [LAMBDA (STREAM) (* hdj - "25-Jan-85 17:11") - (* Send a CRLF to the - printer) - (BOUT STREAM (CHARCODE CR)) - (BOUT STREAM (CHARCODE LF]) - -(\CHANGECHARSET.C150 - [LAMBDA (DISPLAYDATA CHARSET) (* hdj - "19-Jul-85 13:48") - (* Called when the - character set - information cached in a - display stream doesn't - correspond to CHARSET) - (PROG [BM (PBT (ffetch DDPILOTBBT of DISPLAYDATA)) - (CSINFO (COND - ((IEQP 1 (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (\DISPLAYDATA - DDDestination) - of DISPLAYDATA))) - (\GETCHARSETINFO CHARSET (ffetch DDFONT of DISPLAYDATA))) - (T (\GETCOLORCSINFO (fetch (\DISPLAYDATA DDFONT) of DISPLAYDATA) - (fetch DDFOREGROUNDCOLOR of DISPLAYDATA) - (fetch DDBACKGROUNDCOLOR of DISPLAYDATA) - (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (\DISPLAYDATA - DDDestination) - of DISPLAYDATA)) - CHARSET] - (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)) - [if (OR (NEQ (ffetch DDCHARSETASCENT of DISPLAYDATA) - (ffetch CHARSETASCENT of CSINFO)) - (NEQ (ffetch DDCHARSETDESCENT of DISPLAYDATA) - (ffetch CHARSETDESCENT of CSINFO))) - then (\SFFixY DISPLAYDATA CSINFO) - else (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of BM) - (ITIMES (ffetch BITMAPRASTERWIDTH - of BM) - (ffetch DDCHARHEIGHTDELTA - of DISPLAYDATA])]) - -(\CHARWIDTH.C150 - [LAMBDA (C150STREAM CHARCODE) (* hdj - " 5-Jun-85 12:56") - (* gets the width of a - character code in a - display stream. - Need to fix up for - spacefactor.) - (\FGETWIDTH (ffetch (\DISPLAYDATA DDWIDTHSCACHE) of (ffetch IMAGEDATA of C150STREAM)) - CHARCODE]) - -(\CLOSEFN.C150 - [LAMBDA (C150STREAM) (* hdj - " 4-Oct-85 12:31") - - (* * do cleanup prefatory to closing. dump last buffer and close the - backing stream) - - (LET ((DD (fetch (STREAM IMAGEDATA) of C150STREAM))) - [\DUMPPAGEBUFFER.C150 (fetch DDDestination of DD) - C150STREAM - (OR \C150COLORTABLE (SETQ \C150COLORTABLE (COLORMAP.TO.C150TABLE C150COLORMAP] - (CLOSEF (\C150BackingStream C150STREAM]) - -(\CREATEC150FONT - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn - " 8-Jan-86 17:09") - - (* * create a font for the C150, synthesizing it if we must) - - (PROG [(FONTDESC (create FONTDESCRIPTOR - FONTDEVICE _(QUOTE C150) - FONTFAMILY _ FAMILY - FONTSIZE _ SIZE - FONTFACE _ FACE - \SFAscent _ 0 - \SFDescent _ 0 - \SFHeight _ 0 - ROTATION _ ROTATION - FONTDEVICESPEC _(LIST FAMILY SIZE FACE ROTATION (QUOTE C150] - (if (\GETCHARSETINFO CHARSET FONTDESC T) - then (RETURN FONTDESC) - else (RETURN NIL]) - -(\READC150FONTFILE - [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* hdj - "26-Sep-85 21:49") - (DECLARE (GLOBALVARS C150FONTEXTENSIONS C150FONTDIRECTORIES)) - (bind FONTFILE CSINFO STRM for EXT inside C150FONTEXTENSIONS - when (SETQ FONTFILE (FINDFILE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET) - T C150FONTDIRECTORIES)) - do (SETQ STRM (OPENSTREAM FONTFILE (QUOTE INPUT))) - (RESETLST (SETQ CSINFO (\READACFONTFILE STRM FAMILY SIZE FACE))) - - (* If not a recognizable format, I guess we should keep looking for - another possible extension, altho it would also be nice to tell the user - that he has a bogus file.) - - (RETURN CSINFO]) - -(\DRAWCIRCLE.C150 - [LAMBDA (C150STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* gbn - " 9-Jan-86 13:36") - (* \DRAWCIRCLE.C150 - extended for color. - Color is specified by - either BRUSH or the - DSPCOLOR of DS.) - - (* * how is a litatom passed in as brush?) - - (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) - (T (GLOBALRESOURCE \BRUSHBBT - (PROG ((BRUSH (create BRUSH using BRUSH BRUSHCOLOR _(\C150.ASSURE.COLOR (fetch - BRUSHCOLOR - of BRUSH) - C150STREAM))) - (X 0) - (Y RADIUS) - (D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) - DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT - LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE - BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION HEIGHTMINUS1 - CX CY (BBT \BRUSHBBT) - COLOR COLORBRUSHBASE NBITS (DISPLAYDATA (fetch IMAGEDATA of C150STREAM)) - (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 (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH 2)))) - (4 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 2) - 2)))) - (8 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 3) - 2)))) - (SHOULDNT)) (* take into account - the brush thickness.) - (SETQ CY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2))) - (* Move the window to - top while - interruptable, but - verify that it is still - there uninterruptably - with drawing points) - )) - [COND - ((EQ RADIUS 1) (* put a single brush - down.) - (* draw the top and - bottom most points.) - (COND - (USERFN (APPLY* USERFN CX CY C150STREAM)) - (T (\CURVEPT CX CY))) - (RETURN)) - (T (* draw the top and - bottom most points.) - (COND - (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS) - C150STREAM) - (APPLY* USERFN CX (IDIFFERENCE CY RADIUS) - C150STREAM)) - (T (\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 C150STREAM) - (APPLY* USERFN (IDIFFERENCE CX X) - CY C150STREAM)) - (T (\CURVEPT (IPLUS CX X) - CY) - (\CURVEPT (IDIFFERENCE CX X) - CY] - (T (COND - (USERFN (APPLY* USERFN (IPLUS CX X) - (IPLUS CY Y) - C150STREAM) - (APPLY* USERFN (IDIFFERENCE CX X) - (IPLUS CY Y) - C150STREAM) - (APPLY* USERFN (IPLUS CX X) - (IDIFFERENCE CY Y) - C150STREAM) - (APPLY* USERFN (IDIFFERENCE CX X) - (IDIFFERENCE CY Y) - C150STREAM)) - (T (\CIRCLEPTS CX CY X Y))) - (GO LP))) - (MOVETO CENTERX CENTERY C150STREAM) - (RETURN NIL]) - -(\DRAWCURVE.C150 - [LAMBDA (C150STREAM KNOTS CLOSED BRUSH DASHING) (* gbn - "12-Jan-86 15:03") - (* draws a spline curve - with a given brush.) - (GLOBALRESOURCE \BRUSHBBT (PROG ([DASHLST (AND DASHING - (OR (AND (LISTP DASHING) - (EVERY DASHING (FUNCTION FIXP)) - DASHING) - (\ILLEGAL.ARG DASHING] - (BBT \BRUSHBBT) - (CBRUSH (CREATE BRUSH USING BRUSH BRUSHCOLOR _( - \C150.ASSURE.COLOR - (FETCH BRUSHCOLOR - OF BRUSH) - C150STREAM))) - LKNOT) - (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 (fetch XCOORD of (CAR KNOTS)) - (fetch YCOORD of (CAR KNOTS)) - BRUSH C150STREAM)) - (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 C150STREAM BBT)) - (\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED) - CBRUSH DASHLST BBT C150STREAM)) - (RETURN C150STREAM]) - -(\DRAWELLIPSE.C150 - [LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) - (* hdj - " 6-Jun-85 16:17") - (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))) - - (* 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 (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH 2)))) - (4 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 2) - 2)))) - (8 (SETQ CX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 3) - 2)))) - (SHOULDNT)) - (SETQ CY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2))) - (* Move the window to - top while - interruptable, but - verify that it is still - there uninterruptably - with drawing points) - )) - (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 (\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]) - -(\DRAWLINE.C150 - [LAMBDA (C150STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) (* gbn - " 5-Nov-85 13:39") - (* C150STREAM is - guaranteed to be a - C150STREAM Draws a line - from x1,y1 to x2,y2 - leaving the position at - x2,y2) - (PROG ((DD (fetch IMAGEDATA of C150STREAM))) - (\CLIPANDDRAWLINE (OR (FIXP X1) - (FIXR X1)) - (OR (FIXP Y1) - (FIXR Y1)) - (OR (FIXP X2) - (FIXR X2)) - (OR (FIXP Y2) - (FIXR Y2)) - [COND - ((NULL WIDTH) - 1) - ((OR (FIXP WIDTH) - (FIXR WIDTH] - (SELECTQ OPERATION - (NIL (ffetch DDOPERATION of DD)) - ((REPLACE PAINT INVERT ERASE) - OPERATION) - (\ILLEGAL.ARG OPERATION)) - (ffetch DDDestination of DD) - (ffetch DDClippingLeft of DD) - (SUB1 (ffetch DDClippingRight of DD)) - (ffetch DDClippingBottom of DD) - (SUB1 (ffetch DDClippingTop of DD)) - C150STREAM - (\C150.ASSURE.COLOR COLOR C150STREAM))) (* the generic case of - MOVETO is used so that - the hardcopy streams - get handled as well.) - (MOVETO X2 Y2 C150STREAM]) - -(\DSPBACKCOLOR.C150 - [LAMBDA (STREAM COLOR) (* rmk: - "12-Sep-84 09:54") - (* sets and returns a - display stream's - background color.) - (PROG (COLORCELL (DD (\GETDISPLAYDATA STREAM))) - (SETQ COLORCELL (fetch DDCOLOR of DD)) - (RETURN (COND - (COLOR (OR (\POSSIBLECOLOR COLOR) - (\ILLEGAL.ARG COLOR)) - (PROG1 (COND - (COLORCELL (PROG1 (CDR COLORCELL) - (RPLACD COLORCELL COLOR))) - (T (* no color cell yet, - make one.) - (replace DDCOLOR of DD with (CONS WHITECOLOR COLOR)) - BLACKCOLOR)) - (\SFFixFont STREAM DD))) - (T (OR (CDR COLORCELL) - BLACKCOLOR]) - -(\DSPCLIPPINGREGION.C150 - [LAMBDA (C150STREAM REGION) (* hdj - " 5-Jun-85 12:56") - (* sets the clipping - region of a display - stream.) - (PROG ((DD (\GETDISPLAYDATA C150STREAM))) - (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) - (\SFFixY DD))]) - -(\DSPCOLOR.C150 - [LAMBDA (STREAM COLOR) (* gbn - "13-Jan-86 12:08") - (* sets and returns a - display stream's - foreground color.) - (LET (CURRENTCOLOR NEWCOLOR (DD (\GETDISPLAYDATA STREAM))) - (SETQ CURRENTCOLOR (fetch DDCOLOR of DD)) - (COND - (COLOR (SETQ NEWCOLOR (\C150.ASSURE.COLOR COLOR STREAM)) - (PROG1 (COND - (CURRENTCOLOR (PROG1 (CAR CURRENTCOLOR) - (RPLACA CURRENTCOLOR NEWCOLOR))) - (T (* no color cell yet, - make one.) - (replace DDCOLOR of DD with (CONS NEWCOLOR BLACKCOLOR)) - WHITECOLOR)) - (\SFFixFont STREAM DD))) - (T (OR (CAR CURRENTCOLOR) - WHITECOLOR]) - -(\C150.ASSURE.COLOR - [LAMBDA (COLOR# C150STREAM) (* gbn - " 7-Jan-86 17:44") - (PROG (LEVELS) - (AND (COND - ((NULL COLOR) - (RETURN (DSPCOLOR NIL C150STREAM))) - [(FIXP COLOR#) - (RETURN (COND - ((AND (IGEQ COLOR# 0) - (ILESSP COLOR# 8) - COLOR#)) - (T (\ILLEGAL.ARG COLOR#] - [(LITATOM COLOR#) - (RETURN (COND - ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR#)) (* recursively look up - color number) - (\C150.ASSURE.COLOR (CDR LEVELS) - C150STREAM)) - (T (ERROR "Unknown color name" COLOR#] - ((EQ (LENGTH COLOR#) - 2) (* temporarily, handle - the case of being given - a texture and a color, - by using the color) - (RETURN (\C150.ASSURE.COLOR (CADR COLOR#) - C150STREAM))) - ((HLSP COLOR#) (* HLS form convert to - RGB) - (SETQ LEVELS (HLSTORGB COLOR#))) - ((RGBP COLOR#) (* check for RGB or HLS) - (SETQ LEVELS COLOR#)) - ((TYPENAMEP COLOR# (QUOTE BITMAP)) (* just a hack to not - blow up) - (RETURN (IMOD (for I from 1 to (BITMAPWIDTH COLOR#) - sum (BITMAPBIT COLOR# I 1)) - 8))) - (T (\ILLEGAL.ARG COLOR#))) - (RETURN (COND - ((\C150.LOOKUPRGB LEVELS C150STREAM)) - (T (ERROR COLOR# "not available in color map"]) - -(\C150.LOOKUPRGB - [LAMBDA (RGB C150STREAM) (* gbn - " 5-Nov-85 15:47") - - (* * returns the colormap index whose value is RGB. - Looks first in the cache, then runs through the colormap. - Returns NIL if RGB NOT found) - - (DECLARE (GLOBALVARS C150COLORMAP)) - (PROG [INDEX (CACHE (STREAMPROP C150STREAM (QUOTE COLORMAPCACHE] - (RETURN (if (SETQ INDEX (SASSOC RGB CACHE)) - then (CDR INDEX) - else [SETQ INDEX (bind (CM _ C150COLORMAP) for I from 0 - to (SUB1 (EXPT 2 3)) - thereis (AND (EQ (\GENERIC.COLORLEVEL CM I (QUOTE RED)) - (fetch (RGB RED) of LEVELS)) - (EQ (\GENERIC.COLORLEVEL CM I (QUOTE GREEN)) - (fetch (RGB GREEN) of LEVELS)) - (EQ (\GENERIC.COLORLEVEL CM I (QUOTE BLUE)) - (fetch (RGB BLUE) of LEVELS] - (if INDEX - then (PUTASSOC RGB INDEX CACHE)) - INDEX]) - -(\DSPFONT.C150 - [LAMBDA (C150STREAM FONT) (* hdj - " 4-Oct-85 11:55") - (* sets the font that a - display stream uses to - print characters. - C150STREAM is - guaranteed to be a - stream of type C150) - (PROG (XFONT OLDFONT (DD (fetch IMAGEDATA of C150STREAM))) (* 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 (QUOTE C150) - T) - (FONTCOPY (ffetch DDFONT of DD) - FONT))) (* color case, create a - font with the current - foreground and - background colors.) - - (* (SETQ XFONT (\GETCOLORFONT XFONT (DSPCOLOR NIL C150STREAM) - (DSPBACKCOLOR NIL C150STREAM) (ffetch (BITMAP BITMAPBITSPERPIXEL) of - (ffetch (\DISPLAYDATA DDDestination) of DD))))) - (* 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))) - (\SFFixFont C150STREAM DD))]) - -(\DSPLEFTMARGIN.C150 - [LAMBDA (C150STREAM XPOSITION) (* hdj - " 5-Jun-85 12:56") - (* sets the xposition - that a carriage return - returns to.) - (PROG ((DD (fetch IMAGEDATA of C150STREAM))) - (RETURN (PROG1 (ffetch DDLeftMargin of DD) - (AND XPOSITION (COND - ((AND (SMALLP XPOSITION) - (IGREATERP XPOSITION -1)) - (UNINTERRUPTABLY - (freplace DDLeftMargin of DD with XPOSITION) - (\SFFIXLINELENGTH C150STREAM))) - (T (\ILLEGAL.ARG XPOSITION]) - -(\DSPLINEFEED.C150 - [LAMBDA (C150STREAM DELTAY) (* hdj - " 5-Jun-85 12:56") - (* sets the amount that - a line feed increases - the y coordinate by.) - (PROG ((DD (fetch IMAGEDATA of C150STREAM))) - (RETURN (PROG1 (ffetch DDLINEFEED of DD) - (AND DELTAY (COND - ((NUMBERP DELTAY) - (freplace DDLINEFEED of DD with DELTAY)) - (T (\ILLEGAL.ARG DELTAY]) - -(\DSPOPERATION.C150 - [LAMBDA (C150STREAM OPERATION) (* hdj - " 5-Jun-85 12:56") - (* sets the operation - field of a display - stream) - (PROG ((DD (\GETDISPLAYDATA C150STREAM))) - (RETURN (PROG1 (fetch DDOPERATION of DD) - (COND - (OPERATION (OR (FMEMB OPERATION (QUOTE (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))]) - -(\DSPPRINTCHAR.C150 - [LAMBDA (STREAM CHARCODE) (* hdj - " 5-Jun-85 12:56") - (* Displays the - character and - increments the - Xposition. STREAM is - guaranteed to be of - type display.) - (PROG ((DD (fetch IMAGEDATA of STREAM))) - (SELCHARQ CHARCODE - ((EOL CR LF) - (\DSPPRINTCR/LF.C150 CHARCODE STREAM) - (replace CHARPOSITION of STREAM with 0)) - (LF (\DSPPRINTCR/LF.C150 CHARCODE STREAM)) - (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) - STREAM))) - (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) - (if (IGREATERP (\DISPLAYSTREAMINCRXPOSITION - (SETQ TABWIDTH (IDIFFERENCE TABWIDTH - (MOD (IDIFFERENCE (fetch DDXPOSITION - of DD) - (ffetch DDLeftMargin - of DD)) - TABWIDTH))) - DD) - (ffetch DDRightMargin of DD)) - then (* tab was past - rightmargin, force cr.) - (\DSPPRINTCR/LF.C150 (CHARCODE EOL) - STREAM)) (* return the number of - spaces taken.) - (add (fetch CHARPOSITION of STREAM) - (IQUOTIENT TABWIDTH SPACEWIDTH)))) - (add (fetch CHARPOSITION of STREAM) - (IPLUS (if (ILESSP CHARCODE 32) - then (* CONTROL character) - (\BLTCHAR.C150 CHARCODE STREAM DD) - 0 - else (\BLTCHAR.C150 CHARCODE STREAM DD) - 1]) - -(\DSPPRINTCR/LF.C150 - [LAMBDA (CHARCODE DS) (* hdj - " 6-Jun-85 14:08") - (* CHARCODE is EOL, CR, - or LF Assumes that DS - has been checked by - \DSPPRINTCHAR) - (PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch IMAGEDATA of DS))) - (COND - ((AND (fetch DDSlowPrintingCase of DD) - (NEQ (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch DDFONT of DD))) - 0)) - (PROG ((CLIPREG (ffetch DDClippingRegion of DD)) - X) - [COND - ((EQ CHARCODE (CHARCODE EOL)) (* on LF, no change in - X) - (COND - ((SETQ Y (fetch DDEOLFN of DD)) (* call the eol - function for ds.) - (APPLY* Y DS))) - (\DSPYPOSITION.C150 DS (SELECTQ ROTATION - (90 (fetch (REGION BOTTOM) of CLIPREG)) - (270 (fetch (REGION TOP) of CLIPREG)) - (ERROR - "Only rotations supported are 0, 90 and 270" - ] - [SETQ X (IPLUS (fetch DDXPOSITION of DD) - (SELECTQ ROTATION - (90 (IMINUS (ffetch DDLINEFEED of DD))) - (270 (ffetch DDLINEFEED of DD)) - (ERROR "Only rotations supported are 0, 90 and 270"] - (DSPXPOSITION X DS))) - (T (COND - ((EQ CHARCODE (CHARCODE EOL)) (* on LF, no change in - X) - (COND - ((SETQ Y (fetch DDEOLFN of DD)) (* call the eol - function for ds.) - (APPLY* Y DS))) - (DSPXPOSITION (ffetch DDLeftMargin of DD) - DS))) - (SETQ Y (IPLUS (ffetch DDYPOSITION of DD) - (ffetch DDLINEFEED of DD))) - (DSPYPOSITION Y DS]) - -(\DSPRESET.C150 - [LAMBDA (C150STREAM) (* hdj - " 5-Aug-85 18:57") - (DECLARE (GLOBALVARS \CURRENTDISPLAYLINE)) (* resets a display - stream) - (PROG (CREG FONT FONTASCENT (DD (\GETDISPLAYDATA C150STREAM))) - (SETQ CREG (ffetch DDClippingRegion of DD)) - (SETQ FONT (fetch DDFONT of DD)) - (SETQ FONTASCENT (FONTASCENT FONT)) - (SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT) - (0 (\DSPXPOSITION.C150 C150STREAM (ffetch DDLeftMargin of DD)) - (\DSPYPOSITION.C150 C150STREAM (ADD1 (IDIFFERENCE (fetch TOP of CREG) - FONTASCENT)))) - (90 (\DSPXPOSITION.C150 C150STREAM (IPLUS (fetch LEFT of CREG) - FONTASCENT)) - (\DSPYPOSITION.C150 C150STREAM (fetch BOTTOM of CREG))) - (270 (\DSPXPOSITION.C150 C150STREAM (IDIFFERENCE (fetch RIGHT of CREG) - FONTASCENT)) - (\DSPYPOSITION.C150 C150STREAM (fetch TOP of CREG))) - (ERROR "only supported rotations are 0, 90 and 270")) - (\CLEARBM (ffetch (\DISPLAYDATA DDDestination) of DD) - (DSPBACKCOLOR NIL C150STREAM) - CREG]) - -(\DSPRIGHTMARGIN.C150 - [LAMBDA (C150STREAM XPOSITION) (* hdj - " 5-Jun-85 12:56") - (* Sets the right - margin that determines - when a cr is inserted - by print.) - (PROG (OLDRM (DD (fetch IMAGEDATA of C150STREAM))) - (SETQ OLDRM (ffetch DDRightMargin of DD)) - (COND - ((NULL XPOSITION)) - [(AND (SMALLP XPOSITION) - (IGREATERP XPOSITION -1)) (* Avoid fixing - linelength if right - margin hasn't changed.) - (OR (EQ XPOSITION OLDRM) - (UNINTERRUPTABLY - (freplace DDRightMargin of DD with XPOSITION) - (\SFFIXLINELENGTH C150STREAM))] - (T (\ILLEGAL.ARG XPOSITION))) - (RETURN OLDRM]) - -(\DSPXPOSITION.C150 - [LAMBDA (C150STREAM XPOSITION) (* hdj - " 5-Jun-85 12:56") - (* coordinate position - is stored in 15 bits in - the range -2^15 to - +2^15.) - (PROG ((DD (fetch IMAGEDATA of C150STREAM))) - (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 C150STREAM with 0)) - (T (\ILLEGAL.ARG XPOSITION]) - -(\DSPYPOSITION.C150 - [LAMBDA (DISPLAYSTREAM YPOSITION) (* hdj - " 3-Oct-85 17:57") - (LET ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) - (PROG1 (ffetch DDYPOSITION of DD) - (COND - ((NULL YPOSITION)) - ((NUMBERP YPOSITION) - (UNINTERRUPTABLY - (freplace DDYPOSITION of DD with YPOSITION) - (\INVALIDATEDISPLAYCACHE DD))) - (T (\ILLEGAL.ARG YPOSITION]) - -(\DUMPPAGEBUFFER.C150 - [LAMBDA (BITMAP C150STREAM COLOR.TABLES) (* gbn - "13-Jan-86 21:37") - (CENTRONICS.RESET C150STREAM) - (LET*[(BACKINGSTREAM (\C150BackingStream C150STREAM)) - (MAXX (SUB1 (BITMAPWIDTH BITMAP))) - (MAXY (SUB1 (BITMAPHEIGHT BITMAP))) - (LINEBYTES (FOLDHI (BITMAPWIDTH BITMAP) - BITSPERBYTE)) - (PrintingTimeInSeconds 1) - (PrintingTimer (SETUPTIMER PrintingTimeInSeconds NIL (QUOTE SECONDS] - (C150.SETMARGINS BACKINGSTREAM) - (C150.SEPARATOR BACKINGSTREAM) - (bind (BLANKLINES _ 0) - (FIRSTLINE _ T) for SCANLINE from MAXY to 0 by -4 - do - (if (\C150.ALLWHITESPACE BITMAP COLOR.TABLES SCANLINE) - then (add BLANKLINES 1) - (BLOCK) - else - - (* * First dump the buffered microlinefeeds) - - (if (AND FIRSTLINE C150.CLIPBUFFER) - then (* don't bother - printing these - microlinefeeds, since - they are just the - blanks at the top of - the buffer) - (SETQ FIRSTLINE NIL) - else (for I to BLANKLINES do (\C150.MICROLINEFEED BACKINGSTREAM))) - (SETQ BLANKLINES 0) - [for SUBSCAN from 0 to 3 - do - (if (TIMEREXPIRED? PrintingTimer (QUOTE SECONDS)) - then (BLOCK) - (SETUPTIMER PrintingTimeInSeconds PrintingTimer (QUOTE SECONDS))) - (for COLOR from 0 to 3 - do (* loop over (black - magenta yellow cyan)) - (LET [(COLOR.ARRAY.BASE (fetch (ARRAYP BASE) of (ELT COLOR.TABLES COLOR] - (\C150.SENDLINEINFO BACKINGSTREAM COLOR LINEBYTES SUBSCAN) - (for XPOSITION from 0 to MAXX by 8 - do (BOUT BACKINGSTREAM (for BIT from 0 to 7 - sum (LLSH (\GETBASE COLOR.ARRAY.BASE - (BITMAPBIT BITMAP - (IPLUS XPOSITION BIT) - (IDIFFERENCE SCANLINE - SUBSCAN))) - (IDIFFERENCE 7 BIT] - (\C150.MICROLINEFEED BACKINGSTREAM)) - finally (if (NOT C150.CLIPBUFFER) - then (* print out the - remaining - microlinefeeds) - (for I from 1 to BLANKLINES do (\C150.MICROLINEFEED BACKINGSTREAM]) - -(\FILLCIRCLE.C150 - [LAMBDA (C150STREAM CENTERX CENTERY RADIUS TEXTURE) (* hdj - " 6-Jun-85 16:17") - (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 (fetch IMAGEDATA of C150STREAM)) - (X 0) - (Y RADIUS) - (D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) - DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE - NBITS (FCBBT \BRUSHBBT)) - (SETQ TOP (SUB1 (fetch DDClippingTop of DISPLAYDATA))) - (SETQ BOTTOM (fetch DDClippingBottom of DISPLAYDATA)) - (SETQ LEFT (fetch DDClippingLeft of DISPLAYDATA)) - (SETQ RIGHT (SUB1 (fetch DDClippingRight of DISPLAYDATA))) - (SETQ OPERATION (ffetch DDOPERATION of DISPLAYDATA)) - (SETQ DestinationBitMap (fetch DDDestination of DISPLAYDATA)) - (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap)) - [SETQ TEXTUREBM (COND - ((BITMAPP TEXTURE)) - [(AND (NEQ NBITS 1) - (BITMAPP (COLORTEXTUREFROMCOLOR# - (COLORNUMBERP (OR TEXTURE (DSPCOLOR NIL - C150STREAM - ] - [(AND (NULL TEXTURE) - (BITMAPP (ffetch DDTexture of DISPLAYDATA] - ([OR (FIXP TEXTURE) - (AND (NULL TEXTURE) - (SETQ TEXTURE (ffetch DDTexture of DISPLAYDATA] - (* create bitmap for - the texture. Could - reuse a bitmap but for - now this is good - enough.) - (SETQ TEXTUREBM (BITMAPCREATE 16 4)) - (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) - (\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE - 12) - 15))) - (\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8 - ) - 15))) - (\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4 - ) - 15))) - (\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15))) - TEXTUREBM) - (T (\ILLEGAL.ARG TEXTURE] - (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) - (SETQ DESTINATIONBASE (fetch BITMAPBASE of DestinationBitMap)) - (SETQ RASTERWIDTH (fetch BITMAPRASTERWIDTH of DestinationBitMap)) - (* update as many - fields in the brush - bitblt table as - possible from DS.) - (replace PBTFLAGS of FCBBT with 0) - (replace PBTDESTBPL of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD)) - (* clear gray - information. - PBTSOURCEBPL is used - for gray information - too.) - (replace PBTSOURCEBPL of FCBBT with 0) - (replace PBTUSEGRAY of FCBBT with T) - [replace PBTGRAYWIDTHLESSONE of FCBBT - with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH) of TEXTUREBM) - 16] - [replace PBTGRAYHEIGHTLESSONE of FCBBT - with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT) of TEXTUREBM - ) - 16] - (replace PBTDISJOINT of FCBBT with T) - (\SETPBTFUNCTION FCBBT (QUOTE TEXTURE) - OPERATION) - (replace PBTHEIGHT of FCBBT with 1) (* take into account - the brush thickness.) - (SETQ CX CENTERX) - (SETQ CY CENTERY) (* change Y TOP and - BOTTOM to be in bitmap - coordinates) - (SETQ CY (\SFInvert DestinationBitMap CY)) - [SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DestinationBitMap TOP)) - (SETQ TOP (SUB1 (\SFInvert DestinationBitMap BOTTOM] - (COND - ((EQ RADIUS 0) (* put a single point - down. Use \LINEBLT to - get proper texture. - NIL) - (\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.) - (\LINEBLT FCBBT (IDIFFERENCE CX X) - CY - (IPLUS CX X) - DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH - GRAYHEIGHT GRAYBASE NBITS)) - (T (\FILLCIRCLEBLT CX CY X Y) - (SETQ Y (SUB1 Y)) - (GO LP))) - (MOVETO CENTERX CENTERY C150STREAM) - (RETURN NIL]) - -(\OUTCHARFN.C150 - [LAMBDA (C150STREAM CHARCODE) (* hdj - "10-Jun-85 15:14") - (SELCHARQ CHARCODE - (EOL (* New Line) - (NEWLINE.C150 C150STREAM) - (replace (STREAM CHARPOSITION) of C150STREAM with 0)) - (LF (* Line feed--move - down, but not over) - (\DSPXPOSITION.C150 C150STREAM (PROG1 (\DSPXPOSITION.C150 C150STREAM) - (NEWLINE.C150 C150STREAM)))) - (^L (* Form Feed) - (replace (STREAM CHARPOSITION) of C150STREAM with 0) - (NEWPAGE.C150 C150STREAM)) - (\BOUT C150STREAM CHARCODE]) - -(\SEARCHC150FONTFILES - [LAMBDA (FAMILY SIZE FACE ROTATION) (* hdj - " 5-Jun-85 14:19") - - (* * returns a list of the fonts that can be read in for the C150 device. - Rotation is ignored because it is assumed that all devices support 0 90 - and 270) - - (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES)) - (SELECTQ (SYSTEMTYPE) - (D (for E FILENAMEPATTERN FONTSFOUND THISFONT inside DISPLAYFONTEXTENSIONS - do (SETQ FILENAMEPATTERN (\FONTFILENAME FAMILY SIZE FACE E)) - [for DIR inside DISPLAYFONTDIRECTORIES - do (for FONTFILE in (DIRECTORY (PACKFILENAME (QUOTE DIRECTORY) - DIR - (QUOTE BODY) - FILENAMEPATTERN)) - do (OR (MEMBER (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE (QUOTE - DISPLAY - ))) - FONTSFOUND) - (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND] - finally (RETURN FONTSFOUND))) - (SHOULDNT]) - -(\STRINGWIDTH.C150 - [LAMBDA (C150STREAM STR RDTBL) (* hdj - " 5-Jun-85 12:56") - (* Returns the width of - for the current - font/spacefactor in - STREAM.) - (PROG (WIDTHSBASE) - (RETURN (\STRINGWIDTH.GENERIC STR (SETQ WIDTHSBASE (ffetch (\DISPLAYDATA DDWIDTHSCACHE) - of (ffetch IMAGEDATA of C150STREAM))) - RDTBL - (\FGETWIDTH WIDTHSBASE (CHARCODE SPACE]) -) - -(RPAQQ MISSINGC150FONTCOERCIONS (((GACHA) - (MODERN)) - ((TIMESROMAN) - (MODERN)) - ((HELVETICA) - (MODERN)))) - -(RPAQQ \C150COLORTABLE NIL) - -(RPAQQ \C150.FRAMEBUFFER NIL) - -(RPAQQ \C150STREAM NIL) - -(RPAQ C150COLORMAP (READARRAY 16 (QUOTE POINTER) 0)) -((0 0 0) -(0 0 255) -(0 255 0) -(255 0 0) -(255 255 0) -(255 0 255) -(0 255 255) -(255 255 255) -(0 0 0) -(0 0 255) -(0 255 0) -(255 0 0) -(255 255 0) -(255 0 255) -(0 255 255) -(255 255 255) -NIL -) - -(RPAQQ C150FONTCOERCIONS (((CLASSIC 8) - (CLASSIC 10)) - ((MODERN 8) - (MODERN 10)) - ((MODERN 24) - (MODERN 18)) - ((MODERN 18) - (CLASSIC 18)) - ((CLASSIC 24) - (CLASSIC 18)) - ((CLASSIC 12) - (CLASSIC 14)))) - -(RPAQQ C150FONTDIRECTORIES ({ERIS}LIBRARY>)) - -(RPAQQ C150FONTEXTENSIONS (C150FONT)) - -(RPAQ? C150.CLIPBUFFER T) - -(RPAQ? \C150DEFAULTDEVICE (QUOTE CENTRONICS)) -(DEFINEQ - -(COLORMAP.TO.C150TABLE - [LAMBDA (COLORMAP) (* hdj - " 3-Aug-85 21:36") - (LET*((SIZE (ARRAYSIZE COLORMAP)) - (TABLETABLE (ARRAY 4 (QUOTE POINTER) - NIL 0)) - (BLACKTABLE (ARRAY SIZE (QUOTE SMALLP) - 0 0)) - (CYANTABLE (ARRAY SIZE (QUOTE SMALLP) - 0 0)) - (MAGENTATABLE (ARRAY SIZE (QUOTE SMALLP) - 0 0)) - (YELLOWTABLE (ARRAY SIZE (QUOTE SMALLP) - 0 0))) - (bind CYAN MAGENTA YELLOW for PIXELVAL from 0 to (SUB1 SIZE) - do [SETQ CYAN (SETA CYANTABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB RED) - of (COLORMAPENTRY - COLORMAP - PIXELVAL)) - 128] - [SETQ MAGENTA (SETA MAGENTATABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB GREEN) - of (COLORMAPENTRY - COLORMAP - PIXELVAL)) - 128] - [SETQ YELLOW (SETA YELLOWTABLE PIXELVAL (IDIFFERENCE 1 (IQUOTIENT (fetch (RGB BLUE) - of (COLORMAPENTRY - COLORMAP PIXELVAL - )) - 128] - (if (AND (EQ CYAN 1) - (EQ MAGENTA 1) - (EQ YELLOW 1)) - then (SETA CYANTABLE PIXELVAL 0) - (SETA MAGENTATABLE PIXELVAL 0) - (SETA YELLOWTABLE PIXELVAL 0) - (SETA BLACKTABLE PIXELVAL 1))) - (SETA TABLETABLE 0 BLACKTABLE) - (SETA TABLETABLE 1 MAGENTATABLE) - (SETA TABLETABLE 2 YELLOWTABLE) - (SETA TABLETABLE 3 CYANTABLE) - TABLETABLE]) -) -(FILESLOAD COLOR XXGEOM XXFILL) -(IF (NOT (GETD (QUOTE POLYSHADE.BLT))) - THEN - (* A fix for KOTO, which is not necessary in n>) - (MOVD (QUOTE POLYSHADE.DISPLAY) - (QUOTE POLYSHADE.BLT))) -(DECLARE: DONTEVAL@LOAD DOCOPY -(\C150INIT) - -(FILESLOAD CENTRONICS) -) -(DECLARE: EVAL@LOAD DONTCOPY -(FILESLOAD (LOADFROM) - ADISPLAY LLDISPLAY) -) -(DECLARE: EVAL@COMPILE -(DEFMACRO \C150BackingStream (C150STREAM) - (BQUOTE (fetch (STREAM F1) - of , C150STREAM))) -) -(PUTPROPS C150STREAM COPYRIGHT ("Xerox Corporation" 1985 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (2416 20778 (C150.SEPARATOR 2426 . 2839) (C150.SETMARGINS 2841 . 4574) ( -\C150.ALLWHITESPACE 4576 . 6320) (\C150.BUFFER.DOT 6322 . 6553) (\C150.MICROLINEFEED 6555 . 6835) ( -\C150.SENDLINE 6837 . 7856) (\C150.SENDLINEINFO 7858 . 8357) (\C150INIT 8359 . 12525) ( -\CREATECHARSET.C150 12527 . 20776)) (20779 135286 (CREATEC150BUFFER 20789 . 21931) (NEWLINE.C150 21933 - . 22878) (NEWPAGE.C150 22880 . 23386) (OPENC150STREAM 23388 . 26698) (C150.RESET 26700 . 27074) ( -SEND.TO.C150 27076 . 27516) (STARTPAGE.C150 27518 . 28241) (\BITBLT.C150 28243 . 39228) (\BLTCHAR.C150 - 39230 . 46739) (\BLTSHADE.C150 46741 . 54213) (\C150.CRLF 54215 . 54665) (\CHANGECHARSET.C150 54667 - . 58079) (\CHARWIDTH.C150 58081 . 58888) (\CLOSEFN.C150 58890 . 59533) (\CREATEC150FONT 59535 . 60463 -) (\READC150FONTFILE 60465 . 61352) (\DRAWCIRCLE.C150 61354 . 70823) (\DRAWCURVE.C150 70825 . 74177) ( -\DRAWELLIPSE.C150 74179 . 90084) (\DRAWLINE.C150 90086 . 92331) (\DSPBACKCOLOR.C150 92333 . 93755) ( -\DSPCLIPPINGREGION.C150 93757 . 94804) (\DSPCOLOR.C150 94806 . 96147) (\C150.ASSURE.COLOR 96149 . -98725) (\C150.LOOKUPRGB 98727 . 100214) (\DSPFONT.C150 100216 . 103285) (\DSPLEFTMARGIN.C150 103287 . -104410) (\DSPLINEFEED.C150 104412 . 105295) (\DSPOPERATION.C150 105297 . 106757) (\DSPPRINTCHAR.C150 -106759 . 109848) (\DSPPRINTCR/LF.C150 109850 . 112967) (\DSPRESET.C150 112969 . 114625) ( -\DSPRIGHTMARGIN.C150 114627 . 115995) (\DSPXPOSITION.C150 115997 . 117372) (\DSPYPOSITION.C150 117374 - . 118012) (\DUMPPAGEBUFFER.C150 118014 . 121744) (\FILLCIRCLE.C150 121746 . 131735) (\OUTCHARFN.C150 -131737 . 132803) (\SEARCHC150FONTFILES 132805 . 134363) (\STRINGWIDTH.C150 134365 . 135284)) (136566 -139219 (COLORMAP.TO.C150TABLE 136576 . 139217))))) -STOP diff --git a/obsolete/lispusers/c150fonts/CLASSIC10-C0.C150FONT b/obsolete/lispusers/c150fonts/CLASSIC10-C0.C150FONT deleted file mode 100644 index 007e5c75..00000000 Binary files a/obsolete/lispusers/c150fonts/CLASSIC10-C0.C150FONT and /dev/null differ diff --git a/obsolete/lispusers/c150fonts/CLASSIC14-C0.C150FONT b/obsolete/lispusers/c150fonts/CLASSIC14-C0.C150FONT deleted file mode 100644 index 1cb874ad..00000000 Binary files a/obsolete/lispusers/c150fonts/CLASSIC14-C0.C150FONT and /dev/null differ diff --git a/obsolete/lispusers/c150fonts/CLASSIC18-C0.C150FONT b/obsolete/lispusers/c150fonts/CLASSIC18-C0.C150FONT deleted file mode 100644 index efe7862d..00000000 Binary files a/obsolete/lispusers/c150fonts/CLASSIC18-C0.C150FONT and /dev/null differ diff --git a/obsolete/lispusers/c150fonts/TIMESROMAN10-C0.C150FONT b/obsolete/lispusers/c150fonts/TIMESROMAN10-C0.C150FONT deleted file mode 100644 index 5ec6b0a0..00000000 Binary files a/obsolete/lispusers/c150fonts/TIMESROMAN10-C0.C150FONT and /dev/null differ diff --git a/obsolete/lispusers/c150fonts/TIMESROMAN12-C0.C150FONT b/obsolete/lispusers/c150fonts/TIMESROMAN12-C0.C150FONT deleted file mode 100644 index 06761504..00000000 Binary files a/obsolete/lispusers/c150fonts/TIMESROMAN12-C0.C150FONT and /dev/null differ diff --git a/obsolete/lispusers/c150fonts/TIMESROMAN14-C0.C150FONT b/obsolete/lispusers/c150fonts/TIMESROMAN14-C0.C150FONT deleted file mode 100644 index 06917afa..00000000 Binary files a/obsolete/lispusers/c150fonts/TIMESROMAN14-C0.C150FONT and /dev/null differ diff --git a/obsolete/lispusers/mathserverplot b/obsolete/lispusers/mathserverplot deleted file mode 100644 index 2e7f18fd..00000000 --- a/obsolete/lispusers/mathserverplot +++ /dev/null @@ -1,1567 +0,0 @@ -(FILECREATED "15-Dec-86 11:35:38" {INDIGO}KOTO>LIBRARY>MATHSERVERPLOT.;4 49010 - - changes to: (FNS MAPL.Simple.MakePlot MAPL.ExpandFilename MAPL.Meta.MakePlot MAPL.Gen.MakePlot) - (VARS MATHSERVERPLOTCOMS) - - previous date: " 8-Dec-86 09:46:39" {INDIGO}KOTO>LIBRARY>MATHSERVERPLOT.;3) - - -(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.) - -(PRETTYCOMPRINT MATHSERVERPLOTCOMS) - -(RPAQQ MATHSERVERPLOTCOMS ((* * ALL PLOTS) - (* Files for Log functions) - (FILES plotexamples.dcom {INDIGO}IDLPLOT>FIXES>LOGPATCH.DCOM) - (* Low-level I/0 functions) - (FNS MAPL.TopLevel MAPL.MakeReadtable MAPL.ReadASCIILine - MAPL.ExpandFilename) - (* * METACODE PLOT STUFF) - (* Menu and window functions) - (FNS MAPL.Meta.TopLevel MAPL.Meta.FreeMenu MAPL.Meta.MakeIconWindow) - (* Plot functions) - (FNS MAPL.Meta.MakePlot MAPL.Meta.Plot MAPL.Meta.ASCIIToLisp) - (* Metaplot functions) - (FNS MAPL.Meta.NewPlotCom MAPL.Meta.MoveCom MAPL.Meta.DrawCom - MAPL.Meta.EndPlotCom MAPL.Meta.NewPenCom) - (* Icon bitmaps) - (BITMAPS MAPL.Meta.Icon MAPL.Meta.IconMask) - (* * SIMPLE PLOT STUFF) - (* Menu and window functions) - (FNS MAPL.Simple.TopLevel MAPL.Simple.FreeMenu - MAPL.Simple.MakeIconWindow) - (* Plot functions) - (FNS MAPL.Simple.MakePlot MAPL.Simple.Plot) - (* Icon bitmaps) - (BITMAPS MAPL.Simple.Icon MAPL.Simple.IconMask) - (* * GENERAL PLOT STUFF) - (* Menu and window functions) - (FNS MAPL.Gen.TopLevel MAPL.Gen.FreeMenu MAPL.Gen.MakeIconWindow) - (* Plot functions) - (FNS MAPL.Gen.MakePlot MAPL.Gen.Plot MAPL.Gen.ASCIIToLisp - MAPL.Gen.NewPlot MAPL.Gen.PlotObject MAPL.Gen.EndPlot - MAPL.Gen.NewPen MAPL.Gen.CollectData) - (* Icon bitmaps) - (BITMAPS MAPL.Gen.Icon MAPL.Gen.IconMask) - (* vars) - (P (MAPL.MakeReadtable)) - (GLOBALVARS MAPL.ASCIIRDTBL) - (ADDVARS (BackgroundMenuCommands (Plot% Menus - (QUOTE (MAPL.TopLevel)) - "Opens all Plot Menus" - (SUBITEMS (General% PlotMenu - (QUOTE (MAPL.Gen.TopLevel) - ) - - "Open a General Plot Menu") - (Simple% PlotMenu - (QUOTE ( -MAPL.Simple.TopLevel)) - "Open a Simple Plot Menu") - (Meta% PlotMenu - (QUOTE (MAPL.Meta.TopLevel - )) - - "Open a MetaCode Plot Menu"))))) - (VARS (BackgroundMenu NIL)))) - (* * ALL PLOTS) - - - - -(* Files for Log functions) - -(FILESLOAD plotexamples.dcom {INDIGO}IDLPLOT>FIXES>LOGPATCH.DCOM) - - - -(* Low-level I/0 functions) - -(DEFINEQ - -(MAPL.TopLevel - (LAMBDA NIL (* DSB " 5-Dec-86 11:39") - (* opens all plot menus) - (MAPL.Gen.TopLevel) - (MAPL.Simple.TopLevel) - (MAPL.Meta.TopLevel))) - -(MAPL.MakeReadtable - (LAMBDA NIL (* DSB "24-Nov-86 09:53") - - (* * Makes a readtable that reads ASCII records which end in carriage returns as strings, recognizing only CR as a  - separator character) - - - (SETQ MAPL.ASCIIRDTBL (COPYREADTABLE FILERDTBL)) - (SETSEPR (QUOTE (13)) - NIL MAPL.ASCIIRDTBL))) - -(MAPL.ReadASCIILine - (LAMBDA (fileStream) (* DSB "24-Nov-86 13:27") - - (* * reads one record from a free-form ASCII file and returns a list of the data items in that record) - - - (LET ((stringstream (OPENSTRINGSTREAM (RSTRING fileStream MAPL.ASCIIRDTBL))) - newChar) - (READC fileStream) - (while (NOT (EOFP stringstream)) collect (READ stringstream))))) - -(MAPL.ExpandFilename - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Dec-86 11:21") - (* if filename is fullFilename, expand it into the  - separate slots) - (PROG ((state (FM.READSTATE WINDOW)) - filename host directory name extension version shortName) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (SETQ host (UNPACKFILENAME filename (QUOTE HOST))) - (COND - (host (SETQ directory (UNPACKFILENAME filename (QUOTE DIRECTORY))) - (SETQ name (UNPACKFILENAME filename (QUOTE NAME))) - (SETQ extension (UNPACKFILENAME filename (QUOTE EXTENSION))) - (SETQ version (UNPACKFILENAME filename (QUOTE VERSION))) - (SETQ shortName (PACKFILENAME (QUOTE NAME) - name - (QUOTE EXTENSION) - extension - (QUOTE VERSION) - version)) - (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE FILENAME)) - WINDOW shortName) - (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE DIRECTORY)) - WINDOW directory) - (FM.CHANGELABEL (FM.ITEMFROMID WINDOW (QUOTE HOST)) - WINDOW host) - (SETQ state (FM.READSTATE WINDOW)))) - (RETURN state)))) -) - (* * METACODE PLOT STUFF) - - - - -(* Menu and window functions) - -(DEFINEQ - -(MAPL.Meta.TopLevel - (LAMBDA NIL (* DSB " 5-Dec-86 11:49") - (* Sets up the MetaCode Plot Free Menu) - (PROG (menuWindow) - (SETQ menuWindow (MAPL.Meta.FreeMenu)) (* initialize to PenFlag ON) - (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE PEN)) - menuWindow) (* set up menu window) - (WINDOWPROP menuWindow (QUOTE ICONFN) - (FUNCTION MAPL.Meta.MakeIconWindow)) - (SHAPEW menuWindow (QUOTE (200 420 271 127))) - (OPENW menuWindow)))) - -(MAPL.Meta.FreeMenu - (LAMBDA (LEFT BOTTOM) (* DSB " 3-Dec-86 12:33") - (* returns a free menu window for MetaCode plots at  - specified position) - (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD)) - (LABEL MakePlot SELECTEDFN MAPL.Meta.MakePlot)) - ((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD))) - ((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD) - ITEMS - (FILENAME)) - (TYPE EDIT ID FILENAME LABEL "")) - ((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD) - ITEMS - (DIRECTORY)) - (TYPE EDIT ID DIRECTORY LABEL "")) - ((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD) - ITEMS - (HOST)) - (TYPE EDIT ID HOST LABEL "")) - ((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD))) - ((TYPE TITLE LABEL PenWidth: FONT (MODERN 12 BOLD)) - (TYPE NWAY ID PEN LABEL ON) - (TYPE NWAY ID PEN LABEL OFF)) - (WINDOWPROPS TITLE "MetaCode Plot Menu" LEFT , LEFT BOTTOM , BOTTOM))) - ))) - -(MAPL.Meta.MakeIconWindow - (LAMBDA (WINDOW OLDICON) (* DSB " 5-Dec-86 18:01") - - (* * Creates a shrink window with an icon formed by two bit maps.) - - - (OR OLDICON (ICONW MAPL.Meta.Icon MAPL.Meta.IconMask)))) -) - - - -(* Plot functions) - -(DEFINEQ - -(MAPL.Meta.MakePlot - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Dec-86 11:32") - (* checks that required data is specified and that the - fullFilename is valid, and makes the MetaCode plot.) - (PROG ((promptW (GETPROMPTWINDOW WINDOW)) - state filename directory host penFlag fullFilename) - - (* * check that all required data is specified) - - - (CLEARW promptW) - (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PRIN1 "Unspecified file name." promptW) - (RETURN))) - (SETQ directory (LISTGET state (QUOTE DIRECTORY))) - (COND - ((EQUAL directory "") - (PRIN1 "Unspecified directory." promptW) - (RETURN))) - (SETQ host (LISTGET state (QUOTE HOST))) - (COND - ((EQUAL host "") - (PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW) - (RETURN))) - (SETQ penFlag (EQ (QUOTE ON) - (LISTGET state (QUOTE PEN)))) - - (* * make fullFilename) - - - (SETQ fullFilename (PACKFILENAME (QUOTE HOST) - host - (QUOTE DIRECTORY) - directory - (QUOTE BODY) - filename)) - - (* * if fullFilename is valid, then make plot) - - - (COND - ((NOT (INFILEP fullFilename)) - (PRIN1 "File not found" promptW) - (RETURN)) - (T (PRIN1 "Making plot ..." promptW) - (MAPL.Meta.Plot fullFilename penFlag) - (CLEARW promptW) - (PRIN1 "Done" promptW) - (RETURN)))))) - -(MAPL.Meta.Plot - (LAMBDA (file penFlag) (* DSB " 3-Dec-86 13:14") - - (* * makes a PLOT of the metacode file) - - - (PROG (dataList plot code newVal1 newVal2 curveList pen) - (SETQ dataList (MAPL.Meta.ASCIIToLisp file)) - (* (PRIN1 dataList PROMPTWINDOW)) - (COND - ((NOT dataList) - (RETURN (PROMPTPRINT "There is no data")))) - (for item in dataList - do (SETQ code (CAR item)) - (SETQ newVal1 (CADR item)) - (SETQ newVal2 (CADDR item)) - (SELECTQ code - (1 (SETQ plot (MAPL.Meta.NewPlotCom)) - (* New plot) - ) - (2 (SETQ curveList (MAPL.Meta.DrawCom curveList newVal1 newVal2))) - (3 (SETQ curveList (MAPL.Meta.MoveCom plot curveList pen newVal1 - newVal2))) - (4 (MAPL.Meta.EndPlotCom plot curveList pen) - (* End of plot) - ) - (5 (SETQ pen (MAPL.Meta.NewPenCom newVal1 penFlag)) - (* New pen) - ) - NIL))))) - -(MAPL.Meta.ASCIIToLisp - (LAMBDA (file) (* DSB "25-Nov-86 09:54") - - (* * returns ASCII data from a file in a list, with one sub-list per line. The file must end in a CR.) - - - (PROG ((tempFile (QUOTE {core}tempplot.dat)) - fileStream dataList) - (COND - ((NOT (INFILEP file)) - (RETURN NIL))) - (COPYFILE file tempFile) (* copy to {core} because reads from filestream to  - {core} are much faster than reads from filestream to a - VAX on the network.) - (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT))) - (SETQ dataList (while (NOT (EOFP tempFile)) collect (MAPL.ReadASCIILine - fileStream))) - (CLOSEF fileStream) - (DELFILE tempFile) - (RETURN dataList)))) -) - - - -(* Metaplot functions) - -(DEFINEQ - -(MAPL.Meta.NewPlotCom - (LAMBDA NIL (* DSB " 5-Dec-86 11:51") - - (* * starts a new plot) - - - (PROG NIL - (SETQ curveList NIL) - (RETURN (CREATEPLOT NIL (QUOTE (471 420 250 250)) - "MetaCode Plot"))))) - -(MAPL.Meta.MoveCom - (LAMBDA (plot curveList pen newVal1 newVal2) (* DSB "25-Nov-86 09:01") - - (* * Plots the previous curve, and moves to a new position, starting a new curve) - - - (PROG NIL - (COND - ((AND curveList (GREATERP (LENGTH curveList) - 1)) - (PLOTCURVE plot curveList NIL pen NIL T))) - (SETQ curveList (LIST (CONS newVal1 newVal2))) - (RETURN curveList)))) - -(MAPL.Meta.DrawCom - (LAMBDA (curveList newVal1 newVal2) (* DSB "24-Nov-86 13:31") - - (* * adds a new set of points to the curveList) - - - (PROG NIL - (SETQ curveList (CONS (CONS newVal1 newVal2) - curveList)) - (RETURN curveList)))) - -(MAPL.Meta.EndPlotCom - (LAMBDA (plot curveList pen) (* DSB "25-Nov-86 09:01") - - (* * plots the last curve and opens the plot. It is expected that no more curves will be drawn to the plot) - - - (PROG NIL - (COND - ((AND curveList (GREATERP (LENGTH curveList) - 1)) - (PLOTCURVE plot curveList NIL pen NIL T))) - (OPENPLOTWINDOW plot)))) - -(MAPL.Meta.NewPenCom - (LAMBDA (newVal1 penFlag) (* DSB " 3-Dec-86 15:25") - - (* * If penFlag is OFF, sets pen to 1) - - - - (* * if penFlag is ON, sets the pen to INT ((PEN + 1) /2)) - - - (PROG (pen) - (COND - (penFlag (SETQ pen (IQUOTIENT (PLUS newVal1 1) - 2))) - (T (SETQ pen 1))) - (RETURN pen)))) -) - - - -(* Icon bitmaps) - - -(RPAQ MAPL.Meta.Icon (READBITMAP)) -(70 70 -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"L@@@@@@@@@ON@@@@@L@@" -"L@@@@@@@@@GO@@@@@L@@" -"LGOH@COOOOOOOOOOLL@@" -"LDLH@B@@@@AOH@@@DL@@" -"LDLH@B@@@@@OL@@@DL@@" -"LD@H@B@@@@@GN@@@DL@@" -"LD@H@BB@@@@CO@@@DL@@" -"LNAL@BB@@@@AOH@@DL@@" -"L@@@@BF@@@@@OH@@DL@@" -"L@@@@BB@@@@@GL@@DL@@" -"L@A@@BB@@@@@CL@@DL@@" -"LCO@@BB@@@@@AN@@DL@@" -"LBA@@BF@@@@@@F@@DL@@" -"LB@@@BB@@@@@@C@@DL@@" -"LCH@@BB@@@@@@AH@DL@@" -"LCH@@BB@@CL@@GH@DL@@" -"LB@@@BF@@FF@AL@@DL@@" -"LBAAOBB@@LC@C@@@DL@@" -"LCOAOBB@AHAHN@@@DL@@" -"L@A@@BB@C@@OH@@@DL@@" -"L@@@@BF@F@@@@@@@DL@@" -"L@@@@BB@L@@@@@@@DL@@" -"LCO@@BB@H@@@@@@@DL@@" -"L@L@@BBAH@@@@@@@DL@@" -"L@L@@BFA@@@@@@@@DL@@" -"L@L@@BBC@@@@@@@@DL@@" -"L@L@@BBB@@@@@@@@DL@@" -"L@L@@BBF@@@@@@@@DL@@" -"L@@@@BFD@@@@@@@@DL@@" -"L@@@@BB@@@@@@@@@DL@@" -"L@L@@BB@@@@@@@@@DL@@" -"LAN@@BB@@@@@@@@@DL@@" -"LAB@@BGOOOOOOOONDL@@" -"LCO@@BBBBBBBBBBBDL@@" -"LBA@@B@@@@@@@@@@DL@@" -"LFAH@COOOOOOOOOOLL@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"LOOOOOH@@@@@@@@@@L@@" -"L@LOLL@@@@@@@@@@@L@@" -"LAHGHF@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@ON@OO@NALL@@" -"LC@C@C@@NF@NG@FAHL@@" -"LC@C@C@@LB@LC@FAHL@@" -"LC@C@C@@H@@LC@FAHL@@" -"LC@C@C@@LH@LC@FAHL@@" -"LC@C@C@@OH@LC@FAHL@@" -"LC@C@C@@LH@LC@FAHL@@" -"LC@GHC@@H@@LC@FAHL@@" -"LC@@@C@@LB@LC@FAHL@@" -"LC@@@C@@NF@LC@GCHL@@" -"LC@@@C@@ONALCHGOHL@@" -"LC@@@C@@@@@@@@@@@L@@" -"LOH@@GL@@@@@@@@@@L@@" -"LOH@@GL@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@") - -(RPAQ MAPL.Meta.IconMask (READBITMAP)) -(70 70 -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@") - (* * SIMPLE PLOT STUFF) - - - - -(* Menu and window functions) - -(DEFINEQ - -(MAPL.Simple.TopLevel - (LAMBDA NIL (* DSB " 8-Dec-86 08:00") - (* Sets up the Simple Plot Free Menu) - (PROG (menuWindow) - (SETQ menuWindow (MAPL.Simple.FreeMenu 200 250)) - - (* * initialize plot defaults) - - - (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE TYPE)) - menuWindow) - (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE REP)) - menuWindow) - (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE DEST)) - menuWindow) - - (* * finish setup of free menu) - - - (WINDOWPROP menuWindow (QUOTE ICONFN) - (FUNCTION MAPL.Simple.MakeIconWindow)) - (OPENW menuWindow)))) - -(MAPL.Simple.FreeMenu - (LAMBDA (LEFT BOTTOM) (* DSB " 8-Dec-86 07:59") - (* returns a free menu window for simple plots at  - specified position) - (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD)) - (LABEL MakePlot SELECTEDFN MAPL.Simple.MakePlot)) - ((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD))) - ((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD) - ITEMS - (FILENAME)) - (TYPE EDIT ID FILENAME LABEL "")) - ((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD) - ITEMS - (DIRECTORY)) - (TYPE EDIT ID DIRECTORY LABEL "")) - ((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD) - ITEMS - (HOST)) - (TYPE EDIT ID HOST LABEL "")) - ((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD))) - ((TYPE TITLE LABEL PlotType: FONT (MODERN 12 BOLD)) - (TYPE NWAY ID TYPE LABEL X-Y CLASSNAME XY) - (TYPE NWAY ID TYPE LABEL X-LogY CLASSNAME X-LogY) - (TYPE NWAY ID TYPE LABEL LogX-Y CLASSNAME LogX-Y) - (TYPE NWAY ID TYPE LABEL LogX-LogY CLASSNAME LogX-LogY)) - ((TYPE TITLE LABEL Representation: FONT (MODERN 12 BOLD)) - (TYPE NWAY ID REP LABEL Curve CLASSNAME Curve) - (TYPE NWAY ID REP LABEL Points CLASSNAME Points) - (TYPE NWAY ID REP LABEL Both CLASSNAME Both)) - ((TYPE EDITSTART LABEL PenWidth: FONT (MODERN 12 BOLD) - ITEMS - (PEN)) - (TYPE EDIT ID PEN LABEL "1")) - ((TYPE TITLE LABEL Destination: FONT (MODERN 12 BOLD)) - (TYPE NWAY ID DEST LABEL New CLASSNAME New) - (TYPE NWAY ID DEST LABEL Previous CLASSNAME Previous)) - (WINDOWPROPS TITLE "Simple Plot Menu" LEFT , LEFT BOTTOM , BOTTOM))))) -) - -(MAPL.Simple.MakeIconWindow - (LAMBDA (WINDOW OLDICON) (* DSB " 5-Dec-86 18:00") - - (* * Creates a window with an icon formed by two bit maps.) - - - (OR OLDICON (ICONW MAPL.Simple.Icon MAPL.Simple.IconMask)))) -) - - - -(* Plot functions) - -(DEFINEQ - -(MAPL.Simple.MakePlot - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Dec-86 11:27") - (* checks that required data is specified and that the - fullFilename is valid, and makes the simple plot.) - (PROG ((promptW (GETPROMPTWINDOW WINDOW)) - state filename directory host type rep penWidth dest fullFilename) - - (* * check that all required data is specified) - - - (CLEARW promptW) - (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PRIN1 "Unspecified file name." promptW) - (RETURN))) - (SETQ directory (LISTGET state (QUOTE DIRECTORY))) - (COND - ((EQUAL directory "") - (PRIN1 "Unspecified directory." promptW) - (RETURN))) - (SETQ host (LISTGET state (QUOTE HOST))) - (COND - ((EQUAL host "") - (PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW) - (RETURN))) - (SETQ type (LISTGET state (QUOTE TYPE))) - (COND - ((NOT type) - (PRIN1 "Unspecified plot type (XY, etc)." promptW) - (RETURN))) - (SETQ rep (LISTGET state (QUOTE REP))) - (COND - ((NOT rep) - (PRIN1 "Unspecified represent. (Points,etc.)" promptW) - (RETURN))) - (SETQ penWidth (MKATOM (LISTGET state (QUOTE PEN)))) - (COND - ((AND (NUMBERP penWidth) - (GREATERP penWidth 0)) - (SETQ penWidth (FIX penWidth))) - (T (PRIN1 "PenWidth must be integer > 0" promptW) - (RETURN))) - (SETQ dest (LISTGET state (QUOTE DEST))) - (COND - ((NOT dest) - (PRIN1 "Unspecified destination (New, etc.)" promptW) - (RETURN))) - - (* * make fullFilename) - - - (SETQ fullFilename (PACKFILENAME (QUOTE HOST) - host - (QUOTE DIRECTORY) - directory - (QUOTE BODY) - filename)) - - (* * if fullFilename is valid, then make plot) - - - (COND - ((NOT (INFILEP fullFilename)) - (PRIN1 "File not found" promptW) - (RETURN)) - (T (PRIN1 "Making plot ..." promptW) - (MAPL.Simple.Plot fullFilename promptW rep type penWidth dest) - (CLEARW promptW) - (PRIN1 "Done" promptW) - (RETURN)))))) - -(MAPL.Simple.Plot - (LAMBDA (filename promptW rep type penWidth dest) (* DSB " 8-Dec-86 08:53") - (* Makes the plot and puts it into the appropriate  - window) - - (* * takes an ASCII file of pairs of X-Y values, converts it into list format, and then converts it into a list of  - dotted pairs of data for requested plot.) - - - (PROG ((rightMenuItems (QUOTE ((Logscale SCAT.LOGSCALE "Toggle exponential tics" - (SUBITEMS (X% axis (SCAT.LOGSCALE (QUOTE X)) - "X axis only") - (Y% axis (SCAT.LOGSCALE (QUOTE Y)) - "Y axis only"))) - (Coordinates SCAT.WORLDCOORD - "Display world coordinates at cursor position")))) - (pointMenuItems (QUOTE ((Coordinates SCAT.POINTCOORDS "Display point coordinates")))) - (tempFile (QUOTE {core}tempplot.dat)) - data first second mouseDown? fileStream dataList newPlot) - - (* * copy to {core} and read into a list, with each line in the original file becoming a sub-list) - - - (COPYFILE filename tempFile) - (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT))) - (SETQ dataList (while (NOT (EOFP tempFile)) collect (MAPL.ReadASCIILine - fileStream))) - (CLOSEF fileStream) - (DELFILE tempFile) - - (* * translate to list of dotted pairs, depending on type of plot to be made) - - - (SETQ data NIL) - (COND - ((EQUAL type (QUOTE X-Y)) - (for item in dataList - do (SETQ first (CAR item)) - (SETQ second (CADR item)) - (COND - ((AND (NUMBERP first) - (NUMBERP second)) - (SETQ data (CONS (CONS first second) - data)))))) - ((EQUAL type (QUOTE X-LogY)) - (for item in dataList - do (SETQ first (CAR item)) - (SETQ second (CADR item)) - (COND - ((AND (NUMBERP first) - (NUMBERP second) - (GREATERP second 0)) - (SETQ data (CONS (CONS first (PLOT.LOG10 second)) - data)))))) - ((EQUAL type (QUOTE LogX-Y)) - (for item in dataList - do (SETQ first (CAR item)) - (SETQ second (CADR item)) - (COND - ((AND (NUMBERP first) - (GREATERP first 0) - (NUMBERP second)) - (SETQ data (CONS (CONS (PLOT.LOG10 first) - second) - data)))))) - ((EQUAL type (QUOTE LogX-LogY)) - (for item in dataList - do (SETQ first (CAR item)) - (SETQ second (CADR item)) - (COND - ((AND (NUMBERP first) - (GREATERP first 0) - (NUMBERP second) - (GREATERP second 0)) - (SETQ data (CONS (CONS (PLOT.LOG10 first) - (PLOT.LOG10 second)) - data)))))) - (T (CLEARW promptW) - (PRIN1 "Error: Unknown plot type" promptW) - (RETURN))) - (CLEARW promptW) - - (* * If the new data is to be put on a previous plot, the user has 20 seconds to button in the desired plot window) - - - - (* * otherwise, the data goes into a new plot) - - - (COND - ((EQUAL dest (QUOTE Previous)) - (PRIN1 "Button in desired plot window" promptW) - (SETQ mouseDown? (UNTILMOUSESTATE LEFT 20000)) - (COND - (mouseDown? (COND - ((EQUAL rep (QUOTE Points)) - (PLOTPOINTS (WHICHPLOT) - data) - (RETURN)) - ((EQUAL rep (QUOTE Curve)) - (PLOTCURVE (WHICHPLOT) - data NIL penWidth) - (RETURN)) - ((EQUAL rep (QUOTE Both)) - (PLOTPOINTS (WHICHPLOT) - data) - (PLOTCURVE (WHICHPLOT) - data NIL penWidth) - (RETURN)) - (T (PRIN1 "Error: Unknown represent." promptW) - (RETURN)))) - (T (PRIN1 "Making a new plot." promptW))))) - (SETQ newPlot (CREATEPLOT NIL (QUOTE (471 250 250 250)) - "Simple Plot")) - (PLOTADDMENUITEMS newPlot (QUOTE RIGHT) - rightMenuItems) - (PLOTMENUITEMS newPlot (QUOTE POINTMENU) - (APPEND (PLOTMENUITEMS newPlot (QUOTE MIDDLE)) - pointMenuItems)) - (COND - ((EQUAL rep (QUOTE Curve)) - (PLOTCURVE newPlot data NIL penWidth)) - ((EQUAL rep (QUOTE Points)) - (PLOTPOINTS newPlot data)) - ((EQUAL rep (QUOTE Both)) - (PLOTCURVE newPlot data NIL penWidth) - (PLOTPOINTS newPlot data)) - (T (PRIN1 "Error: Unknown represent." promptW) - (RETURN))) - (OPENPLOTWINDOW newPlot)))) -) - - - -(* Icon bitmaps) - - -(RPAQ MAPL.Simple.Icon (READBITMAP)) -(70 70 -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"L@@@@@@@@@ON@@@@@L@@" -"L@@@@@@@@@GO@@@@@L@@" -"L@@@@COOOOOOOOOOLL@@" -"L@@@@B@@@@AOH@@@DL@@" -"L@@@@B@@@@@OL@@@DL@@" -"L@@@@B@@@@@GN@@@DL@@" -"L@@@@BB@@@@CO@@@DL@@" -"L@@@@BB@@@@AOH@@DL@@" -"L@@@@BF@@@@@OH@@DL@@" -"L@@@@BB@@@@@GL@@DL@@" -"L@@@@BB@@@@@CL@@DL@@" -"LOO@@BB@@@@@AN@@DL@@" -"LLC@@BF@@@@@@F@@DL@@" -"LLC@@BB@@@@@@C@@DL@@" -"LL@@@BB@@@@@@AH@DL@@" -"LL@@@BB@@CL@@GH@DL@@" -"LL@@@BF@@FF@AL@@DL@@" -"LL@CNBB@@LC@C@@@DL@@" -"LOOCNBB@AHAHN@@@DL@@" -"L@C@@BB@C@@OH@@@DL@@" -"L@C@@BF@F@@@@@@@DL@@" -"L@C@@BB@L@@@@@@@DL@@" -"L@C@@BB@H@@@@@@@DL@@" -"LLC@@BBAH@@@@@@@DL@@" -"LLC@@BFA@@@@@@@@DL@@" -"LOO@@BBC@@@@@@@@DL@@" -"L@@@@BBB@@@@@@@@DL@@" -"L@@@@BBF@@@@@@@@DL@@" -"L@@@@BFD@@@@@@@@DL@@" -"L@@@@BB@@@@@@@@@DL@@" -"L@@@@BB@@@@@@@@@DL@@" -"L@@@@BB@@@@@@@@@DL@@" -"L@@@@BGOOOOOOOONDL@@" -"L@@@@BBBBBBBBBBBDL@@" -"L@@@@B@@@@@@@@@@DL@@" -"L@@@@COOOOOOOOOOLL@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"LOOOOOH@@@@@@@@@@L@@" -"L@LOLL@@@@@@@@@@@L@@" -"LAHGHF@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@ON@OO@NALL@@" -"LC@C@C@@NF@NG@FAHL@@" -"LC@C@C@@LB@LC@FAHL@@" -"LC@C@C@@H@@LC@FAHL@@" -"LC@C@C@@LH@LC@FAHL@@" -"LC@C@C@@OH@LC@FAHL@@" -"LC@C@C@@LH@LC@FAHL@@" -"LC@GHC@@H@@LC@FAHL@@" -"LC@@@C@@LB@LC@FAHL@@" -"LC@@@C@@NF@LC@GCHL@@" -"LC@@@C@@ONALCHGOHL@@" -"LC@@@C@@@@@@@@@@@L@@" -"LOH@@GL@@@@@@@@@@L@@" -"LOH@@GL@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@") - -(RPAQ MAPL.Simple.IconMask (READBITMAP)) -(70 70 -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@") - (* * GENERAL PLOT STUFF) - - - - -(* Menu and window functions) - -(DEFINEQ - -(MAPL.Gen.TopLevel - (LAMBDA NIL (* DSB " 5-Dec-86 11:45") - (* Sets up the General Plot Free Menu) - (PROG (menuWindow) - (SETQ menuWindow (MAPL.Gen.FreeMenu 200 50)) - - (* * initialize plot defaults) - - - (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE TYPE)) - menuWindow) - (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE REP)) - menuWindow) - (FM.CHANGESTATE (FM.ITEMFROMID menuWindow (QUOTE PEN)) - menuWindow) - - (* * finish setup of free menu) - - - (WINDOWPROP menuWindow (QUOTE ICONFN) - (FUNCTION MAPL.Gen.MakeIconWindow)) - (OPENW menuWindow)))) - -(MAPL.Gen.FreeMenu - (LAMBDA (LEFT BOTTOM) (* DSB " 4-Dec-86 13:09") - (* returns a free menu window for simple plots at  - specified position) - (FM.FORMATMENU (BQUOTE (((TYPE TITLE LABEL Command: FONT (MODERN 12 BOLD)) - (LABEL MakePlot SELECTEDFN MAPL.Gen.MakePlot)) - ((TYPE TITLE LABEL "FILE INFO" FONT (MODERN 12 BOLD))) - ((TYPE EDITSTART LABEL Filename: FONT (MODERN 12 BOLD) - ITEMS - (FILENAME)) - (TYPE EDIT ID FILENAME LABEL "")) - ((TYPE EDITSTART LABEL Directory: FONT (MODERN 12 BOLD) - ITEMS - (DIRECTORY)) - (TYPE EDIT ID DIRECTORY LABEL "")) - ((TYPE EDITSTART LABEL Host: FONT (MODERN 12 BOLD) - ITEMS - (HOST)) - (TYPE EDIT ID HOST LABEL "")) - ((TYPE TITLE LABEL "PLOT INFO" FONT (MODERN 12 BOLD))) - ((TYPE EDITSTART LABEL X-Position: FONT (MODERN 12 BOLD) - ITEMS - (XPOS)) - (TYPE EDIT ID XPOS LABEL "1")) - ((TYPE EDITSTART LABEL Y-Position: FONT (MODERN 12 BOLD) - ITEMS - (YPOS)) - (TYPE EDIT ID YPOS LABEL "2")) - ((TYPE TITLE LABEL PlotType: FONT (MODERN 12 BOLD)) - (TYPE NWAY ID TYPE LABEL X-Y CLASSNAME XY) - (TYPE NWAY ID TYPE LABEL X-LogY CLASSNAME X-LogY) - (TYPE NWAY ID TYPE LABEL LogX-Y CLASSNAME LogX-Y) - (TYPE NWAY ID TYPE LABEL LogX-LogY CLASSNAME LogX-LogY)) - ((TYPE TITLE LABEL Representation: FONT (MODERN 12 BOLD)) - (TYPE NWAY ID REP LABEL Curve CLASSNAME Curve) - (TYPE NWAY ID REP LABEL Points CLASSNAME Points) - (TYPE NWAY ID REP LABEL Both CLASSNAME Both)) - ((TYPE TITLE LABEL PenWidth: FONT (MODERN 12 BOLD)) - (TYPE NWAY ID PEN LABEL ON) - (TYPE NWAY ID PEN LABEL OFF)) - (WINDOWPROPS TITLE "General Plot Menu" LEFT , LEFT BOTTOM , BOTTOM)))) - )) - -(MAPL.Gen.MakeIconWindow - (LAMBDA (WINDOW OLDICON) (* DSB " 5-Dec-86 17:42") - - (* * Creates a shrink window with an icon formed by two bit maps.) - - - (OR OLDICON (ICONW MAPL.Gen.Icon MAPL.Gen.IconMask)))) -) - - - -(* Plot functions) - -(DEFINEQ - -(MAPL.Gen.MakePlot - (LAMBDA (ITEM WINDOW BUTTONS) (* DSB "15-Dec-86 11:30") - (* checks that required data is specified and that the - fullFilename is valid, and makes the simple plot.) - (PROG ((promptW (GETPROMPTWINDOW WINDOW)) - state filename directory host type rep xPos yPos penFlag fullFilename) - - (* * check that all required data is specified) - - - (CLEARW promptW) - (SETQ state (MAPL.ExpandFilename ITEM WINDOW BUTTONS)) - (SETQ filename (LISTGET state (QUOTE FILENAME))) - (COND - ((EQUAL filename "") - (PRIN1 "Unspecified file name." promptW) - (RETURN))) - (SETQ directory (LISTGET state (QUOTE DIRECTORY))) - (COND - ((EQUAL directory "") - (PRIN1 "Unspecified directory." promptW) - (RETURN))) - (SETQ host (LISTGET state (QUOTE HOST))) - (COND - ((EQUAL host "") - (PRIN1 "Unspecified host (DSK,IVY,etc.)" promptW) - (RETURN))) - (SETQ xPos (MKATOM (LISTGET state (QUOTE XPOS)))) - (* if xPos is not a number, set it to NIL for a  - Time-Series plot) - (COND - ((NOT (NUMBERP xPos)) - (SETQ xPos (NUMBERP xPos)) - (PRIN1 "Time-series plot..." promptW))) - (SETQ yPos (MKATOM (LISTGET state (QUOTE YPOS)))) - (COND - ((NOT (NUMBERP yPos)) - (PRIN1 "Unspecified position of 'Y' variable" promptW) - (RETURN))) - (SETQ type (LISTGET state (QUOTE TYPE))) - (COND - ((NOT type) - (PRIN1 "Unspecified plot type (XY, etc)." promptW) - (RETURN))) (* if xPos is NIL, do not allow Logs of the "time") - (COND - ((AND (NOT xPos) - (OR (EQUAL type (QUOTE LogX-Y)) - (EQUAL type (QUOTE LogX-LogY)))) - (PRIN1 "Log of X (time) not permitted" promptW) - (RETURN))) - (SETQ rep (LISTGET state (QUOTE REP))) - (COND - ((NOT rep) - (PRIN1 "Unspecified represent. (Points,etc.)" promptW) - (RETURN))) - (SETQ penFlag (EQ (QUOTE ON) - (LISTGET state (QUOTE PEN)))) - - (* * make fullFilename) - - - (SETQ fullFilename (PACKFILENAME (QUOTE HOST) - host - (QUOTE DIRECTORY) - directory - (QUOTE BODY) - filename)) - - (* * if fullFilename is valid, then make plot) - - - (COND - ((NOT (INFILEP fullFilename)) - (PRIN1 "File not found" promptW) - (RETURN)) - (T (PRIN1 "Making plot ..." promptW) - (MAPL.Gen.Plot fullFilename promptW xPos yPos rep type penFlag) - (CLEARW promptW) - (PRIN1 "Done" promptW) - (RETURN)))))) - -(MAPL.Gen.Plot - (LAMBDA (file promptW xPos yPos rep type penFlag) (* DSB " 5-Dec-86 17:41") - - (* * makes a plot from the general plot input format) - - - (PROG (dataList keyword plot objectList (pen 1) - (plotNumber 1)) - - (* * get a data list of those pairs of data you want to plot) - - - (SETQ dataList (MAPL.Gen.ASCIIToLisp file xPos yPos)) - (* (PRIN1 dataList PROMPTWINDOW)) - - (* * parse and plot) - - - (COND - ((NOT dataList) - (RETURN (PRIN1 "There is no data" promptW)))) - (for item in dataList - do (SETQ keyword (CAR item)) - (SELECTQ keyword - (NEWPLOT (SETQ plot (MAPL.Gen.NewPlot plotNumber)) - (* New plot) - ) - (START (SETQ objectList NIL) - (* Start new object) - ) - (END (SETQ objectList (MAPL.Gen.PlotObject plot objectList pen rep) - ) (* Plot the object) - ) - (ENDPLOT (SETQ plotNumber (MAPL.Gen.EndPlot plot plotNumber)) - (* End of plot) - ) - (NEWPEN (SETQ pen (MAPL.Gen.NewPen item penFlag)) - (* New pen) - ) - (SETQ objectList (MAPL.Gen.CollectData objectList item type))))))) - -(MAPL.Gen.ASCIIToLisp - (LAMBDA (file xPos yPos) (* DSB " 5-Dec-86 17:34") - - (* * returns ASCII data from a file in a list, with one sub-list per line. The file must end in a CR.) - - - (PROG ((tempFile (QUOTE {core}tempplot.dat)) - (keywordList (QUOTE (NEWPLOT ENDPLOT START END NEWPEN))) - fileStream dataList lineList key shortList) - (COND - ((NOT (INFILEP file)) - (RETURN NIL))) - (COPYFILE file tempFile) - - (* * copy to {core} because reads from filestream to {core} are much faster than reads from filestream to a VAX on  - the network.) - - - - (* * if Keyword, return the line as is; otherwise, only include the numbers in the positions requested.) - - - - (* * if xPos is NIL, put NIL in the first position of the short list) - - - (SETQ fileStream (OPENSTREAM tempFile (QUOTE INPUT))) - (while (NOT (EOFP tempFile)) - do (SETQ lineList (MAPL.ReadASCIILine fileStream)) - (SETQ key (CAR lineList)) - (COND - ((MEMBER key keywordList) - (SETQ shortList lineList)) - ((NOT xPos) - (SETQ shortList (LIST NIL (CAR (NTH lineList yPos))))) - (T (SETQ shortList (LIST (CAR (NTH lineList xPos)) - (CAR (NTH lineList yPos)))))) - (SETQ dataList (CONS shortList dataList))) - (CLOSEF fileStream) - (DELFILE tempFile) - (RETURN (REVERSE dataList))))) - -(MAPL.Gen.NewPlot - (LAMBDA (plotNumber) (* DSB " 5-Dec-86 11:44") - - (* * starts a new plot with Log scaling) - - - (PROG (newPlot (leftFirst 471) - left - (bottomFirst 50) - bottom region (rightMenuItems (QUOTE - ((Logscale SCAT.LOGSCALE - "Toggle exponential tics" - (SUBITEMS (X% axis - (SCAT.LOGSCALE - (QUOTE X)) - "X axis only") - (Y% axis - (SCAT.LOGSCALE - (QUOTE Y)) - "Y axis only"))) - (Coordinates SCAT.WORLDCOORD - "Display world coordinates at cursor position")))) - (pointMenuItems (QUOTE ((Coordinates SCAT.POINTCOORDS - "Display point coordinates"))))) - (SETQ left (PLUS leftFirst (TIMES 25 (DIFFERENCE plotNumber 1)))) - (SETQ bottom (PLUS bottomFirst (TIMES 25 (DIFFERENCE plotNumber 1)))) - (SETQ region (CREATEREGION left bottom 250 250)) - (SETQ newPlot (CREATEPLOT NIL region "General Plot")) - (PLOTADDMENUITEMS newPlot (QUOTE RIGHT) - rightMenuItems) - (PLOTMENUITEMS newPlot (QUOTE POINTMENU) - (APPEND (PLOTMENUITEMS newPlot (QUOTE MIDDLE)) - pointMenuItems)) - (RETURN newPlot)))) - -(MAPL.Gen.PlotObject - (LAMBDA (plot objectList pen rep) (* DSB " 8-Dec-86 07:28") - - (* * plots the objectList, with specified pen and according to the chosen representation (e.g., points, curve,  - both)) - - - - (* * when plotting points, ignore the pen size) - - - (PROG NIL - (COND - ((NOT plot) - (RETURN (PRIN1 "ERROR: NEWPLOT command omitted. " PROMPTWINDOW)))) - (COND - ((AND objectList (GREATERP (LENGTH objectList) - 0)) - (COND - ((EQUAL rep (QUOTE Curve)) - (PLOTCURVE plot objectList NIL pen NIL T)) - ((EQUAL rep (QUOTE Points)) - (PLOTPOINTS plot objectList NIL NIL NIL T)) - ((EQUAL rep (QUOTE Both)) - (PLOTCURVE plot objectList NIL pen NIL T) - (PLOTPOINTS plot objectList NIL NIL NIL T)))) - (T (PROMPTPRINT "ERROR: PlotObject is NIL and not drawn"))) - (RETURN NIL)))) - -(MAPL.Gen.EndPlot - (LAMBDA (plot plotNumber) (* DSB " 4-Dec-86 14:17") - - (* * opens the plotwindow, and returns a new increment for the next plot position) - - - (PROG NIL - (OPENPLOTWINDOW plot) - (RETURN (PLUS plotNumber 1))))) - -(MAPL.Gen.NewPen - (LAMBDA (item penFlag) (* DSB " 8-Dec-86 07:30") - - (* * If penFlag is OFF, sets pen to 1; otherwise, sets pen width as instructed.) - - - (PROG (pen) - (COND - (penFlag (SETQ pen (CADR item))) - (T (SETQ pen 1))) - (RETURN pen)))) - -(MAPL.Gen.CollectData - (LAMBDA (objectList item type) (* DSB " 8-Dec-86 09:43") - - (* * adds the appropriate dotted pair (determined by dest and the input item) to the objectList.) - - - (PROG ((xVal (CAR item)) - (yVal (CADR item)) - newItem) - - (* * not numbers; don't do anything) - - - (COND - ((NOT (NUMBERP yVal)) - (RETURN objectList))) - - (* * if xVal is NIL (not a number) but yVal is a number, then assume the user is asking for a time sequence. - However, LogX is not allowed. This will slip past MAPL.Gen.MakePlot if the X-position is given as a  - (too large) number. We stop that here.) - - - (COND - ((AND (NOT (NUMBERP xVal)) - (NUMBERP yVal)) - (COND - ((OR (EQUAL type (QUOTE LogX-Y)) - (EQUAL type (QUOTE LogX-LogY))) - (PROMPTPRINT "Log X for X=time-sequence not allowed") - (RETURN objectList))) - (COND - ((NOT objectList) - (SETQ xVal 0)) - (T (SETQ xVal (PLUS 1 (CAAR objectList))))))) - - (* * non time-series plot) - - - (COND - ((EQUAL type (QUOTE X-Y)) - (SETQ newItem (CONS xVal yVal))) - ((EQUAL type (QUOTE X-LogY)) - (COND - ((GREATERP yVal 0) - (SETQ newItem (CONS xVal (PLOT.LOG10 yVal)))) - (T (PROMPTPRINT "ERROR: Attempt to take Log of negative number " yVal)))) - ((EQUAL type (QUOTE LogX-Y)) - (COND - ((GREATERP xVal 0) - (SETQ newItem (CONS (PLOT.LOG10 xVal) - yVal))) - (T (PROMPTPRINT "ERROR: Attempt to take Log of negative number " xVal)))) - ((EQUAL type (QUOTE LogX-LogY)) - (COND - ((AND (GREATERP xVal 0) - (GREATERP yVal 0)) - (SETQ newItem (CONS (PLOT.LOG10 xVal) - (PLOT.LOG10 yVal)))) - (T (PROMPTPRINT "ERROR: Attempt to take Log of neg. number at point (" xVal "," - yVal ")")))) - (T (PRIN1 "ERROR: Unknown plot type requested" PROMPTWINDOW))) - (COND - (newItem (SETQ objectList (CONS newItem objectList)))) - (RETURN objectList)))) -) - - - -(* Icon bitmaps) - - -(RPAQ MAPL.Gen.Icon (READBITMAP)) -(70 70 -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"L@@@@@@@@@ON@@@@@L@@" -"L@@@@@@@@@GO@@@@@L@@" -"L@@@@COOOOOOOOOOLL@@" -"L@@@@B@@@@AOH@@@DL@@" -"L@@@@B@@@@@OL@@@DL@@" -"L@@@@B@@@@@GN@@@DL@@" -"L@@@@BB@@@@CO@@@DL@@" -"L@@@@BB@@@@AOH@@DL@@" -"L@@@@BF@@@@@OH@@DL@@" -"L@@@@BB@@@@@GL@@DL@@" -"L@@@@BB@@@@@CL@@DL@@" -"LOOH@BB@@@@@AN@@DL@@" -"LLAH@BF@@@@@@F@@DL@@" -"LLAH@BB@@@@@@C@@DL@@" -"LL@@@BB@@@@@@AH@DL@@" -"LL@@@BB@@CL@@GH@DL@@" -"LL@@@BF@@FF@AL@@DL@@" -"LL@AOBB@@LC@C@@@DL@@" -"LLOIOBB@AHAHN@@@DL@@" -"LLMH@BB@C@@OH@@@DL@@" -"LLMH@BF@F@@@@@@@DL@@" -"LLAH@BB@L@@@@@@@DL@@" -"LLAH@BB@H@@@@@@@DL@@" -"LLAH@BBAH@@@@@@@DL@@" -"LLAH@BFA@@@@@@@@DL@@" -"LOOH@BBC@@@@@@@@DL@@" -"L@@@@BBB@@@@@@@@DL@@" -"L@@@@BBF@@@@@@@@DL@@" -"L@@@@BFD@@@@@@@@DL@@" -"L@@@@BB@@@@@@@@@DL@@" -"L@@@@BB@@@@@@@@@DL@@" -"L@@@@BB@@@@@@@@@DL@@" -"L@@@@BGOOOOOOOONDL@@" -"L@@@@BBBBBBBBBBBDL@@" -"L@@@@B@@@@@@@@@@DL@@" -"L@@@@COOOOOOOOOOLL@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"LOOOOOH@@@@@@@@@@L@@" -"L@LOLL@@@@@@@@@@@L@@" -"LAHGHF@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@@@@@@@@@@L@@" -"LC@C@C@@ON@OO@NALL@@" -"LC@C@C@@NF@NG@FAHL@@" -"LC@C@C@@LB@LC@FAHL@@" -"LC@C@C@@H@@LC@FAHL@@" -"LC@C@C@@LH@LC@FAHL@@" -"LC@C@C@@OH@LC@FAHL@@" -"LC@C@C@@LH@LC@FAHL@@" -"LC@GHC@@H@@LC@FAHL@@" -"LC@@@C@@LB@LC@FAHL@@" -"LC@@@C@@NF@LC@GCHL@@" -"LC@@@C@@ONALCHGOHL@@" -"LC@@@C@@@@@@@@@@@L@@" -"LOH@@GL@@@@@@@@@@L@@" -"LOH@@GL@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"L@@@@@@@@@@@@@@@@L@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@") - -(RPAQ MAPL.Gen.IconMask (READBITMAP)) -(70 70 -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@" -"OOOOOOOOOOOOOOOOOL@@") - - - -(* vars) - -(MAPL.MakeReadtable) -(DECLARE: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS MAPL.ASCIIRDTBL) -) - -(ADDTOVAR BackgroundMenuCommands (Plot% Menus (QUOTE (MAPL.TopLevel)) - "Opens all Plot Menus" - (SUBITEMS (General% PlotMenu (QUOTE (MAPL.Gen.TopLevel - )) - - "Open a General Plot Menu") - (Simple% PlotMenu (QUOTE ( -MAPL.Simple.TopLevel)) - "Open a Simple Plot Menu") - (Meta% PlotMenu (QUOTE (MAPL.Meta.TopLevel)) - "Open a MetaCode Plot Menu") - ))) - -(RPAQQ BackgroundMenu NIL) -(PUTPROPS MATHSERVERPLOT COPYRIGHT ("Xerox Corporation" 1986)) -(DECLARE: DONTCOPY - (FILEMAP (NIL (2744 5312 (MAPL.TopLevel 2754 . 3043) (MAPL.MakeReadtable 3045 . 3446) ( -MAPL.ReadASCIILine 3448 . 3909) (MAPL.ExpandFilename 3911 . 5310)) (5383 7480 (MAPL.Meta.TopLevel 5393 - . 6056) (MAPL.Meta.FreeMenu 6058 . 7203) (MAPL.Meta.MakeIconWindow 7205 . 7478)) (7508 11497 ( -MAPL.Meta.MakePlot 7518 . 9264) (MAPL.Meta.Plot 9266 . 10593) (MAPL.Meta.ASCIIToLisp 10595 . 11495)) ( -11529 13474 (MAPL.Meta.NewPlotCom 11539 . 11840) (MAPL.Meta.MoveCom 11842 . 12308) (MAPL.Meta.DrawCom -12310 . 12621) (MAPL.Meta.EndPlotCom 12623 . 13057) (MAPL.Meta.NewPenCom 13059 . 13472)) (16880 19790 -(MAPL.Simple.TopLevel 16890 . 17706) (MAPL.Simple.FreeMenu 17708 . 19514) (MAPL.Simple.MakeIconWindow -19516 . 19788)) (19818 27100 (MAPL.Simple.MakePlot 19828 . 22323) (MAPL.Simple.Plot 22325 . 27098)) ( -30511 33501 (MAPL.Gen.TopLevel 30521 . 31327) (MAPL.Gen.FreeMenu 31329 . 33227) ( -MAPL.Gen.MakeIconWindow 33229 . 33499)) (33529 45006 (MAPL.Gen.MakePlot 33539 . 36529) (MAPL.Gen.Plot -36531 . 38142) (MAPL.Gen.ASCIIToLisp 38144 . 39718) (MAPL.Gen.NewPlot 39720 . 41084) ( -MAPL.Gen.PlotObject 41086 . 42080) (MAPL.Gen.EndPlot 42082 . 42388) (MAPL.Gen.NewPen 42390 . 42736) ( -MAPL.Gen.CollectData 42738 . 45004))))) -STOP diff --git a/obsolete/lispusers/microtek.tedit b/obsolete/lispusers/microtek.tedit deleted file mode 100644 index 579d1909..00000000 Binary files a/obsolete/lispusers/microtek.tedit and /dev/null differ diff --git a/obsolete/lispusers/splinefonts/GACHAE.LC1-SF b/obsolete/lispusers/splinefonts/GACHAE.LC1-SF deleted file mode 100644 index 79c03e55..00000000 --- a/obsolete/lispusers/splinefonts/GACHAE.LC1-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY gacha) (CHARACTER 141Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:22:31) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((93 182) (93 182) (143 182)) NIL ((-12.5 0 0 0 75. 0 ) (25. 0 75. 0 -75. 0 )) NATURAL) (19 ((143 182) (147 197) (170 215) (225 221) (290 213) (309 194) (287 165) (191 156) (122 142) (100 128) (85 110) (75 78) (81 46) (96 25) (118 9) (153 -4) (199 -8) (247 -2) (313 14)) NIL ((0.804730058 13.568931 0 0 19.171619 8.5864067 ) (10.390539 17.862133 19.171619 8.5864067 18.1419029 -24.932033 ) (38.63311 13.9825229 37.313522 -16.3456268 -13.7392387 1.14173698 ) (69.07701 -1.79223466 23.574283 -15.2038898 -95.184936 8.36507798 ) (45.058822 -12.813585 -71.610656 -6.83881188 58.47901 -16.602043 ) (2.68767023 -27.953422 -13.131645 -23.440856 -108.73107 64.043106 ) (-64.809524 -19.372722 -121.8627 40.602249 178.4453 -59.570404 ) (-97.44955 -8.5556755 56.58264 -18.968154 0.949485779 24.238521 ) (-40.39218 -15.404567 57.532127 5.27036858 -62.243286 -7.38368893 ) (-13.981699 -13.826044 -4.7111616 -2.11332083 8.02367784 -18.703762 ) (-14.6810188 -25.291248 3.31251764 -20.817085 18.148567 22.19876 ) (-2.29421711 -35.008949 21.461086 1.38167786 -14.617956 13.908697 ) (11.857891 -26.672924 6.8431301 15.290376 -1.67673778 -11.8335666 ) (17.862651 -17.299331 5.16639233 3.45680857 9.3249073 -2.57442284 ) (27.691497 -15.1297359 14.4913 0.882385612 0.377099991 10.1312599 ) (42.371345 -9.1817188 14.8684 11.013647 -22.833305 -1.95062256 ) (45.823097 0.856617928 -7.9649067 9.0630245 36.956123 3.67121887 ) (56.336258 11.7552509 28.991222 12.734243 -28.991222 -12.734243 )) NATURAL) (5 ((313 14) (329 6) (358 -1) (378 0) (397 2)) NIL ((11.8928566 -7.7142849 0 0 24.642856 -1.71428537 ) (24.214283 -8.5714283 24.642856 -1.71428537 -45.214279 14.571426 ) (26.249996 -2.99999952 -20.571426 12.857141 24.214283 -14.571426 ) (17.785713 2.5714283 3.6428566 -1.71428561 -3.6428566 1.71428561 )) NATURAL) (2 ((397 2) (397 36)) NIL ((0 34. 0 0 0 0 )) NATURAL) (4 ((397 36) (378 36) (361 41) (355 51)) NIL ((-18.799999 -1. 0 0 -1.19999981 6. ) (-19.399997 2. -1.19999981 6. 17.999996 0 ) (-11.599998 8. 16.799999 6. -16.799999 -6. )) NATURAL) (2 ((355 51) (355 185)) NIL ((0 134. 0 0 0 0 )) NATURAL) (6 ((355 185) (348 212) (328 232) (304 245) (271 252) (229 256)) NIL ((-3.67464113 28.473682 0 0 -19.952152 -8.84210397 ) (-13.6507168 24.052627 -19.952152 -8.84210397 21.760761 2.21052551 ) (-22.722484 16.315788 1.80861187 -6.63157845 -13.090906 0 ) (-27.459327 9.6842098 -11.282295 -6.63157845 0.602870941 3.78947353 ) (-38.440185 4.94736767 -10.679424 -2.84210491 10.679424 2.84210491 )) NATURAL) (6 ((229 256) (177 253) (135 241) (115 228) (99 209) (93 182)) NIL ((-53.12918 -0.583732248 0 0 6.77511979 -14.497606 ) (-49.741623 -7.83253575 6.77511979 -14.497606 26.1244 18.488033 ) (-29.904304 -13.086122 32.89952 3.99043036 -39.27272 -11.454544 ) (-16.641147 -14.822965 -6.37320519 -7.46411515 22.966503 -2.66985512 ) (-11.531099 -23.622009 16.5932998 -10.13397 -16.5932998 10.13397 )) NATURAL)) ((11 ((308 127) (235 123) (180 115) (142 101) (127 74) (139 46) (174 32) (223 30) (290 45) (308 80) (308 127)) NIL ((-76.935379 -3.13017798 0 0 23.612281 -5.21893215 ) (-65.129226 -5.73964405 23.612281 -5.21893215 -10.061409 2.09466267 ) (-46.54766 -9.91124536 13.5508728 -3.12426949 10.63335 -15.159719 ) (-27.68011 -20.615371 24.184223 -18.2839889 3.5280075 16.544212 ) (-1.73188519 -30.627254 27.71223 -1.73977589 -0.745380402 20.982864 ) (25.607654 -21.875595 26.96685 19.243091 -24.546482 -10.4756908 ) (40.30126 -7.87034989 2.42036581 8.76740075 44.931312 8.9199009 ) (65.187286 5.35700226 47.351684 17.687301 -131.1788 4.79608155 ) (46.949569 25.442344 -83.827118 22.483383 77.783889 -10.1042308 ) (2.0144062 42.87361 -6.04321957 12.379152 6.04321957 -12.379152 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 142Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:29:14) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((73 337) (73 337) (73 0)) NIL ((0 84.25 0 0 0 -505.5 ) (0 -168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((73 0) (122 0)) NIL ((49. 0 0 0 0 0 )) NATURAL) (2 ((122 0) (122 19)) NIL ((0 19. 0 0 0 0 )) NATURAL) (19 ((122 19) (145 7) (186 -3) (223 -6) (274 -2) (306 10) (330 24) (346 42) (358 66) (367 124) (358 182) (346 206) (330 224) (306 238) (274 250) (223 254) (186 251) (145 241) (122 229)) NIL ((17.530986 -12.1277828 0 0 32.814079 0.766703606 ) (33.938026 -11.74443 32.814079 0.766703606 -56.070419 8.166481 ) (38.716896 -6.89448739 -23.25634 8.93318559 59.467628 -3.43263149 ) (45.194366 0.322382927 36.211288 5.50055409 -73.800094 5.56404019 ) (44.505607 8.60495759 -37.588813 11.064594 37.732772 -12.823528 ) (25.783184 13.2577877 0.143964797 -1.75893473 -11.131006 9.73007585 ) (20.361644 16.363891 -10.987041 7.97114278 6.79124547 -14.0967788 ) (12.770227 17.286644 -4.195796 -6.12563706 7.96602345 58.657035 ) (12.5574417 40.489532 3.77022743 52.531402 -32.655334 -52.531402 ) (-3.20374965E-7 66.755233 -28.885112 0 32.655334 -52.531402 ) (-12.5574417 40.489524 3.77022743 -52.531402 -7.96602345 58.657035 ) (-12.770227 17.286644 -4.195796 6.12563706 -6.79124547 -14.0967788 ) (-20.361644 16.363891 -10.987041 -7.97114278 11.131006 9.73007585 ) (-25.783184 13.2577858 0.143965035 1.75893426 -37.732772 -12.823528 ) (-44.505607 8.60495568 -37.588813 -11.064594 73.800094 5.56404019 ) (-45.194366 0.322382271 36.211288 -5.50055409 -59.467628 -3.43263149 ) (-38.716896 -6.89448739 -23.25634 -8.93318559 56.070419 8.166481 ) (-33.938026 -11.74443 32.814079 -0.766703487 -32.814079 0.766703487 )) NATURAL) (2 ((122 229) (122 337)) NIL ((0 108. 0 0 0 0 )) NATURAL) (2 ((122 337) (73 337)) NIL ((-49. 0 0 0 0 0 )) NATURAL)) ((11 ((315 124) (312 86) (300 53) (275 34) (240 28) (220 28) (200 28) (165 34) (140 53) (128 86) (125 124)) NIL ((-1.25837326 -38.552482 0 0 -10.44976 3.31491756 ) (-6.48325349 -36.895027 -10.44976 3.31491756 -1.75119591 13.425411 ) (-17.808612 -26.8674 -12.200956 16.740329 -6.54545403 -3.01657295 ) (-33.282295 -11.6353588 -18.74641 13.7237568 45.933013 -7.35911656 ) (-29.062198 -1.59116006 27.186603 6.36464024 -27.186603 -9.5469589 ) (-15.4688987 0 0 -3.18232012 -27.186603 9.5469589 ) (-29.062198 1.5911603 -27.186603 6.36464024 45.933013 7.35911656 ) (-33.282295 11.6353588 18.74641 13.7237568 -6.54545403 3.01657295 ) (-17.808609 26.8674 12.200956 16.740329 -1.75119781 -13.425413 ) (-6.48325253 36.895027 10.4497585 3.3149166 -10.4497585 -3.3149166 )) NATURAL) (11 ((125 124) (128 162) (140 195) (165 214) (200 220) (220 220) (240 220) (275 214) (300 195) (312 162) (315 124)) NIL ((1.25837326 38.552482 0 0 10.44976 -3.31491756 ) (6.48325349 36.895027 10.44976 -3.31491756 1.75119591 -13.425411 ) (17.808612 26.8674 12.200956 -16.740329 6.54545403 3.01657295 ) (33.282295 11.6353588 18.74641 -13.7237568 -45.933013 7.35911656 ) (29.062198 1.59116006 -27.186603 -6.36464024 27.186603 9.5469589 ) (15.4688987 0 0 3.18232012 27.186603 -9.5469589 ) (29.062198 -1.5911603 27.186603 -6.36464024 -45.933013 -7.35911656 ) (33.282295 -11.6353588 -18.74641 -13.7237568 6.54545403 -3.01657295 ) (17.808609 -26.8674 -12.200956 -16.740329 1.75119781 13.425413 ) (6.48325253 -36.895027 -10.4497585 -3.3149166 10.4497585 3.3149166 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 143Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 7:26:59) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((24 ((379 184) (360 219) (330 239) (291 250) (247 253) (199 250) (165 243) (128 229) (105 209) (87 184) (76 148) (73 124) (76 100) (86 64) (103 37) (124 19) (163 3) (199 -4) (247 -7) (291 -2) (330 9) (358 30) (370 49) (379 74)) NIL ((-16.644897 38.499534 0 0 -14.1306038 -20.997219 ) (-23.710201 28.000923 -14.1306038 -20.997219 4.65302277 14.9861088 ) (-35.514289 14.496757 -9.477581 -6.0111103 7.51851369 -2.94722366 ) (-41.232612 7.01203538 -1.95906663 -8.95833398 -10.727083 2.80278683 ) (-48.55522 -0.544904828 -12.686151 -6.15554715 41.389816 3.73607063 ) (-40.546463 -4.83241654 28.70367 -2.41947651 -46.832206 -5.74706936 ) (-35.258895 -10.125427 -18.128536 -8.16654588 43.939003 1.25220871 ) (-31.41793 -17.665866 25.810466 -6.91433716 -26.923797 6.73823167 ) (-19.069366 -21.21109 -1.11333346 -0.176105380 9.75619889 -22.205131 ) (-15.3045978 -32.48976 8.64286614 -22.381237 -0.101001739 46.08229 ) (-6.71223355 -31.829849 8.5418644 23.701057 -3.35219002 -24.124053 ) (0.153535515 -20.190822 5.18967438 -0.422999382 1.50976372 -21.586059 ) (6.09809209 -31.406852 6.6994381 -22.009059 3.31313324 38.468307 ) (14.4540958 -34.181755 10.012571 16.459247 -14.762298 -6.28718758 ) (17.0855179 -20.8661 -4.74972725 10.17206 37.73606 -13.319557 ) (31.203823 -17.35382 32.986335 -3.14749718 -52.181953 17.565422 ) (38.099174 -11.718605 -19.195617 14.4179268 44.99176 -14.942138 ) (41.399444 -4.7717495 25.796146 -0.524212718 -37.78511 12.203134 ) (48.30303 0.805606008 -11.9889679 11.6789226 10.148691 -9.8704033 ) (41.388412 7.5493269 -1.84027552 1.80851817 -8.8096504 15.278482 ) (35.14331 16.997085 -10.649927 17.087001 -10.910089 -27.243534 ) (19.038337 20.462322 -21.560016 -10.156534 22.450019 21.695667 ) (8.703331 21.153621 0.890004874 11.539133 -0.890004874 -11.539133 )) NATURAL) (2 ((379 74) (329 74)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (20 ((329 74) (329 64) (322 47) (298 35) (268 30) (243 29) (218 30) (176 36) (153 48) (135 71) (124 124) (135 177) (153 200) (176 212) (218 218) (243 219) (268 218) (298 213) (322 201) (329 184)) NIL ((0.788245917 -7.8808317 0 0 -4.72947598 -12.7150058 ) (-1.57649183 -14.238334 -4.72947598 -12.7150058 -18.352619 21.575031 ) (-15.4822788 -16.165821 -23.082096 8.8600273 18.139965 -1.58513355 ) (-29.494392 -8.09836198 -4.94212914 7.27489377 11.792747 -3.23450184 ) (-28.540145 -2.4407196 6.85061837 4.04039192 0.689037323 -3.47685623 ) (-21.345008 -0.138755947 7.53965569 0.563535691 -44.548889 5.14192868 ) (-36.079803 2.99574423 -37.009239 5.70546437 75.50656 0.909141541 ) (-35.335762 9.15577889 38.497322 6.6146059 -41.47737 -2.77849531 ) (-17.577129 14.3811378 -2.98005152 3.83611059 6.4029312 40.204834 ) (-17.3557129 38.319664 3.4228797 44.040947 27.865646 -44.040847 ) (-8.89971852E-6 60.340187 31.288528 9.19930607E-5 -27.865531 -44.041404 ) (17.355751 38.319572 3.42299652 -44.041313 -6.40351487 40.206466 ) (17.576992 14.381498 -2.98051882 -3.83484268 41.47959 -2.78447056 ) (35.336265 9.15442086 38.499076 -6.61931325 -75.514846 0.931411744 ) (36.077919 3.00081348 -37.015777 -5.6879015 44.57981 5.05882263 ) (21.352046 -0.157676696 7.56403638 -0.629078388 -0.804404259 -3.16670466 ) (28.513881 -2.37010717 6.7596321 -3.79578304 -11.3621997 -4.39200688 ) (29.592414 -8.3618946 -4.60256768 -8.1877899 -19.746788 2.73473835 ) (15.116451 -15.1823158 -24.349357 -5.45305157 24.349357 5.45305157 )) NATURAL) (2 ((329 184) (379 184)) NIL ((50. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 144Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 7:36:21) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((367 337) (367 337) (367 0)) NIL ((0 84.25 0 0 0 -505.5 ) (0 -168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((367 0) (319 0)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((319 0) (319 19)) NIL ((0 19. 0 0 0 0 )) NATURAL) (19 ((319 19) (288 7) (255 -1) (217 -6) (166 -2) (134 9) (111 24) (94 42) (82 66) (73 124) (82 182) (94 206) (111 224) (134 239) (166 250) (217 254) (255 249) (288 241) (319 229)) NIL ((-30.485801 -12.997631 0 0 -3.08518171 5.9857931 ) (-32.028389 -10.004734 -3.08518171 5.9857931 3.42590904 -5.92896652 ) (-33.400619 -6.98342515 0.340727687 0.0568262711 -28.618454 11.7300739 ) (-47.369117 -1.06156063 -28.277729 11.786901 63.04792 -4.99134064 ) (-44.122886 8.22966958 34.770195 6.79556084 -31.573257 -3.76470709 ) (-25.13932 13.142877 3.19693613 3.03085375 3.24512148 2.05016756 ) (-20.319824 17.198814 6.4420576 5.0810213 0.592772484 -10.4359607 ) (-13.5813789 17.061855 7.0348301 -5.3549404 -11.616209 57.69367 ) (-12.354654 40.553749 -4.58137989 52.338737 33.872062 -52.338737 ) (7.97212123E-7 66.723114 29.290687 -2.04428988E-6 -33.872062 -52.33872 ) (12.354654 40.553749 -4.58137989 -52.338729 11.616209 57.693664 ) (13.5813789 17.061855 7.03482915 5.3549385 -0.592770577 -10.4359588 ) (20.319824 17.198814 6.44205857 -5.08102036 -3.24512196 2.05016661 ) (25.13932 13.142877 3.1969366 -3.03085375 31.573257 -3.76470709 ) (44.122886 8.22966958 34.770195 -6.79556084 -63.04792 -4.99134064 ) (47.369117 -1.06156182 -28.277729 -11.786901 28.618454 11.7300739 ) (33.400619 -6.98342515 0.340728342 -0.0568258986 -3.42591 -5.92896652 ) (32.028389 -10.004734 -3.08518171 -5.9857931 3.08518171 5.9857931 )) NATURAL) (2 ((319 229) (319 337)) NIL ((0 108. 0 0 0 0 )) NATURAL) (2 ((319 337) (367 337)) NIL ((48. 0 0 0 0 0 )) NATURAL)) ((21 ((125 124) (128 86) (140 53) (166 34) (195 28) (220 25) (248 28) (275 34) (300 53) (312 86) (315 124) (312 162) (300 195) (275 214) (240 220) (220 221) (200 220) (166 214) (140 195) (128 162) (125 124)) NIL ((1.51067447 -38.577346 0 0 8.93595315 3.46408939 ) (5.97865105 -36.845298 8.93595315 3.46408939 9.32023049 12.679552 ) (19.574718 -27.041435 18.256183 16.143642 -16.216877 -0.182313919 ) (29.722465 -10.9889488 2.03930521 15.961328 -10.452711 -17.950286 ) (26.535415 -4.0027647 -8.41340638 -1.98896122 16.027721 11.9834747 ) (26.135868 1.15633010E-5 7.6143179 9.99451448 -11.658184 -11.983612 ) (27.921096 4.00271988 -4.04386616 -1.98909831 6.60501576 17.950973 ) (27.179737 10.989109 2.5611496 15.9618759 -20.761878 0.179710388 ) (19.359943 27.04084 -18.200729 16.141586 10.4425125 -12.669805 ) (6.38047219 36.847518 -7.75821686 3.47177982 2.99181557 -3.50048733 ) (0.118163108 38.569053 -4.76640129 -0.0287075825 -4.40977478 -3.32824135 ) (-6.85312558 36.876228 -9.17617608 -3.35694933 -3.35271454 -13.186544 ) (-17.705661 26.926006 -12.5288906 -16.543495 -6.17935753 2.07443428 ) (-33.324226 11.419729 -18.708248 -14.4690609 46.070129 10.8888015 ) (-28.997413 2.39507007 27.36188 -3.58025837 -28.10115 2.3703537 ) (-15.686109 -1.16033479E-5 -0.739272595 -1.20990467 -23.665515 -2.37021637 ) (-28.25814 -2.3950243 -24.404789 -3.58012104 38.763206 -10.889488 ) (-33.281318 -11.419889 14.358423 -14.46961 0.612663269 -2.07182503 ) (-18.616565 -26.92541 14.971086 -16.541435 -5.21385956 13.176794 ) (-6.25240899 -36.878448 9.75722695 -3.36464119 -9.75722695 3.36464119 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 145Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 7:44:36) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((10 ((114 106) (121 71) (140 47) (162 36) (198 28) (232 26) (262 30) (290 38) (310 55) (317 74)) NIL ((3.72561359 -37.048507 0 0 19.646316 12.291084 ) (13.5487728 -30.902969 19.646316 12.291084 -26.23159 4.54457855 ) (20.079292 -16.3395958 -6.5852747 16.8356628 31.280056 -18.469402 ) (29.134048 -8.738636 24.694782 -1.63374018 -32.88864 9.3330364 ) (37.384506 -5.70585728 -8.1938591 7.69929696 4.27451039 -0.862744332 ) (31.327903 1.56206679 -3.91934872 6.8365526 3.79060364 -5.88205815 ) (29.303859 5.4575901 -0.128744781 0.954493762 -7.43692494 12.390974 ) (25.456649 12.6075706 -7.56567 13.345468 -10.0429077 -13.681835 ) (12.8695259 19.112121 -17.608577 -0.336367309 17.608577 0.336367309 )) NATURAL) (2 ((317 74) (367 74)) NIL ((50. 0 0 0 0 0 )) NATURAL) (26 ((367 74) (358 49) (346 30) (318 9) (279 -2) (235 -7) (187 -4) (151 3) (120 17) (92 38) (74 63) (64 90) (61 124) (64 148) (75 184) (92 210) (116 229) (153 245) (188 252) (235 253) (276 248) (315 237) (345 217) (365 189) (375 153) (376 106)) NIL ((-9.14956666 -26.922843 0 0 0.897400857 11.5370788 ) (-8.7008648 -21.154304 0.897400857 11.5370788 -22.487003 -21.685394 ) (-19.046966 -20.459922 -21.589603 -10.148315 11.0506248 27.204502 ) (-35.111259 -17.005985 -10.5389785 17.056186 8.28450204 -15.132629 ) (-41.507988 -7.51611615 -2.25447607 1.92355561 -8.18863679 9.3260288 ) (-47.85678 -0.929544092 -10.443113 11.249586 30.470039 -10.1714935 ) (-43.064872 5.23429489 20.026927 1.07809257 -17.691524 7.3599491 ) (-31.883708 9.99236299 2.33540249 8.4380417 -1.70394110 -1.26830482 ) (-30.400276 17.796249 0.631461263 7.16973687 12.5072899 -2.28672886 ) (-23.51517 23.822624 13.138752 4.883008 -6.32522488 -7.5847759 ) (-13.53903 24.913242 6.8135271 -2.7017684 0.793606759 20.625831 ) (-6.3286991 32.52439 7.60713387 17.924064 -2.84920406 -44.918556 ) (-0.146167755 27.989177 4.7579298 -26.994491 4.60321713 57.048393 ) (6.91337014 29.518886 9.3611469 30.053905 -3.56366348 -51.275047 ) (14.492685 33.935264 5.79748345 -21.221145 -2.34856748 16.051834 ) (19.115882 20.740036 3.44891596 -5.16931153 18.957935 5.067708 ) (32.043769 18.1045799 22.406852 -0.101603269 -37.483184 -12.32267 ) (35.70903 11.84164 -15.0763359 -12.424274 40.974823 8.22297288 ) (41.1201 3.52885342 25.89849 -4.20130062 -42.416122 -2.56921959 ) (45.81053 -1.957057 -16.517631 -6.7705202 20.689662 2.05390358 ) (39.637733 -7.7006254 4.17203236 -4.71661663 -16.342529 -5.64639378 ) (35.638504 -15.24044 -12.1704979 -10.36301 2.68045235 2.53167534 ) (24.808235 -24.337612 -9.49004556 -7.83133507 -0.379274368 1.51969146 ) (15.128551 -31.409103 -9.8693199 -6.3116436 -1.16334915 -8.610445 ) (4.67755604 -42.02597 -11.032669 -14.922088 11.032669 14.922088 )) NATURAL) (2 ((376 106) (114 106)) NIL ((-262. 0 0 0 0 0 )) NATURAL)) ((13 ((111 148) (115 173) (128 195) (142 206) (164 215) (199 220) (219 221) (239 220) (273 215) (296 206) (309 195) (323 173) (327 148)) NIL ((1.59247875 25.037006 0 0 14.445127 -0.222058296 ) (8.8150425 24.925979 14.445127 -0.222058296 -18.225643 -16.889705 ) (14.147348 16.259063 -3.78051567 -17.111766 10.4574489 19.780899 ) (15.595558 9.03774835 6.67693425 2.66913366 18.395839 -8.23390008 ) (31.470413 7.58993245 25.072776 -5.56476689 -54.040817 1.15470123 ) (29.522777 2.60251617 -28.968044 -4.41006565 29.767448 3.61509848 ) (15.438461 -1.19209289E-7 0.799406291 -0.794966818 24.971008 -3.61509848 ) (28.723369 -2.60251665 25.770416 -4.41006565 -45.65148 -1.15470123 ) (31.668045 -7.58993245 -19.881069 -5.56476689 7.63492776 8.23390008 ) (15.60444 -9.03774835 -12.246141 2.66913366 21.111778 -19.780899 ) (13.914188 -16.259067 8.8656368 -17.111766 -26.082042 16.889705 ) (9.73880197 -24.925979 -17.216407 -0.222057551 17.216407 0.222057551 )) NATURAL) (2 ((327 148) (111 148)) NIL ((-216. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 146Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 7:51:03) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((156 0) (156 210)) NIL ((0 210. 0 0 0 0 )) NATURAL) (2 ((156 210) (60 210)) NIL ((-96. 0 0 0 0 0 )) NATURAL) (2 ((60 210) (60 246)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((60 246) (156 246)) NIL ((96. 0 0 0 0 0 )) NATURAL) (2 ((156 246) (156 292)) NIL ((0 46. 0 0 0 0 )) NATURAL) (10 ((156 292) (165 316) (189 333) (215 341) (243 345) (278 346) (315 342) (348 331) (369 315) (378 292)) NIL ((5.11860848 25.295597 0 0 23.288345 -7.7735853 ) (16.762779 21.408802 23.288345 -7.7735853 -26.441726 -3.1320734 ) (26.83026 12.069181 -3.15338469 -10.9056587 4.47857857 8.3018837 ) (25.916164 5.31446457 1.32519412 -2.60377359 8.5274124 -0.0754714012 ) (31.505065 2.67295551 9.8526077 -2.67924499 -8.58823396 -1.99999904 ) (37.063552 -1.00628972 1.26437258 -4.67924404 -4.17447186 -3.92452908 ) (36.240692 -7.64779854 -2.9100995 -8.6037731 -10.713871 5.69811249 ) (27.973655 -13.402515 -13.6239719 -2.90566063 -0.970033646 -6.86792374 ) (13.8646679 -19.742137 -14.594005 -9.77358438 14.594005 9.77358438 )) NATURAL) (2 ((378 292) (378 272)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (2 ((378 272) (337 272)) NIL ((-41. 0 0 0 0 0 )) NATURAL) (8 ((337 272) (331 295) (319 305) (300 311) (273 313) (245 310) (219 299) (209 283)) NIL ((-4.74338722 26.25661 0 0 -7.53967667 -19.539676 ) (-8.51322557 16.48677 -7.53967667 -19.539676 1.69838524 19.698383 ) (-15.203708 6.79628945 -5.84129143 0.158708185 -5.25386429 -5.25386334 ) (-23.671932 4.32806492 -11.0951557 -5.0951557 13.3170719 1.31707239 ) (-28.10855 -0.108553722 2.22191667 -3.77808333 -6.01442719 -6.01442719 ) (-28.893848 -6.89385033 -3.7925105 -9.792511 28.74063 4.74063969 ) (-18.31604 -14.3160419 24.948123 -5.0518713 -24.948123 5.0518713 )) NATURAL) (2 ((209 283) (209 246)) NIL ((0 -37. 0 0 0 0 )) NATURAL) (2 ((209 246) (313 246)) NIL ((104. 0 0 0 0 0 )) NATURAL) (2 ((313 246) (313 210)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((313 210) (209 210)) NIL ((-104. 0 0 0 0 0 )) NATURAL) (2 ((209 210) (209 0)) NIL ((0 -210. 0 0 0 0 )) NATURAL) (2 ((209 0) (156 0)) NIL ((-53. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 147Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:11:15) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((11 ((367 -36) (360 -58) (339 -81) (316 -96) (276 -109) (223 -113) (171 -109) (130 -96) (106 -81) (87 -58) (79 -36)) NIL ((-3.1312089 -21.157455 0 0 -23.212745 -5.05524826 ) (-14.737581 -23.685081 -23.212745 -5.05524826 32.063728 19.276241 ) (-21.91846 -19.102207 8.85098649 14.220993 -33.042182 -18.04972 ) (-29.588569 -13.906076 -24.1912 -3.82872963 10.105022 16.922653 ) (-48.727256 -9.27347947 -14.0861778 13.093923 16.622085 -7.6408863 ) (-54.502388 6.37024641E-7 2.53591108 5.45303726 7.4066181 7.6408844 ) (-48.263168 9.27347947 9.94252969 13.0939216 13.751432 -16.922649 ) (-31.444919 13.906076 23.693962 -3.82872915 -26.412349 18.04972 ) (-20.957134 19.102207 -2.71838999 14.220993 19.897983 -19.276241 ) (-13.726532 23.685081 17.1795959 -5.05524826 -17.1795959 5.05524826 )) NATURAL) (2 ((79 -36) (134 -36)) NIL ((55. 0 0 0 0 0 )) NATURAL) (8 ((134 -36) (157 -66) (188 -78) (215 -81) (238 -81) (278 -72) (310 -53) (319 -26)) NIL ((20.736858 -34.19924 0 0 13.578838 25.195465 ) (27.526279 -21.601509 13.578838 25.195465 -19.894191 -17.977325 ) (31.15802 -5.39470959 -6.3153553 7.21813775 -6.00206185 -7.28615475 ) (21.841632 -1.81964922 -12.317417 -0.0680177510 43.902435 11.121948 ) (31.475437 3.67330837 31.585022 11.053932 -43.607688 -1.20164871 ) (41.256607 14.126417 -12.0226726 9.85228349 -19.471656 -0.315355301 ) (19.498107 23.821022 -31.49433 9.53692819 31.49433 -9.53692819 )) NATURAL) (2 ((319 -26) (319 19)) NIL ((0 45. 0 0 0 0 )) NATURAL) (19 ((319 19) (294 10) (255 -1) (217 -6) (166 -2) (134 9) (111 24) (94 42) (78 78) (73 124) (77 160) (88 196) (111 224) (134 239) (166 250) (217 254) (263 249) (297 238) (319 229)) NIL ((-20.838954 -8.1762371 0 0 -24.966262 -4.94256687 ) (-33.322082 -10.6475219 -24.966262 -4.94256687 40.83132 12.712835 ) (-37.872688 -9.2336712 15.865064 7.77026845 -48.359054 2.09122372 ) (-46.187156 -0.417790532 -32.493995 9.86149217 68.604934 -3.07773304 ) (-44.378677 7.9048357 36.110939 6.7837591 -34.060707 -1.78029155 ) (-25.298099 13.798448 2.05022669 5.00346756 7.6379194 -7.8010969 ) (-19.428913 14.901367 9.6881466 -2.79762983 -14.490961 26.984676 ) (-16.986244 25.596077 -4.80281449 24.187049 20.325923 -10.1376247 ) (-11.6260967 44.714317 15.523111 14.049425 -6.81274796 -34.43418 ) (0.490640223 41.546646 8.7103634 -20.384758 -5.07493115 27.874359 ) (6.66353799 35.099075 3.63543177 7.489604 15.112472 -17.0632629 ) (17.855205 34.057045 18.747905 -9.5736599 -25.374961 -7.62130547 ) (23.91563 20.672733 -6.62705899 -17.194965 14.387386 17.548488 ) (24.482265 12.252012 7.7603283 0.353523433 21.825416 -8.572649 ) (43.155304 8.31921006 29.585746 -8.21912576 -41.68907 -1.25789261 ) (51.896514 -0.528861285 -12.1033249 -9.47701837 0.930879594 1.60422325 ) (40.258628 -9.20376779 -11.172445 -7.8727951 -4.0344429 12.8409939 ) (27.068962 -10.656065 -15.206888 4.96819878 15.206888 -4.96819878 )) NATURAL) (2 ((319 229) (319 246)) NIL ((0 17. 0 0 0 0 )) NATURAL) (2 ((319 246) (367 246)) NIL ((48. 0 0 0 0 0 )) NATURAL) (2 ((367 246) (367 -36)) NIL ((0 -282. 0 0 0 0 )) NATURAL)) ((11 ((315 124) (312 86) (300 53) (275 34) (240 28) (220 26) (200 28) (166 34) (140 53) (128 86) (125 124)) NIL ((-1.25777840 -38.569053 0 0 -10.453329 3.41436482 ) (-6.4844427 -36.861877 -10.453329 3.41436482 -1.73335266 12.9281749 ) (-17.804447 -26.983425 -12.1866817 16.34254 -6.61325646 -1.12707138 ) (-33.29776 -11.204418 -18.799938 15.215469 46.186386 -14.419889 ) (-29.004505 -3.1988945 27.386447 0.795579792 -28.1323 4.80662918 ) (-15.6842098 4.17232513E-7 -0.745856881 5.60220909 -23.657165 -4.80662918 ) (-28.258647 3.19889498 -24.403022 0.795579315 38.76097 14.419889 ) (-33.28118 11.20442 14.357952 15.215469 0.613256455 1.12706756 ) (-18.6166 26.983425 14.971208 16.3425369 -5.21401215 -12.928171 ) (-6.2523985 36.861877 9.7571964 3.41436482 -9.7571964 -3.41436482 )) NATURAL) (11 ((125 124) (128 162) (140 195) (166 214) (200 220) (220 222) (240 220) (275 214) (300 195) (312 162) (315 124)) NIL ((1.37380051 38.569053 0 0 9.7571964 -3.41436482 ) (6.2523985 36.861877 9.7571964 -3.41436482 5.21401596 -12.9281749 ) (18.616603 26.983425 14.971212 -16.34254 -0.613260269 1.12707138 ) (33.28118 11.204418 14.357952 -15.215469 -38.76097 14.419889 ) (28.258647 3.1988945 -24.403022 -0.795579792 23.657165 -4.80662918 ) (15.6842098 -4.17232513E-7 -0.745855928 -5.60220909 28.1323 4.80662918 ) (29.004505 -3.19889498 27.386447 -0.795579315 -46.186386 -14.419889 ) (33.29776 -11.20442 -18.799942 -15.215469 6.61326218 -1.12706756 ) (17.804447 -26.983425 -12.1866798 -16.3425369 1.73335075 12.928171 ) (6.4844427 -36.861877 -10.453329 -3.41436482 10.453329 3.41436482 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 150Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:17:17) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((81 0) (81 0) (81 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((81 337) (132 337)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((132 337) (132 221)) NIL ((0 -116. 0 0 0 0 )) NATURAL) (11 ((132 221) (159 239) (190 249) (215 254) (244 256) (273 253) (301 245) (321 236) (336 224) (348 208) (355 187)) NIL ((25.419338 19.823307 0 0 9.48395349 -10.939859 ) (30.161315 14.353378 9.48395349 -10.939859 -23.419769 6.69930363 ) (27.935386 6.76317025 -13.9358158 -4.24055577 24.195125 2.14264202 ) (26.097133 3.59393549 10.2593097 -2.09791374 -13.3607387 -3.26987267 ) (29.676075 -0.138914734 -3.10142994 -5.3677864 5.24783802 -1.06315231 ) (29.198562 -6.03827763 2.14640856 -6.4309387 -13.630613 7.5224819 ) (24.529663 -8.7079754 -11.484205 1.09154343 7.27461815 -5.02677727 ) (16.6827659 -10.1298198 -4.2095871 -3.93523455 2.53214359 0.584630490 ) (13.739254 -13.772739 -1.67744326 -3.35060406 -5.40319538 -3.31174469 ) (9.3602123 -18.779216 -7.08063889 -6.66234875 7.08063889 6.66234875 )) NATURAL) (2 ((355 187) (357 0)) NIL ((2. -187. 0 0 0 0 )) NATURAL) (2 ((357 0) (308 0)) NIL ((-49. 0 0 0 0 0 )) NATURAL) (2 ((308 0) (308 166)) NIL ((0 166. 0 0 0 0 )) NATURAL) (9 ((308 166) (302 195) (283 213) (255 220) (232 221) (202 218) (168 211) (142 191) (132 166)) NIL ((-3.2881074 31.25368 0 0 -16.271354 -13.5220909 ) (-11.423784 24.492633 -16.271354 -13.5220909 3.35677528 1.61045646 ) (-26.01675 11.775772 -12.914579 -11.911634 26.844253 7.08026505 ) (-25.5092 3.40427065 13.929674 -4.8313694 -26.733795 0.0684823990 ) (-24.946426 -1.39285707 -12.8041229 -4.762887 8.09094239 4.64580345 ) (-33.705078 -3.83284283 -4.71318054 -0.117083445 12.370027 -18.651691 ) (-32.233245 -13.275772 7.65684796 -18.7687759 14.4289398 15.9609699 ) (-17.361927 -24.064064 22.085788 -2.80780554 -22.085788 2.80780554 )) NATURAL) (2 ((132 166) (132 0)) NIL ((0 -166. 0 0 0 0 )) NATURAL) (2 ((132 0) (81 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 151Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:21:40) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((254 210) (254 0)) NIL ((0 -210. 0 0 0 0 )) NATURAL) (2 ((254 0) (304 0)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((304 0) (304 246)) NIL ((0 246. 0 0 0 0 )) NATURAL) (2 ((304 246) (115 246)) NIL ((-189. 0 0 0 0 0 )) NATURAL) (2 ((115 246) (115 210)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((115 210) (254 210)) NIL ((139. 0 0 0 0 0 )) NATURAL)) ((13 ((236 313) (240 329) (251 339) (275 345) (299 339) (310 329) (314 313) (310 297) (299 287) (275 281) (251 287) (240 297) (236 313)) NIL ((2.99777937 17.538459 0 0 6.01332379 -9.2307682 ) (6.00444127 12.9230766 6.01332379 -9.2307682 11.93338 10.1538429 ) (17.984455 8.7692299 17.946704 0.923076273 -17.7468529 -19.384609 ) (27.057731 -6.96629285E-7 0.199850619 -18.461536 -18.945957 19.384613 ) (17.784599 -8.7692299 -18.746109 0.923076988 15.530712 -10.1538448 ) (6.80384827 -12.9230766 -3.21539688 -9.2307682 -7.17690278 9.2307682 ) (-7.15255737E-7 -17.538459 -10.3922996 0 7.17690278 9.2307682 ) (-6.80384827 -12.9230747 -3.2153964 9.2307682 -15.5307159 -10.1538448 ) (-17.784603 -8.7692299 -18.746112 -0.923076749 18.945961 19.384613 ) (-27.057731 6.96629285E-7 0.199851840 18.461536 17.7468529 -19.384613 ) (-17.984455 8.7692299 17.946704 -0.923076988 -11.93338 10.1538448 ) (-6.00444127 12.9230766 6.01332379 9.2307682 -6.01332379 -9.2307682 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 152Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:27:59) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((275 -33) (275 210)) NIL ((0 243. 0 0 0 0 )) NATURAL) (2 ((275 210) (136 210)) NIL ((-139. 0 0 0 0 0 )) NATURAL) (2 ((136 210) (136 246)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((136 246) (325 246)) NIL ((189. 0 0 0 0 0 )) NATURAL) (2 ((325 246) (325 -32)) NIL ((0 -278. 0 0 0 0 )) NATURAL) (13 ((325 -32) (321 -50) (312 -67) (298 -83) (279 -97) (250 -107) (193 -113) (136 -107) (108 -97) (88 -83) (75 -67) (66 -50) (61 -34)) NIL ((-2.93862963 -18.215393 0 0 -6.36822224 1.29237032 ) (-6.12274075 -17.569206 -6.36822224 1.29237032 1.84111404 -0.461851597 ) (-11.5704059 -16.5077629 -4.52710819 0.830518723 -0.996235848 0.555036068 ) (-16.59563 -15.3997268 -5.52334404 1.38555479 2.14382934 4.2417059 ) (-21.047061 -11.89332 -3.37951469 5.62726116 -37.579078 -5.52186203 ) (-43.216117 -9.02698899 -40.958595 0.105398297 40.172508 17.845745 ) (-64.088455 0.00128283351 -0.786086679 17.951145 44.889015 -17.861129 ) (-42.43003 9.021862 44.102935 0.0900126547 -45.728599 5.5987873 ) (-21.191398 11.911268 -1.62566781 5.6888008 12.0254 -4.5340147 ) (-16.804367 15.333061 10.3997326 1.15478539 -8.37299348 0.537271738 ) (-10.591131 16.756481 2.02673769 1.69205713 3.466578 -3.6150713 ) (-6.83110524 16.641002 5.4933157 -1.92301416 -5.4933157 1.92301416 )) NATURAL) (2 ((61 -34) (111 -33)) NIL ((50. 1. 0 0 0 0 )) NATURAL) (9 ((111 -33) (120 -56) (145 -71) (170 -75) (193 -77) (216 -75) (241 -71) (266 -56) (275 -33)) NIL ((4.75 -24.371131 0 0 25.5 8.2268028 ) (17.5 -20.257728 25.5 8.2268028 -31.5 6.86598015 ) (27.249996 -8.59793664 -6. 15.0927829 4.5 -17.690719 ) (23.499996 -2.35051536 -1.49999976 -2.59793806 1.49999952 9.8969059 ) (22.75 -1.58324837E-7 -6.38824957E-8 7.29896927 1.5 -9.8969059 ) (23.5 2.35051536 1.5 -2.59793758 4.49999905 17.690715 ) (27.249996 8.59793855 5.99999905 15.092781 -31.499992 -6.86597634 ) (17.499996 20.257728 -25.499996 8.22680474 25.499996 -8.22680474 )) NATURAL)) ((13 ((296 345) (272 339) (261 329) (257 313) (261 297) (272 287) (296 281) (320 287) (331 297) (335 313) (331 329) (320 339) (296 345)) NIL ((-27.115383 -5.32938576 0 0 18.692306 -4.02368546 ) (-17.7692299 -7.34122849 18.692306 -4.02368546 -15.461536 -3.88156986 ) (-6.80769158 -13.305698 3.23076916 -7.9052553 7.15384579 7.549963 ) (2.38418579E-7 -17.43597 10.3846149 -0.355292022 -7.15384579 9.681715 ) (6.80769253 -12.950405 3.23076868 9.32642365 15.461536 -10.2768306 ) (17.7692299 -8.76239778 18.692306 -0.950407744 -18.692306 19.425609 ) (27.115383 -2.57045030E-7 0 18.475204 -18.692306 -19.425609 ) (17.7692299 8.76239778 -18.692306 -0.950407386 15.461538 10.2768306 ) (6.80769158 12.950407 -3.2307682 9.32642365 -7.15384675 -9.681715 ) (-2.38418579E-7 17.43597 -10.3846149 -0.355291724 7.15384579 -7.549963 ) (-6.80769253 13.305698 -3.23076868 -7.9052553 -15.461536 3.88156986 ) (-17.7692299 7.34122849 -18.692306 -4.02368546 18.692306 4.02368546 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 153Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:32:02) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((73 0) (73 337)) NIL ((0 337. 0 0 0 0 )) NATURAL) (2 ((73 337) (120 337)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((120 337) (120 157)) NIL ((0 -180. 0 0 0 0 )) NATURAL) (2 ((120 157) (165 157)) NIL ((45. 0 0 0 0 0 )) NATURAL) (2 ((165 157) (293 246)) NIL ((128. 89. 0 0 0 0 )) NATURAL) (2 ((293 246) (360 246)) NIL ((67. 0 0 0 0 0 )) NATURAL) (2 ((360 246) (199 136)) NIL ((-161. -110. 0 0 0 0 )) NATURAL) (2 ((199 136) (405 0)) NIL ((206. -136. 0 0 0 0 )) NATURAL) (2 ((405 0) (333 0)) NIL ((-72. 0 0 0 0 0 )) NATURAL) (2 ((333 0) (165 110)) NIL ((-168. 110. 0 0 0 0 )) NATURAL) (2 ((165 110) (120 110)) NIL ((-45. 0 0 0 0 0 )) NATURAL) (2 ((120 110) (120 0)) NIL ((0 -110. 0 0 0 0 )) NATURAL) (2 ((120 0) (73 0)) NIL ((-47. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 154Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:32:50) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((232 0) (232 301)) NIL ((0 301. 0 0 0 0 )) NATURAL) (2 ((232 301) (94 301)) NIL ((-138. 0 0 0 0 0 )) NATURAL) (2 ((94 301) (94 337)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((94 337) (283 337)) NIL ((189. 0 0 0 0 0 )) NATURAL) (2 ((283 337) (283 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL) (2 ((283 0) (232 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 155Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 8:39:05) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((31 0) (31 246)) NIL ((0 246. 0 0 0 0 )) NATURAL) (2 ((31 246) (78 246)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((78 246) (78 227)) NIL ((0 -19. 0 0 0 0 )) NATURAL) (9 ((78 227) (88 237) (100 244) (117 250) (153 254) (178 254) (205 250) (225 244) (241 232)) NIL ((9.3958931 10.755245 0 0 3.62463093 -4.53147984 ) (11.20821 8.48950578 3.62463093 -4.53147984 -6.1231556 4.65740013 ) (11.771263 6.286726 -2.49852466 0.125920355 38.867988 -2.09812164 ) (28.706737 5.36358547 36.369468 -1.97220134 -65.348846 -2.26491165 ) (32.401779 2.2589283 -28.979377 -4.237113 42.52742 -0.842230797 ) (24.686119 -2.39930057 13.548048 -5.0793438 -26.76086 5.63383484 ) (24.853736 -4.661726 -13.212812 0.554491878 10.516016 -9.6931133 ) (16.898929 -8.95379258 -2.69679642 -9.13862229 2.69679642 9.13862229 )) NATURAL) (10 ((241 232) (256 241) (274 248) (294 253) (322 255) (358 250) (381 242) (394 231) (403 220) (409 200)) NIL ((14.241657 9.41674615 0 0 4.5500555 -2.50048065 ) (16.516681 8.1665058 4.5500555 -2.50048065 -4.75027752 0.502404452 ) (18.6916 5.91722679 -0.200222254 -1.9980762 8.4510555 0.490862370 ) (22.716903 4.16458225 8.2508335 -1.50721383 6.94605637 -8.46585084 ) (34.440765 -1.57555818 15.1968898 -9.9730663 -36.235282 9.37254716 ) (31.520011 -6.86235047 -21.038398 -0.600517631 11.995113 -5.02434349 ) (16.4791679 -9.9750385 -9.04328538 -5.6248617 6.25482846 10.7248249 ) (10.563299 -10.2374878 -2.78845692 5.09996319 -1.01442861 -19.87495 ) (7.2676277 -15.075002 -3.80288553 -14.77499 3.80288553 14.77499 )) NATURAL) (2 ((409 200) (409 0)) NIL ((0 -200. 0 0 0 0 )) NATURAL) (2 ((409 0) (359 0)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((359 0) (359 190)) NIL ((0 190. 0 0 0 0 )) NATURAL) (9 ((359 190) (355 206) (341 215) (319 219) (294 219) (271 214) (258 205) (252 190) (250 174)) NIL ((-1.83845734 17.571243 0 0 -12.969255 -9.42746545 ) (-8.32308579 12.857509 -12.969255 -9.42746545 4.84628105 5.1373329 ) (-18.869197 5.99871063 -8.1229744 -4.29013253 5.58413029 0.878129960 ) (-24.200107 2.14764309 -2.53884363 -3.41200256 2.81719446 -2.64985275 ) (-25.330356 -2.58928585 0.278350830 -6.0618553 13.147089 3.72128105 ) (-18.478458 -6.79050065 13.4254398 -2.34057426 -7.40555764 -6.23527337 ) (-8.75579835 -12.2487106 6.0198822 -8.5758476 -1.52485275 9.21980859 ) (-3.49834299 -16.214653 4.49502945 0.643961907 -4.49502945 -0.643961907 )) NATURAL) (2 ((250 174) (250 0)) NIL ((0 -174. 0 0 0 0 )) NATURAL) (2 ((250 0) (201 0)) NIL ((-49. 0 0 0 0 0 )) NATURAL) (2 ((201 0) (201 190)) NIL ((0 190. 0 0 0 0 )) NATURAL) (10 ((201 190) (197 206) (183 215) (161 219) (142 220) (122 218) (99 214) (86 205) (80 190) (78 174)) NIL ((-1.95049953 17.560386 0 0 -12.2970028 -9.3623371 ) (-8.09900094 12.879219 -12.2970028 -9.3623371 1.48501777 4.81169033 ) (-19.653495 5.92272759 -10.811985 -4.55064678 18.356933 2.11557484 ) (-21.287014 2.42986774 7.54494954 -2.43507194 -8.9127617 -1.27399206 ) (-18.198444 -0.642200113 -1.36781311 -3.709064 -6.70588303 2.98039245 ) (-22.9192 -2.86106777 -8.07369615 -0.728671313 23.736293 -4.64757633 ) (-19.124748 -5.91352749 15.662597 -5.37624836 -10.23929 -2.39008522 ) (-8.58179666 -12.484817 5.42330647 -7.76633359 -0.779133797 8.20791627 ) (-3.54805756 -16.1471939 4.64417267 0.441583455 -4.64417267 -0.441583455 )) NATURAL) (2 ((78 174) (78 0)) NIL ((0 -174. 0 0 0 0 )) NATURAL) (2 ((78 0) (31 0)) NIL ((-47. 0 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/GACHAE.LC2-SF b/obsolete/lispusers/splinefonts/GACHAE.LC2-SF deleted file mode 100644 index 2b113cd5..00000000 --- a/obsolete/lispusers/splinefonts/GACHAE.LC2-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY gacha) (CHARACTER 156Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:03:06) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((81 0) (81 0) (81 246)) NIL ((0 -61.5 0 0 0 369. ) (0 123. 0 369. 0 -369. )) NATURAL) (2 ((81 246) (132 246)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((132 246) (132 231)) NIL ((0 -15. 0 0 0 0 )) NATURAL) (12 ((132 231) (146 239) (165 247) (188 252) (219 255) (244 255) (273 253) (301 245) (321 236) (336 224) (348 208) (355 187)) NIL ((12.757387 7.8082018 0 0 7.45567608 1.15078807 ) (16.4852218 8.3835945 7.45567608 1.15078807 -7.2783804 -5.75393963 ) (20.301708 6.65741254 0.177295416 -4.60315228 15.657846 3.86497593 ) (28.30793 3.9867487 15.835142 -0.738176108 -31.353008 -3.705966 ) (28.466568 1.39558935 -15.517866 -4.44414234 25.754188 4.95888996 ) (25.825794 -0.569107771 10.236322 0.514747978 -11.6637478 -10.1295967 ) (30.230243 -5.11915779 -1.42742538 -9.6148491 -9.09919549 11.5594978 ) (24.253219 -8.95425797 -10.5266208 1.94464874 6.0605383 -6.10839368 ) (16.756866 -10.0638065 -4.46608258 -4.16374493 2.85703802 0.874077321 ) (13.719303 -13.790512 -1.60904455 -3.2896676 -5.48869324 -3.38791514 ) (9.36591149 -18.774135 -7.09773827 -6.67758275 7.09773827 6.67758275 )) NATURAL) (2 ((355 187) (357 0)) NIL ((2. -187. 0 0 0 0 )) NATURAL) (2 ((357 0) (308 0)) NIL ((-49. 0 0 0 0 0 )) NATURAL) (2 ((308 0) (308 176)) NIL ((0 176. 0 0 0 0 )) NATURAL) (11 ((308 176) (307 191) (295 205) (275 215) (247 219) (223 220) (197 219) (168 215) (149 205) (137 191) (132 176)) NIL ((1.54838872 15.082872 0 0 -15.2903328 -0.497237682 ) (-6.09677697 14.834253 -15.2903328 -0.497237682 10.4516639 -3.51381159 ) (-16.161277 12.5801086 -4.83866883 -4.01104927 -8.5163231 -3.44751453 ) (-25.258106 6.84530354 -13.3549919 -7.4585638 23.613628 5.30386734 ) (-26.806285 2.03867388 10.258636 -2.15469599 -13.938192 0.232043981 ) (-23.516746 -7.96280801E-8 -3.67955732 -1.922652 -3.86084795 -0.232043504 ) (-29.126728 -2.03867388 -7.54040528 -2.15469551 23.381584 -5.3038683 ) (-24.976337 -6.84530354 15.8411789 -7.4585638 -11.665493 3.44751453 ) (-14.9679069 -12.58011 4.17568493 -4.01104927 5.28039456 3.51381159 ) (-8.1520252 -14.834253 9.45607949 -0.497237623 -9.45607949 0.497237623 )) NATURAL) (2 ((132 176) (132 0)) NIL ((0 -176. 0 0 0 0 )) NATURAL) (2 ((132 0) (81 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 157Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:07:04) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((29 ((220 253) (184 250) (150 243) (111 227) (90 209) (72 184) (61 148) (58 124) (61 100) (72 64) (90 39) (111 21) (148 3) (184 -4) (220 -7) (256 -4) (292 3) (330 21) (351 39) (369 64) (379 100) (382 124) (379 148) (369 184) (351 209) (330 227) (291 243) (256 250) (220 253)) NIL ((-37.23284 -2.5527296 0 0 7.3970537 -2.68362236 ) (-33.534309 -3.89454079 7.3970537 -2.68362236 -24.985267 -10.581888 ) (-38.629898 -11.869106 -17.5882149 -13.26551 50.544029 15.0111789 ) (-30.94609 -17.629028 32.955818 1.74566984 -39.190887 -7.4628372 ) (-17.58572 -19.614776 -6.23507023 -5.71716786 16.219528 -15.159822 ) (-15.711023 -32.911857 9.9844608 -20.876991 -1.68723678 44.102119 ) (-6.5701809 -31.737785 8.29722405 23.225132 -3.47058487 -23.24868 ) (-0.00824896433 -20.136993 4.82663918 -0.0235491991 3.56957626 -23.107383 ) (6.60317803 -31.714237 8.39621545 -23.130935 1.19228363 43.67823 ) (15.595535 -33.00605 9.58849908 20.547298 -14.338714 -13.6055526 ) (18.014675 -19.261531 -4.75021649 6.9417448 32.162574 -13.256025 ) (29.345752 -18.947799 27.412365 -6.31428147 -36.311607 24.629661 ) (38.60231 -12.94725 -8.8992462 18.31538 11.083864 -19.26263 ) (35.244995 -4.26318646 2.18461943 -0.947252036 -2.02385092 10.4208755 ) (36.417686 4.37721610E-7 0.160768091 9.47362519 -2.98846006 -10.420877 ) (35.084228 4.26318646 -2.82769203 -0.947252989 13.977691 19.262634 ) (39.245384 12.947252 11.1499996 18.3153839 -40.922302 -24.629665 ) (29.93423 18.947799 -29.772304 -6.31428147 35.711525 13.256027 ) (18.017688 19.261531 5.93922329 6.94174576 -17.923809 13.6055526 ) (14.995006 33.00605 -11.9845867 20.547298 5.98371315 -43.67823 ) (6.00227643 31.714233 -6.00087357 -23.130935 -0.0110425949 23.107383 ) (-0.00411796570 20.136993 -6.01191617 -0.0235481784 0.0604562759 23.24868 ) (-5.9858074 31.737785 -5.95145989 23.225132 -6.23077584 -44.102119 ) (-15.052654 32.91185 -12.1822357 -20.876987 18.86264 15.159818 ) (-17.803569 19.614776 6.68040753 -5.7171688 -39.219795 7.46283913 ) (-30.733062 17.629028 -32.53939 1.74567079 48.016555 -15.0111828 ) (-39.264167 11.869106 15.4771709 -13.265512 -20.846462 10.58189 ) (-34.210235 3.8945403 -5.36929226 -2.6836214 5.36929226 2.6836214 )) NATURAL)) ((21 ((244 28) (221 26) (196 28) (160 36) (138 47) (117 71) (106 124) (117 177) (138 201) (160 212) (196 220) (221 221) (244 220) (280 212) (303 201) (324 177) (334 124) (324 71) (303 47) (280 36) (244 28)) NIL ((-31.346866 -4.94781018 27.096454 7.89321995 -31.20816 -5.99279499 ) (-19.854492 -0.0509881154 -4.11170769 1.90042472 -18.537914 6.6046543 ) (-33.235153 5.1517639 -22.649623 8.50507928 51.359825 -8.4258213 ) (-30.204864 9.44393159 28.7102 0.0792564750 -36.90139 9.0986347 ) (-19.945362 14.0725078 -8.19119454 9.17789269 18.245773 32.031272 ) (-19.013671 39.266037 10.0545787 41.209167 17.918293 -41.223762 ) (5.46798110E-5 59.863327 27.972873 -0.0145962312 -17.918949 -41.136184 ) (19.01345 39.280632 10.0539245 -41.150787 -18.242496 31.768524 ) (19.946128 14.014112 -8.18857194 -9.38226129 36.88893 10.062099 ) (30.202026 9.6629028 28.700363 0.679839969 -51.313247 -12.016935 ) (33.245758 4.33427334 -22.612884 -11.337097 18.364067 14.005647 ) (19.81491 1.11246481E-6 -4.24881554 2.66855192 31.85696 -14.005661 ) (31.494579 -4.33427906 27.608146 -11.33711 -55.791923 12.0170059 ) (31.206764 -9.66288568 -28.183776 0.679895640 35.31073 -10.062366 ) (20.678356 -14.014175 7.1269579 -9.38247109 -19.451011 -31.767528 ) (18.079803 -39.28041 -12.3240547 -41.15 -11.506668 41.132476 ) (0.00241565704 -59.864166 -23.830722 -0.0175195671 11.477674 41.237594 ) (-18.0894699 -39.262886 -12.353048 41.220077 19.59597 -32.08287 ) (-20.644531 -14.084251 7.24292184 9.1372032 -35.861557 -8.9060955 ) (-31.332393 -9.4000969 -28.618637 0.231106251 57.850273 7.70726395 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 160Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:12:38) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((73 246) (73 -98)) NIL ((0 -344. 0 0 0 0 )) NATURAL) (2 ((73 -98) (122 -98)) NIL ((49. 0 0 0 0 0 )) NATURAL) (2 ((122 -98) (122 19)) NIL ((0 117. 0 0 0 0 )) NATURAL) (19 ((122 19) (152 6) (186 -2) (223 -6) (274 -2) (306 10) (330 24) (346 42) (358 66) (367 124) (358 182) (346 206) (330 224) (306 238) (274 250) (223 254) (186 250) (149 241) (122 229)) NIL ((28.78485 -14.1662578 0 0 7.29088879 6.99755765 ) (32.43029 -10.6674785 7.29088879 6.99755765 -12.4544449 -4.9877901 ) (33.493957 -6.1638174 -5.1635561 2.00976705 36.526893 6.95360566 ) (46.593849 -0.677247048 31.363338 8.96337319 -67.653137 1.17336273 ) (44.130615 8.87280656 -36.28981 10.1367359 36.0857 -11.6470565 ) (25.883659 13.186014 -0.204107195 -1.51032066 -10.689651 9.4148655 ) (20.334728 16.383125 -10.8937587 7.90454579 6.67289925 -14.012405 ) (12.777418 17.281471 -4.22085953 -6.10786057 7.9980583 58.63475 ) (12.5555877 40.490989 3.77719927 52.526893 -32.66513 -52.526634 ) (2.22682952E-4 66.75456 -28.887935 2.57580541E-4 32.662468 -52.528175 ) (-12.556476 40.49073 3.77453518 -52.527923 -7.98474026 58.639366 ) (-12.7743129 17.282493 -4.21020508 6.11144925 -6.72350693 -14.029323 ) (-20.346271 16.37928 -10.933712 -7.91787434 10.8787708 9.4779205 ) (-25.840599 13.2003688 -0.0549402982 1.56004619 -36.791572 -11.8823547 ) (-44.291328 8.81923677 -36.846519 -10.322309 70.28755 2.05150032 ) (-45.99407 -0.477321923 33.441032 -8.27080918 -46.358634 3.67635918 ) (-35.73236 -6.9099512 -12.917608 -4.59445 31.147007 1.24306249 ) (-33.076461 -10.8828697 18.2294 -3.3513875 -18.2294 3.3513875 )) NATURAL) (2 ((122 229) (122 246)) NIL ((0 17. 0 0 0 0 )) NATURAL) (2 ((122 246) (73 246)) NIL ((-49. 0 0 0 0 0 )) NATURAL)) ((11 ((121 124) (124 162) (136 195) (162 214) (196 220) (222 222) (244 220) (279 214) (304 195) (316 162) (319 124)) NIL ((1.40951395 38.569053 0 0 9.54291535 -3.41436482 ) (6.1809721 36.861877 9.54291535 -3.41436482 6.28541756 -12.9281749 ) (18.866596 26.983425 15.8283329 -16.34254 -4.68458176 1.12707138 ) (32.352638 11.204418 11.143751 -15.215469 -23.547092 14.419889 ) (31.722843 3.1988945 -12.403341 -0.795579792 2.87295532 -4.80662918 ) (20.755977 -4.17232513E-7 -9.53038598 -5.60220909 36.055267 4.80662918 ) (29.25323 -3.19889498 26.524887 -0.795579315 -45.094047 -14.419889 ) (33.231086 -11.20442 -18.569164 -15.215469 6.32094384 -1.12706756 ) (17.822395 -26.983425 -12.24822 -16.3425369 1.81027794 12.928171 ) (6.47931386 -36.861877 -10.437942 -3.41436482 10.437942 3.41436482 )) NATURAL) (11 ((319 124) (316 86) (304 53) (279 34) (244 28) (222 26) (196 28) (162 34) (136 53) (124 86) (121 124)) NIL ((-1.26034259 -38.569053 0 0 -10.437944 3.41436482 ) (-6.4793148 -36.861877 -10.437944 3.41436482 -1.81027794 12.9281749 ) (-17.822395 -26.983425 -12.248222 16.34254 -6.32094193 -1.12707138 ) (-33.231086 -11.204418 -18.569164 15.215469 45.094047 -14.419889 ) (-29.25323 -3.1988945 26.524887 0.795579792 -36.055267 4.80662918 ) (-20.755977 4.17232513E-7 -9.53038598 5.60220909 -2.87295532 -4.80662918 ) (-31.722843 3.19889498 -12.403341 0.795579315 23.547092 14.419889 ) (-32.352638 11.20442 11.143753 15.215469 4.68457794 1.12706756 ) (-18.866596 26.983425 15.828331 16.3425369 -6.28541566 -12.928171 ) (-6.18097115 36.861877 9.54291535 3.41436482 -9.54291535 -3.41436482 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 161Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:19:54) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((367 -98) (319 -98)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((319 -98) (319 19)) NIL ((0 117. 0 0 0 0 )) NATURAL) (19 ((319 19) (288 7) (255 -1) (217 -6) (166 -2) (134 9) (111 24) (94 42) (82 66) (73 124) (82 182) (94 206) (111 224) (134 239) (166 250) (217 254) (255 250) (292 241) (319 229)) NIL ((-30.485801 -12.997631 0 0 -3.08518171 5.9857931 ) (-32.028389 -10.004734 -3.08518171 5.9857931 3.42590904 -5.92896652 ) (-33.400619 -6.98342515 0.340727687 0.0568262711 -28.618454 11.7300739 ) (-47.369117 -1.06156039 -28.277729 11.786901 63.04792 -4.99134159 ) (-44.122886 8.22966958 34.770195 6.79555989 -31.57326 -3.76470089 ) (-25.13932 13.142879 3.19693089 3.03085899 3.24514675 2.05014229 ) (-20.319816 17.19881 6.44207764 5.08100128 0.592679024 -10.435867 ) (-13.5813999 17.061878 7.03475667 -5.35486698 -11.6158619 57.693328 ) (-12.354574 40.553672 -4.58110619 52.338462 33.870765 -52.337432 ) (-2.96272337E-4 66.723404 29.289665 0.00102418940 -33.867218 -52.34358 ) (12.3557586 40.552642 -4.5775528 -52.342559 11.5981006 57.711776 ) (13.577257 17.065979 7.0205488 5.36921883 -0.525197029 -10.503532 ) (20.335208 17.183429 6.4953518 -5.13431454 -3.49731016 2.30235624 ) (25.081905 13.200292 2.99804163 -2.83195829 32.514434 -4.7058897 ) (44.337165 8.0153904 35.51248 -7.53784848 -66.560455 -1.47879696 ) (46.56941 -0.261858106 -31.047985 -9.01664544 41.727447 4.62108517 ) (36.385154 -6.9679613 10.679462 -4.39556027 -28.349323 0.994450570 ) (32.889953 -10.8662967 -17.66986 -3.4011097 17.66986 3.4011097 )) NATURAL) (2 ((319 229) (319 246)) NIL ((0 17. 0 0 0 0 )) NATURAL) (2 ((319 246) (367 246)) NIL ((48. 0 0 0 0 0 )) NATURAL) (2 ((367 246) (367 -98)) NIL ((0 -344. 0 0 0 0 )) NATURAL)) ((11 ((319 124) (316 162) (304 195) (279 214) (244 220) (220 222) (196 220) (162 214) (136 195) (124 162) (121 124)) NIL ((-1.27691745 38.569053 0 0 -10.338495 -3.41436482 ) (-6.44616604 36.861877 -10.338495 -3.41436482 -2.307518 -12.9281749 ) (-17.938419 26.983425 -12.646013 -16.34254 -4.43143654 1.12707138 ) (-32.800148 11.204418 -17.077449 -15.215469 38.03327 14.419889 ) (-30.860965 3.1988945 20.955825 -0.795579792 -21.701679 -4.80662918 ) (-20.755977 -4.17232513E-7 -0.745855928 -5.60220909 -17.226543 4.80662918 ) (-30.115108 -3.19889498 -17.9724 -0.795579315 30.607864 -14.419889 ) (-32.783577 -11.20442 12.6354656 -15.215469 2.79507446 -1.12706756 ) (-18.750572 -26.983425 15.43054 -16.3425369 -5.78817559 12.928171 ) (-6.21412087 -36.861877 9.6423645 -3.41436482 -9.6423645 3.41436482 )) NATURAL) (11 ((121 124) (124 86) (136 53) (162 34) (196 28) (220 26) (244 28) (279 34) (304 53) (316 86) (319 124)) NIL ((1.39293909 -38.569053 0 0 9.6423645 3.41436482 ) (6.21412087 -36.861877 9.6423645 3.41436482 5.78817749 12.9281749 ) (18.750572 -26.983425 15.430542 16.34254 -2.79507828 -1.12707138 ) (32.783577 -11.204418 12.6354637 15.215469 -30.607864 -14.419889 ) (30.115108 -3.1988945 -17.9724 0.795579792 17.226543 4.80662918 ) (20.755977 4.17232513E-7 -0.745855928 5.60220909 21.701679 -4.80662918 ) (30.860965 3.19889498 20.955825 0.795579315 -38.03327 14.419889 ) (32.800148 11.20442 -17.077449 15.215469 4.43143654 1.12706756 ) (17.938419 26.983425 -12.646013 16.3425369 2.3075161 -12.928171 ) (6.44616509 36.861877 -10.338497 3.41436482 10.338497 -3.41436482 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 162Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:24:15) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((94 0) (94 0) (94 246)) NIL ((0 -61.5 0 0 0 369. ) (0 123. 0 369. 0 -369. )) NATURAL) (2 ((94 246) (146 246)) NIL ((52. 0 0 0 0 0 )) NATURAL) (2 ((146 246) (146 231)) NIL ((0 -15. 0 0 0 0 )) NATURAL) (11 ((146 231) (172 241) (200 250) (226 254) (258 256) (286 253) (315 245) (334 236) (349 224) (361 208) (369 187)) NIL ((25.179721 9.92842675 0 0 4.92166043 0.429432392 ) (27.640552 10.1431427 4.92166043 0.429432392 -12.608301 -8.14716149 ) (26.25806 6.49899483 -7.6866417 -7.71772957 21.51155 8.15921594 ) (29.327194 2.8608737 13.824909 0.441486776 -25.4379 -6.48970318 ) (30.43315 0.0575087815 -11.612993 -6.04821683 20.240062 -0.200402260 ) (28.940189 -6.090909 8.62707139 -6.24861909 -25.522361 7.29131127 ) (24.806079 -8.69387246 -16.89529 1.04269218 15.849386 -4.96484089 ) (15.835481 -10.1336 -1.04590392 -3.92214918 -1.87518859 0.568055630 ) (13.851984 -13.7717228 -2.9210925 -3.35409355 -2.34863329 -3.30738258 ) (9.7565746 -18.779506 -5.2697258 -6.66147614 5.2697258 6.66147614 )) NATURAL) (2 ((369 187) (370 169)) NIL ((1. -18. 0 0 0 0 )) NATURAL) (2 ((370 169) (321 169)) NIL ((-49. 0 0 0 0 0 )) NATURAL) (10 ((321 169) (319 191) (307 205) (288 215) (259 220) (235 221) (209 219) (178 212) (155 193) (146 160)) NIL ((0.395535767 23.935108 0 0 -14.3732147 -11.6106548 ) (-6.79107094 18.129779 -14.3732147 -11.6106548 11.8660736 10.053274 ) (-15.2312488 11.545763 -2.50714111 -1.55738067 -15.091079 -4.60244179 ) (-25.283931 7.68716145 -17.59822 -6.15982247 30.498256 2.35649347 ) (-27.633022 2.70558596 12.9000358 -3.80332899 -16.901958 1.1764698 ) (-23.183967 -0.509507895 -4.00192356 -2.62685919 -4.89041806 -1.06237459 ) (-29.631099 -3.66755486 -8.8923416 -3.68923378 18.46363 -8.9269695 ) (-29.291626 -11.820274 9.57129098 -12.616203 9.03588296 -5.22974015 ) (-15.20239 -27.051349 18.6071739 -17.845943 -18.6071739 17.845943 )) NATURAL) (2 ((146 160) (146 0)) NIL ((0 -160. 0 0 0 0 )) NATURAL) (2 ((146 0) (94 0)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 163Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:34:01) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((25 ((351 186) (346 202) (336 220) (306 238) (265 250) (223 254) (183 252) (148 246) (120 234) (106 222) (94 204) (90 183) (96 165) (121 142) (175 120) (226 103) (277 85) (295 58) (281 32) (238 25) (210 26) (171 31) (138 42) (122 59) (117 73)) NIL ((-4.89096356 15.5457267 0 0 -0.654214859 2.72563505 ) (-5.21807099 16.908542 -0.654214859 2.72563505 -26.728923 -1.62817669 ) (-19.236747 18.820091 -27.38314 1.09745836 17.569915 -8.21292687 ) (-37.83493 15.811084 -9.8132229 -7.11546899 10.4492588 -1.52011108 ) (-42.423522 7.9355602 0.636036754 -8.63558007 0.633041024 2.29337406 ) (-41.470962 0.446667433 1.26907777 -6.342206 5.0185728 4.34661293 ) (-37.692596 -3.72223234 6.28765107 -1.99559283 -2.70733642 -7.67982579 ) (-32.758613 -9.55773736 3.58031464 -9.67541886 17.810775 14.372688 ) (-20.272914 -12.046812 21.39109 4.69726944 -26.535766 -13.81093 ) (-12.1497097 -14.2550087 -5.1446762 -9.1136608 16.3322868 4.87103844 ) (-9.1282406 -20.933151 11.187612 -4.24262238 -2.79339218 12.326774 ) (0.662676096 -19.012386 8.39422036 8.0841522 6.8412819 -18.178138 ) (12.477537 -20.017303 15.235502 -10.0939865 29.428268 12.385782 ) (42.427177 -23.918396 44.663772 2.2917962 -64.554397 4.63500405 ) (54.81375 -19.309097 -19.890628 6.92680073 36.789367 -6.92580319 ) (53.3178 -15.845199 16.8987388 9.97102587E-4 -64.603057 -12.9317836 ) (37.915008 -22.310096 -47.704322 -12.930788 23.622894 10.6529445 ) (2.02213144 -29.914409 -24.081428 -2.27784204 -23.888504 30.319995 ) (-34.003547 -17.032253 -47.969932 28.042156 89.931106 -23.932937 ) (-37.007927 -0.956568003 41.961174 4.10921669 -71.835937 -0.588241577 ) (-30.964725 2.85852814 -29.874763 3.52097511 41.412643 2.28590584 ) (-40.133163 7.52245618 11.5378837 5.80688095 8.1853447 3.44461632 ) (-24.502605 15.051645 19.723228 9.25149728 -8.15403558 -16.064369 ) (-8.8563976 16.2709579 11.5691928 -6.81287385 -11.5691928 6.81287385 )) NATURAL) (2 ((117 73) (72 73)) NIL ((-45. 0 0 0 0 0 )) NATURAL) (24 ((72 73) (85 42) (112 15) (144 1) (183 -7) (222 -8) (261 -7) (296 0) (325 13) (349 37) (355 66) (348 95) (330 114) (292 131) (238 148) (187 165) (151 184) (156 213) (188 221) (213 223) (241 221) (277 214) (297 202) (303 186)) NIL ((9.47211839 -31.218654 0 0 21.167285 1.31194877 ) (20.055763 -30.562683 21.167285 1.31194877 -21.836437 17.440254 ) (30.304828 -20.530601 -0.669154763 18.752204 12.1784839 -17.072986 ) (35.724914 -10.3148918 11.5093307 1.67921805 -14.877496 8.8516998 ) (39.795494 -4.20982266 -3.3681674 10.530918 5.33150673 -12.3338146 ) (39.093078 0.154187590 1.96334004 -1.80289674 -6.4485321 10.483564 ) (37.832153 3.59307385 -4.4851923 8.68066789 -3.53737736 -5.60044766 ) (31.578277 9.47351838 -8.02256967 3.08022022 8.59804345 11.918224 ) (27.854728 18.512851 0.575473786 14.998445 -24.854797 -12.0724487 ) (16.0028 27.47507 -24.279323 2.9259963 12.821157 0.371571064 ) (-1.86594367 30.586853 -11.458166 3.29756737 3.57016087 -19.413829 ) (-11.539028 24.177501 -7.88800526 -16.116264 -15.101804 17.28376 ) (-26.977935 16.703121 -22.98981 1.16749811 2.83706665 -1.72122335 ) (-48.549217 17.0100059 -20.152744 -0.553725243 27.753543 1.6011281 ) (-54.825187 17.256843 7.6008024 1.04740286 0.148731231 -4.68328858 ) (-47.150016 15.962604 7.74953366 -3.63588619 43.651519 29.132022 ) (-17.574722 26.89273 51.401054 25.496139 -18.754821 -63.84481 ) (24.448917 20.466461 32.646232 -38.34867 -52.632209 40.247222 ) (30.779045 2.24140549 -19.985977 1.89855599 25.283653 -7.1441021 ) (23.434894 0.567910671 5.297678 -5.24554634 11.497587 0.329174995 ) (34.48136 -4.51304817 16.795265 -4.91637135 -41.274002 -0.172595977 ) (30.639629 -9.51571656 -24.478736 -5.08896733 9.598423 0.361209869 ) (10.9601039 -14.4240799 -14.8803138 -4.72775746 14.8803138 4.72775746 )) NATURAL) (2 ((303 186) (351 186)) NIL ((48. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 164Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:41:54) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((215 316) (169 316)) NIL ((-46. 0 0 0 0 0 )) NATURAL) (2 ((169 316) (169 246)) NIL ((0 -70. 0 0 0 0 )) NATURAL) (2 ((169 246) (73 246)) NIL ((-96. 0 0 0 0 0 )) NATURAL) (2 ((73 246) (73 210)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((73 210) (169 210)) NIL ((96. 0 0 0 0 0 )) NATURAL) (2 ((169 210) (169 60)) NIL ((0 -150. 0 0 0 0 )) NATURAL) (11 ((169 60) (175 39) (189 20) (205 7) (229 -3) (268 -9) (316 -6) (346 3) (367 20) (381 38) (388 69)) NIL ((3.90507937 -21.153274 0 0 12.5695228 0.919651986 ) (10.18984 -20.693447 12.5695228 0.919651986 -14.847616 7.40174008 ) (15.335556 -16.072925 -2.27809334 8.32139207 10.8209438 -6.526618 ) (18.467933 -11.014843 8.5428505 1.79477358 7.56383896 0.704737187 ) (30.792705 -8.86770059 16.106689 2.49951076 0.923694611 9.7076702 ) (47.361244 -1.51435375 17.030384 12.2071819 -47.258613 -9.53542138 ) (40.762313 5.92511654 -30.228233 2.67175913 26.110794 10.434017 ) (23.589481 13.8138847 -4.1174364 13.1057777 -3.1845789 -20.200649 ) (17.879753 16.8193359 -7.3020153 -7.09487343 -1.37248039 28.368587 ) (9.89149858 23.90876 -8.6744957 21.273715 8.6744957 -21.273715 )) NATURAL) (2 ((388 69) (340 69)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (8 ((340 69) (337 47) (325 33) (303 27) (272 25) (245 29) (222 40) (215 60)) NIL ((-1.11267614 -23.621776 0 0 -11.323942 9.73067666 ) (-6.7746477 -18.756439 -11.323942 9.73067666 2.61971664 -0.653385163 ) (-16.78873 -9.35245515 -8.70422555 9.0772915 -5.1549282 -7.1171398 ) (-28.070419 -3.83373404 -13.8591537 1.96015119 23.999996 5.12195015 ) (-29.929576 0.687392831 10.140844 7.0821018 -12.8450699 -1.37066269 ) (-26.211265 7.08416367 -2.70422554 5.71143914 27.380279 6.3607006 ) (-15.225351 15.975952 24.676055 12.0721397 -24.676055 -12.0721397 )) NATURAL) (2 ((215 60) (215 210)) NIL ((0 150. 0 0 0 0 )) NATURAL) (2 ((215 210) (334 210)) NIL ((119. 0 0 0 0 0 )) NATURAL) (2 ((334 210) (334 246)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((334 246) (215 246)) NIL ((-119. 0 0 0 0 0 )) NATURAL) (2 ((215 246) (215 316)) NIL ((0 70. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 165Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:50:36) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((3 ((367 0) (367 0) (367 246)) NIL ((0 -61.5 0 0 0 369. ) (0 123. 0 369. 0 -369. )) NATURAL) (2 ((367 246) (316 246)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((316 246) (316 90)) NIL ((0 -156. 0 0 0 0 )) NATURAL) (9 ((316 90) (308 59) (278 39) (243 30) (222 29) (196 29) (161 33) (132 49) (123 90)) NIL ((-2.74641037 -33.309829 0 0 -31.521537 13.858984 ) (-18.507179 -26.380336 -31.521537 13.858984 25.607692 -3.29491997 ) (-37.224868 -14.1688137 -5.91384316 10.564064 31.090755 -0.679307938 ) (-27.593334 -3.94440317 25.176914 9.8847561 -35.970726 -11.987848 ) (-20.401783 -0.0535713807 -10.7938156 -2.10309267 -1.20783996 6.63070584 ) (-31.799518 1.1586895 -12.001655 4.52761364 16.802093 3.46502209 ) (-35.400123 7.41881467 4.80043888 7.9926357 23.99945 27.5092 ) (-18.599964 29.166053 28.799892 35.501838 -28.799892 -35.501838 )) NATURAL) (2 ((123 90) (123 246)) NIL ((0 156. 0 0 0 0 )) NATURAL) (2 ((123 246) (75 246)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((75 246) (76 59)) NIL ((1. -187. 0 0 0 0 )) NATURAL) (11 ((76 59) (82 35) (96 18) (114 5) (141 -4) (175 -8) (204 -9) (235 -6) (258 -1) (277 7) (316 23)) NIL ((4.01473713 -25.642467 0 0 11.911575 9.85482026 ) (9.9705238 -20.715057 11.911575 9.85482026 -11.5578765 -7.27410126 ) (16.1031608 -14.497289 0.353697181 2.58071852 10.3199367 1.24158621 ) (21.616828 -11.295776 10.673635 3.82230473 0.278120041 2.30775452 ) (32.429519 -6.31959534 10.951755 6.13005925 -23.432415 -4.47259999 ) (31.665069 -2.42583704 -12.480661 1.65745854 21.451553 3.5826478 ) (29.910186 1.02294540 8.97089387 5.24010659 -20.373809 -3.85799217 ) (28.694175 4.3340559 -11.4029178 1.38211417 0.0436954498 -0.150678157 ) (17.313106 5.640831 -11.359222 1.23143601 44.199028 10.4607029 ) (28.053398 12.102619 32.839805 11.6921405 -32.839805 -11.6921405 )) NATURAL) (2 ((316 23) (316 0)) NIL ((0 -23. 0 0 0 0 )) NATURAL) (2 ((316 0) (367 0)) NIL ((51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 166Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:55:45) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((55 246) (195 0)) NIL ((140. -246. 0 0 0 0 )) NATURAL) (2 ((195 0) (242 0)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((242 0) (382 246)) NIL ((140. 246. 0 0 0 0 )) NATURAL) (2 ((382 246) (328 246)) NIL ((-54. 0 0 0 0 0 )) NATURAL) (2 ((328 246) (219 41)) NIL ((-109. -205. 0 0 0 0 )) NATURAL) (2 ((219 41) (110 246)) NIL ((-109. 205. 0 0 0 0 )) NATURAL) (2 ((110 246) (55 246)) NIL ((-55. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 167Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 9:57:51) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((25 246) (124 0)) NIL ((99. -246. 0 0 0 0 )) NATURAL) (2 ((124 0) (175 0)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((175 0) (219 146)) NIL ((44. 146. 0 0 0 0 )) NATURAL) (2 ((219 146) (262 0)) NIL ((43. -146. 0 0 0 0 )) NATURAL) (2 ((262 0) (313 0)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((313 0) (412 246)) NIL ((99. 246. 0 0 0 0 )) NATURAL) (2 ((412 246) (361 246)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((361 246) (286 62)) NIL ((-75. -184. 0 0 0 0 )) NATURAL) (2 ((286 62) (237 246)) NIL ((-49. 184. 0 0 0 0 )) NATURAL) (2 ((237 246) (201 246)) NIL ((-36. 0 0 0 0 0 )) NATURAL) (2 ((201 246) (151 62)) NIL ((-50. -184. 0 0 0 0 )) NATURAL) (2 ((151 62) (77 246)) NIL ((-74. 184. 0 0 0 0 )) NATURAL) (2 ((77 246) (25 246)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 170Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 10:01:04) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((76 246) (190 139)) NIL ((114. -107. 0 0 0 0 )) NATURAL) (2 ((190 139) (43 0)) NIL ((-147. -139. 0 0 0 0 )) NATURAL) (2 ((43 0) (98 0)) NIL ((55. 0 0 0 0 0 )) NATURAL) (2 ((98 0) (219 109)) NIL ((121. 109. 0 0 0 0 )) NATURAL) (2 ((219 109) (340 0)) NIL ((121. -109. 0 0 0 0 )) NATURAL) (2 ((340 0) (394 0)) NIL ((54. 0 0 0 0 0 )) NATURAL) (2 ((394 0) (248 139)) NIL ((-146. 139. 0 0 0 0 )) NATURAL) (2 ((248 139) (361 246)) NIL ((113. 107. 0 0 0 0 )) NATURAL) (2 ((361 246) (305 246)) NIL ((-56. 0 0 0 0 0 )) NATURAL) (2 ((305 246) (219 164)) NIL ((-86. -82. 0 0 0 0 )) NATURAL) (2 ((219 164) (132 246)) NIL ((-87. 82. 0 0 0 0 )) NATURAL) (2 ((132 246) (76 246)) NIL ((-56. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 171Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 10:03:58) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((67 246) (207 3)) NIL ((140. -243. 0 0 0 0 )) NATURAL) (8 ((207 3) (204 -28) (182 -55) (154 -65) (130 -67) (105 -63) (78 -50) (65 -25)) NIL ((1.58570909 -30.982479 0 0 -27.514255 -0.105117797 ) (-12.171417 -31.035038 -27.514255 -0.105117797 23.571277 24.525589 ) (-27.900032 -18.877357 -3.94297457 24.420471 11.2291298 -19.997249 ) (-26.228443 -4.455513 7.2861557 4.42322159 -8.4878044 1.4634161 ) (-23.186187 0.699416161 -1.20164919 5.88663769 -7.27790929 2.14358997 ) (-28.026794 7.65785027 -8.47955895 8.03022767 31.599445 7.9622154 ) (-20.706626 19.669185 23.119888 15.992443 -23.119888 -15.992443 )) NATURAL) (2 ((65 -25) (18 -25)) NIL ((-47. 0 0 0 0 0 )) NATURAL) (9 ((18 -25) (33 -57) (60 -81) (88 -95) (138 -101) (195 -91) (232 -69) (253 -38) (274 3)) NIL ((11.490978 -33.511222 0 0 21.054122 9.0673771 ) (22.018039 -28.977539 21.054122 9.0673771 -33.270614 2.66310882 ) (26.436855 -18.578605 -12.2164936 11.7304859 46.028343 -7.71980954 ) (37.234535 -10.7080249 33.81185 4.01067639 -24.842777 16.216125 ) (58.625 1.41071462 8.96907235 20.226802 -36.65721 -9.1446972 ) (49.265457 17.065166 -27.688144 11.0821056 9.47165299 -3.63733387 ) (26.31314 26.328605 -18.216491 7.44477177 22.770614 5.69403363 ) (19.481956 36.620391 4.55412293 13.138805 -4.55412293 -13.138805 )) NATURAL) (2 ((274 3) (394 246)) NIL ((120. 243. 0 0 0 0 )) NATURAL) (2 ((394 246) (340 246)) NIL ((-54. 0 0 0 0 0 )) NATURAL) (2 ((340 246) (241 37)) NIL ((-99. -209. 0 0 0 0 )) NATURAL) (2 ((241 37) (122 246)) NIL ((-119. 209. 0 0 0 0 )) NATURAL) (2 ((122 246) (67 246)) NIL ((-55. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 172Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 10:05:23) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((81 246) (369 246)) NIL ((288. 0 0 0 0 0 )) NATURAL) (2 ((369 246) (369 212)) NIL ((0 -34. 0 0 0 0 )) NATURAL) (2 ((369 212) (140 36)) NIL ((-229. -176. 0 0 0 0 )) NATURAL) (2 ((140 36) (378 36)) NIL ((238. 0 0 0 0 0 )) NATURAL) (2 ((378 36) (378 0)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((378 0) (63 0)) NIL ((-315. 0 0 0 0 0 )) NATURAL) (2 ((63 0) (63 34)) NIL ((0 34. 0 0 0 0 )) NATURAL) (2 ((63 34) (292 210)) NIL ((229. 176. 0 0 0 0 )) NATURAL) (2 ((292 210) (81 210)) NIL ((-211. 0 0 0 0 0 )) NATURAL) (2 ((81 210) (81 246)) NIL ((0 36. 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/GACHAE.NUM-SF b/obsolete/lispusers/splinefonts/GACHAE.NUM-SF deleted file mode 100644 index af6370f4..00000000 --- a/obsolete/lispusers/splinefonts/GACHAE.NUM-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY gacha) (CHARACTER 60Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 11:56:36) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((29 ((220 -2) (177 2) (142 13) (115 28) (97 49) (87 72) (78 108) (72 169) (78 230) (87 266) (97 289) (115 310) (142 325) (177 336) (220 340) (264 336) (298 325) (325 308) (343 289) (354 266) (363 230) (369 169) (363 108) (354 72) (343 49) (325 28) (298 13) (264 2) (220 -2)) NIL ((-44.70249 2.2971487 0 0 10.2149925 10.2171058 ) (-39.595 7.4057026 10.2149925 10.2171058 -3.07496834 -9.08553506 ) (-30.917491 13.0800399 7.14002419 1.13156938 2.08488273 8.12504388 ) (-22.735023 18.274131 9.2249069 9.25661469 0.735431671 -11.4146518 ) (-13.1424007 21.823421 9.9603386 -2.15803718 -11.0266018 13.533569 ) (-8.695364 26.43217 -1.06626343 11.375532 1.37097907 23.280372 ) (-9.07613755 49.44789 0.304715693 34.655906 17.542682 -34.655075 ) (-7.94418156E-5 66.776245 17.8474 8.27937503E-4 -17.541725 -34.660041 ) (9.07645799 49.447059 0.305675328 -34.659217 -1.37578034 23.295288 ) (8.69424249 26.435485 -1.07010507 -11.3639278 11.044849 13.478868 ) (13.146564 21.810989 9.9747448 2.11494064 -0.803623200 -11.210775 ) (22.719497 18.320545 9.1711216 -9.09583474 -1.83035755 7.36423016 ) (30.97544 12.906824 7.34076405 -1.73160457 2.12505627 -6.24614144 ) (39.37873 8.0521488 9.4658203 -7.977746 -6.6698742 -0.379662514 ) (45.509613 -0.115427330 2.79594612 -8.3574085 -17.445552 1.76478958 ) (39.582786 -7.59044076 -14.649606 -6.59261895 10.452091 -0.679496765 ) (30.159225 -14.522808 -4.19751454 -7.2721157 -6.3628168 6.95319844 ) (22.7803 -18.318321 -10.560331 -0.318916559 2.99917793 -3.13330078 ) (13.7195587 -20.203891 -7.5611534 -3.45221758 6.3660984 -6.4199934 ) (9.34145547 -26.866107 -1.19505500 -9.87221147 1.53642988 -25.186718 ) (8.91461564 -49.331672 0.341374993 -35.058929 -18.5118179 35.166854 ) (7.89556652E-5 -66.807174 -18.170444 0.107930347 18.510856 34.519271 ) (-8.91493608 -49.439598 0.340415239 34.627204 -1.53162884 -23.243984 ) (-9.34033395 -26.434387 -1.19121360 11.3832206 -6.38434506 -13.5433178 ) (-13.723722 -21.822826 -7.57555867 -2.1600976 -2.93098736 11.4172649 ) (-22.764774 -18.274292 -10.506546 9.2571678 6.10829259 -8.12574578 ) (-30.217174 -13.079996 -4.39825344 1.13142156 -9.5021801 9.08572198 ) (-39.366516 -7.40571404 -13.900434 10.217144 13.900434 -10.217144 )) NATURAL)) ((15 ((117 169) (117 139) (120 107) (126 75) (143 52) (165 38) (195 29) (220 28) (245 29) (275 38) (298 52) (314 75) (320 107) (323 139) (323 169)) NIL ((-0.787026048 -29.594802 0 0 4.72215653 -2.43117809 ) (1.57405233 -30.81039 4.72215653 -2.43117809 -5.61078453 0.155890941 ) (3.49081659 -33.16362 -0.888628126 -2.27528715 17.720981 13.807613 ) (11.4626827 -28.535102 16.832355 11.5323276 -17.2731628 -1.38635635 ) (19.658454 -17.695949 -0.440809131 10.145971 15.371683 -8.2621956 ) (26.903488 -11.6810779 14.9308757 1.88377571 -26.213573 10.435146 ) (28.727577 -4.57973004 -11.2826976 12.318922 11.482616 -15.478382 ) (23.186187 1.59256160E-7 0.199920326 -3.15946055 10.283096 15.47838 ) (28.527656 4.57973004 10.4830169 12.31892 -22.615001 -10.435144 ) (27.70317 11.6810779 -12.1319866 1.88377547 8.17691995 8.2621975 ) (19.659645 17.695953 -3.95506573 10.145973 -10.0926818 1.38635444 ) (10.658237 28.535102 -14.047748 11.5323276 14.193815 -13.807615 ) (3.70739698 33.16362 0.146066695 -2.27528763 -4.68258286 -0.155889988 ) (1.51217198 30.81039 -4.53651619 -2.43117761 4.53651619 2.43117761 )) NATURAL) (15 ((323 169) (323 199) (320 231) (314 263) (298 286) (275 300) (245 309) (220 310) (195 309) (165 300) (143 286) (126 263) (120 231) (117 199) (117 169)) NIL ((0.756085992 29.594802 0 0 -4.53651619 2.43117809 ) (-1.51217222 30.81039 -4.53651619 2.43117809 4.6825819 -0.155890941 ) (-3.70739698 33.16362 0.146066278 2.27528715 -14.193813 -13.807613 ) (-10.658239 28.535102 -14.047748 -11.5323276 10.0926818 1.38635635 ) (-19.659645 17.695949 -3.95506573 -10.145971 -8.17691995 8.2621956 ) (-27.70317 11.6810779 -12.1319866 -1.88377571 22.615001 -10.435146 ) (-28.527656 4.57973004 10.4830169 -12.318922 -10.283094 15.478382 ) (-23.186187 -1.59256160E-7 0.199920833 3.15946055 -11.48262 -15.47838 ) (-28.727577 -4.57973004 -11.2826995 -12.31892 26.213577 10.435144 ) (-26.903488 -11.6810779 14.930877 -1.88377547 -15.3716869 -8.2621975 ) (-19.658454 -17.695953 -0.440809786 -10.145973 17.273166 -1.38635444 ) (-11.4626808 -28.535102 16.832359 -11.5323276 -17.720985 13.807615 ) (-3.49081612 -33.16362 -0.888629199 2.27528763 5.61078549 0.155889988 ) (-1.57405209 -30.81039 4.72215653 2.43117761 -4.72215653 -2.43117761 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 61Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 11:58:51) (MADE-FROM gachan.cu 0 140 10 925) (SPLINES ((3 ((124 0) (124 0) (367 0)) NIL ((-60.75 0 0 0 364.5 0 ) (121.5 0 364.5 0 -364.5 0 )) NATURAL) (2 ((367 0) (367 36)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((367 36) (273 36)) NIL ((-94. 0 0 0 0 0 )) NATURAL) (2 ((273 36) (273 337)) NIL ((0 301. 0 0 0 0 )) NATURAL) (2 ((273 337) (210 337)) NIL ((-63. 0 0 0 0 0 )) NATURAL) (2 ((210 337) (78 246)) NIL ((-132. -91. 0 0 0 0 )) NATURAL) (2 ((78 246) (134 246)) NIL ((56. 0 0 0 0 0 )) NATURAL) (2 ((134 246) (220 303)) NIL ((86. 57. 0 0 0 0 )) NATURAL) (2 ((220 303) (220 36)) NIL ((0 -267. 0 0 0 0 )) NATURAL) (2 ((220 36) (124 36)) NIL ((-96. 0 0 0 0 0 )) NATURAL) (2 ((124 36) (124 0)) NIL ((0 -36. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 62Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:24:12) (MADE-FROM gachan.cu 0 140 10 925) (SPLINES ((3 ((367 0) (367 0) (73 0)) NIL ((73.5 0 0 0 -441. 0 ) (-147. 0 -441. 0 441. 0 )) NATURAL) (2 ((73 0) (73 50)) NIL ((0 50. 0 0 0 0 )) NATURAL) (17 ((73 50) (78 70) (90 89) (123 114) (152 134) (189 159) (230 186) (269 212) (303 239) (306 270) (290 291) (260 301) (216 305) (179 301) (155 293) (137 280) (130 264)) NIL ((4.74380017 20.817619 0 0 1.53719520 -4.90571976 ) (5.51239777 18.364757 1.53719520 -4.90571976 34.314018 18.528598 ) (24.206604 22.723339 35.851219 13.622879 -54.793289 -27.208679 ) (32.66117 22.741878 -18.942073 -13.5858 34.85916 24.306118 ) (31.148681 21.309139 15.917087 10.7203178 -12.643362 -10.0157985 ) (40.744087 27.021556 3.27372408 0.704518795 -8.28570748 -2.24291372 ) (39.874954 26.604618 -5.01198483 -1.53839493 9.78619767 0.987456680 ) (39.756073 25.559951 4.77421379 -0.550938249 -48.859077 10.293085 ) (20.100742 30.155559 -44.084869 9.74214746 29.650135 -24.159797 ) (-9.1590557 27.817802 -14.434732 -14.417652 2.25853729 2.34612083 ) (-22.464519 14.573211 -12.176195 -12.071531 -8.6842861 8.77531434 ) (-38.982856 6.8893385 -20.860481 -3.29621697 32.478599 -7.44738007 ) (-43.604034 -0.130568802 11.61812 -10.743597 4.7698803 9.014204 ) (-29.600975 -6.36706353 16.388 -1.729393 -15.558134 -4.60943508 ) (-20.992042 -10.4011745 0.829866291 -6.33882809 15.462663 3.42353535 ) (-12.430843 -15.028234 16.29253 -2.91529274 -16.29253 2.91529274 )) NATURAL) (2 ((130 264) (130 239)) NIL ((0 -25. 0 0 0 0 )) NATURAL) (2 ((130 239) (82 239)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((82 239) (82 269)) NIL ((0 30. 0 0 0 0 )) NATURAL) (20 ((82 269) (90 291) (105 308) (129 322) (159 331) (216 338) (273 332) (307 320) (331 305) (348 282) (354 247) (341 216) (312 189) (282 167) (246 143) (211 120) (181 101) (149 81) (131 65) (125 43)) NIL ((6.78662205 23.226146 0 0 7.2802677 -7.356884 ) (10.4267559 19.547702 7.2802677 -7.356884 5.5986595 6.78442288 ) (20.506351 15.58303 12.878927 -0.572460413 -17.6749038 -7.78081227 ) (24.547828 11.1201629 -4.79597855 -8.3532734 47.100959 12.3388309 ) (43.30233 8.936306 42.304985 3.9855585 -44.728965 -23.574516 ) (63.242828 1.13460397 -2.42398405 -19.588958 -30.185062 15.959251 ) (45.72631 -10.4747276 -32.609046 -3.62970686 27.469234 1.73749709 ) (26.851886 -13.235687 -5.1398096 -1.89220977 -1.69189834 -4.90924263 ) (20.866127 -17.582519 -6.83170796 -6.80145264 -2.70164585 -12.100521 ) (12.6835956 -30.434234 -9.5333538 -18.901973 -11.501516 29.311332 ) (-2.60051441 -34.680542 -21.03487 10.4093589 0.707698822 -9.14481927 ) (-23.281532 -28.843593 -20.327171 1.26453852 26.670726 7.2679472 ) (-30.273342 -23.945079 6.3435564 8.53248597 -17.390609 -13.926967 ) (-32.62509 -22.376079 -11.047054 -5.39448166 12.891712 6.4399252 ) (-37.226287 -24.550598 1.84465909 1.04544425 7.82375527 6.1672592 ) (-31.469749 -20.421524 9.66841508 7.2127037 -20.186737 -13.108963 ) (-31.894702 -19.763301 -10.5183239 -5.8962593 30.923206 16.2685928 ) (-26.951423 -17.5252609 20.404884 10.372335 -7.50610734 -21.965419 ) (-10.299591 -18.135635 12.898777 -11.593084 -12.898777 11.593084 )) NATURAL) (2 ((125 43) (367 43)) NIL ((242. 0 0 0 0 0 )) NATURAL) (2 ((367 43) (367 0)) NIL ((0 -43. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 63Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:24:51) (MADE-FROM gachan.cu 0 140 10 925) (SPLINES ((2 ((61 99) (111 99)) NIL ((50. 0 0 0 0 0 )) NATURAL) (16 ((111 99) (111 75) (126 51) (153 39) (188 35) (213 34) (238 35) (272 39) (299 48) (319 70) (323 97) (317 126) (304 143) (281 155) (251 161) (226 161)) NIL ((-3.35919046 -23.278705 0 0 20.155143 -4.32776165 ) (6.71838284 -25.442585 20.155143 -4.32776165 -10.775732 21.638805 ) (21.48566 -18.950939 9.3794117 17.311046 4.94778824 -10.2274837 ) (33.338966 -6.7536373 14.3271999 7.0835619 -33.01541 -4.72886086 ) (31.158458 -2.03450584 -18.688217 2.35470104 19.11388 -0.857067586 ) (22.027183 -0.108338594 0.425663412 1.49763345 16.559894 2.15713119 ) (30.732795 2.4678607 16.985561 3.65476465 -31.353477 -1.77145815 ) (32.041618 5.2368965 -14.367916 1.8833065 12.854017 16.928699 ) (24.100711 15.584554 -1.51389813 18.812007 -20.062587 -17.943359 ) (12.555519 25.42488 -21.576488 0.868646980 13.396343 6.8447523 ) (-2.32279682 29.715908 -8.18014527 7.71339989 2.47721863 -27.435646 ) (-9.2643337 23.711479 -5.70292664 -19.722248 -5.30521584 18.89785 ) (-17.619869 13.438158 -11.008142 -0.824397088 0.743648529 -6.1557617 ) (-28.256187 9.53587915 -10.2644939 -6.9801588 20.330616 -0.274801254 ) (-28.355373 2.4183197 10.0661239 -7.25496007 -10.0661239 7.25496007 )) NATURAL) (2 ((226 161) (166 161)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (3 ((166 161) (166 197) (166 197)) NIL ((0 45. 0 0 0 -54. ) (0 18. 0 -54. 0 54. )) NATURAL) (2 ((166 197) (216 197)) NIL ((50. 0 0 0 0 0 )) NATURAL) (15 ((216 197) (241 197) (269 204) (289 217) (298 235) (301 260) (290 283) (268 297) (232 303) (210 303) (187 303) (149 297) (133 286) (125 272) (125 252)) NIL ((23.819458 -1.50491333 0 0 7.08323479 9.02947999 ) (27.361076 3.00982666 7.08323479 9.02947999 -17.416175 -3.14740086 ) (25.736225 10.4656067 -10.332941 5.88207913 -3.4185276 -2.43987894 ) (13.694019 15.127746 -13.751468 3.44220018 13.090288 6.9069147 ) (6.48769475 22.023403 -0.661179662 10.349115 -18.9426269 -13.187776 ) (-3.64480162 25.778629 -19.603809 -2.83866167 14.6802387 -8.1558056 ) (-15.908493 18.862064 -4.92357064 -10.9944687 -21.778327 3.8110094 ) (-31.721229 9.7731018 -26.7019 -7.18345929 54.43308 -1.08823299 ) (-31.206584 2.0455246 27.731185 -8.27169229 -27.954029 12.541927 ) (-17.452415 0.0447963029 -0.222843975 4.27023506 -32.616958 -13.079483 ) (-33.983741 -2.22471094 -32.839805 -8.80924798 74.42189 3.77601147 ) (-29.612598 -9.1459522 41.582084 -5.0332365 -43.07064 3.97543287 ) (-9.56583596 -12.191473 -1.48855781 -1.05780363 13.8606968 -7.6777439 ) (-4.12404633 -17.08815 12.3721389 -8.735548 -12.3721389 8.735548 )) NATURAL) (2 ((125 252) (82 252)) NIL ((-43. 0 0 0 0 0 )) NATURAL) (2 ((82 252) (82 277)) NIL ((0 25. 0 0 0 0 )) NATURAL) (15 ((82 277) (91 294) (108 310) (132 323) (163 332) (213 337) (259 333) (295 323) (321 307) (339 284) (346 254) (342 230) (331 210) (312 190) (294 179)) NIL ((7.3249216 17.1195678 0 0 10.0504665 -0.717417956 ) (12.3501548 16.76086 10.0504665 -0.717417956 -2.25233459 -2.41290998 ) (21.274452 14.836986 7.79813195 -3.13032818 -7.04112816 -1.63093948 ) (25.55202 10.8911876 0.757003189 -4.76126766 30.41685 2.93666792 ) (41.517448 7.59825516 31.173854 -1.8245995 -42.626266 -10.115734 ) (51.378166 0.715788484 -11.452417 -11.940334 2.08823204 7.5262718 ) (40.969863 -7.4614105 -9.36418534 -4.4140625 -1.72665214 -1.98934936 ) (30.742355 -12.8701477 -11.090837 -6.40341187 4.81837368 0.431121826 ) (22.060703 -19.057998 -6.2724638 -5.97229004 -5.5468378 -5.73513413 ) (13.014822 -27.897853 -11.8193016 -11.707424 -0.631027222 22.50941 ) (0.880005479 -28.35057 -12.4503288 10.8019886 8.07095338 -6.3025217 ) (-7.53484727 -20.699844 -4.37937546 4.4994669 -7.65279008 -9.29932405 ) (-15.740617 -20.85004 -12.032165 -4.79985714 16.5402069 19.499816 ) (-19.502677 -15.899986 4.50804138 14.699962 -4.50804138 -14.699962 )) NATURAL) (15 ((294 179) (331 161) (354 138) (364 115) (367 90) (360 61) (339 32) (316 16) (279 3) (216 -2) (159 1) (117 12) (90 28) (72 50) (63 71)) NIL ((39.920318 -16.637714 0 0 -17.5219269 -8.17371179 ) (31.159355 -20.724571 -17.5219269 -8.17371179 3.60964584 10.8685646 ) (15.442251 -23.464 -13.912281 2.6948533 9.08333589 -5.30055332 ) (6.07163716 -23.419422 -4.82894516 -2.60570001 -3.94299126 -1.66635275 ) (-0.728803635 -26.858299 -8.7719364 -4.27205277 -11.3113689 -0.0340318680 ) (-15.156425 -31.147369 -20.083305 -4.30608464 25.188472 25.802475 ) (-22.645492 -22.552211 5.10516835 21.496391 -17.442531 -25.17588 ) (-26.261592 -13.643764 -12.337366 -3.679492 -27.41833 14.9010658 ) (-52.308128 -9.8727226 -39.755699 11.2215747 55.115875 -4.42838192 ) (-64.505874 -0.865339280 15.360178 6.79319287 -1.04520416 2.81245708 ) (-49.668304 7.3340826 14.3149738 9.60564996 3.0649395 -6.82144929 ) (-33.820861 13.5290088 17.379913 2.78420067 -11.2145576 6.4733448 ) (-22.048225 19.549881 6.16535569 9.25754548 5.79330445 -13.0719318 ) (-12.986219 22.271461 11.95866 -3.81438637 -11.95866 3.81438637 )) NATURAL) (2 ((63 71) (61 99)) NIL ((-2. 28. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 64Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:27:37) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((2 ((287 0) (334 0)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((334 0) (334 84)) NIL ((0 84. 0 0 0 0 )) NATURAL) (2 ((334 84) (388 84)) NIL ((54. 0 0 0 0 0 )) NATURAL) (2 ((388 84) (388 127)) NIL ((0 43. 0 0 0 0 )) NATURAL) (2 ((388 127) (334 127)) NIL ((-54. 0 0 0 0 0 )) NATURAL) (2 ((334 127) (334 337)) NIL ((0 210. 0 0 0 0 )) NATURAL) (2 ((334 337) (287 337)) NIL ((-47. 0 0 0 0 0 )) NATURAL) (2 ((287 337) (61 112)) NIL ((-226. -225. 0 0 0 0 )) NATURAL) (2 ((61 112) (61 84)) NIL ((0 -28. 0 0 0 0 )) NATURAL) (2 ((61 84) (287 84)) NIL ((226. 0 0 0 0 0 )) NATURAL) (2 ((287 84) (287 0)) NIL ((0 -84. 0 0 0 0 )) NATURAL)) ((2 ((287 127) (132 127)) NIL ((-155. 0 0 0 0 0 )) NATURAL) (2 ((132 127) (287 285)) NIL ((155. 158. 0 0 0 0 )) NATURAL) (2 ((287 285) (287 127)) NIL ((0 -158. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 65Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:33:57) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((2 ((63 99) (113 99)) NIL ((50. 0 0 0 0 0 )) NATURAL) (11 ((113 99) (117 71) (128 55) (149 41) (187 33) (212 31) (238 32) (276 39) (300 56) (317 84) (322 112)) NIL ((2.45260906 -31.158916 0 0 9.2843437 18.953514 ) (7.09478188 -21.682159 9.2843437 18.953514 -4.42172432 -22.76757 ) (14.168264 -14.112432 4.8626194 -3.81405783 26.402553 12.1167736 ) (32.232162 -11.868103 31.265174 8.3027172 -59.188507 -1.69952965 ) (33.903076 -4.41515064 -27.923336 6.60318757 30.351509 -5.31865692 ) (21.155502 -0.471291602 2.42817497 1.28452992 21.782455 4.97415924 ) (34.474899 3.30031872 24.210632 6.25868989 -51.48133 3.42201805 ) (32.944862 11.2700176 -27.270702 9.6807079 28.14289 5.33776856 ) (19.745609 23.619609 0.872188688 15.018476 -19.090236 -18.773094 ) (11.072681 29.251537 -18.218048 -3.7546196 18.218048 3.7546196 )) NATURAL) (12 ((322 112) (319 136) (310 159) (298 174) (278 186) (250 191) (229 192) (203 191) (167 185) (146 173) (134 159) (125 141)) NIL ((-1.50521779 23.720333 0 0 -8.96869279 1.67799902 ) (-5.9895649 24.55933 -8.96869279 1.67799902 8.8434677 -14.389993 ) (-10.5365219 19.042331 -0.125223279 -12.711996 -8.4051876 13.8819828 ) (-14.8643398 13.2713279 -8.53041268 1.16998744 -5.22271347 -11.137939 ) (-26.00611 8.87234689 -13.753126 -9.9679527 29.296043 6.669775 ) (-25.111213 2.23928118 15.542919 -3.29817772 -21.961471 2.45884323 ) (-20.54903 0.170525491 -6.4185524 -0.839334369 -13.450157 -4.50514984 ) (-33.692657 -2.92138386 -19.868709 -5.34448433 45.762107 -2.43824291 ) (-30.680313 -9.48498918 25.893402 -7.78272725 -19.598308 8.2581215 ) (-14.586067 -13.138656 6.29509164 0.475394309 -3.36886454 -6.59424306 ) (-9.97540856 -15.960382 2.92622709 -6.1188488 -2.92622709 6.1188488 )) NATURAL) (3 ((125 141) (73 141) (73 141)) NIL ((-65. 0 0 0 78. 0 ) (-26. 0 78. 0 -78. 0 )) NATURAL) (2 ((73 141) (108 337)) NIL ((35. 196. 0 0 0 0 )) NATURAL) (2 ((108 337) (334 337)) NIL ((226. 0 0 0 0 0 )) NATURAL) (2 ((334 337) (334 295)) NIL ((0 -42. 0 0 0 0 )) NATURAL) (2 ((334 295) (153 295)) NIL ((-181. 0 0 0 0 0 )) NATURAL) (2 ((153 295) (137 202)) NIL ((-16. -93. 0 0 0 0 )) NATURAL) (22 ((137 202) (170 217) (202 224) (237 227) (280 222) (312 211) (337 193) (352 175) (363 153) (367 122) (363 86) (351 57) (325 29) (295 12) (259 2) (208 -2) (160 4) (120 17) (94 34) (76 54) (67 73) (63 99)) NIL ((33.278953 16.989254 0 0 -1.6737628 -11.935539 ) (32.442077 11.021486 -1.6737628 -11.935539 2.36881447 11.677698 ) (31.95272 4.9247961 0.695052028 -0.257840454 16.198501 -10.775257 ) (40.747024 -0.720674277 16.893554 -11.033098 -37.162834 7.42333985 ) (39.059166 -8.0421009 -20.269279 -3.6097579 18.4528389 -6.9181099 ) (28.016304 -15.110916 -1.816437 -10.527868 -12.6485328 14.249101 ) (19.875598 -18.514232 -14.464971 3.72123432 14.141298 -8.07830239 ) (12.481279 -18.832149 -0.323671937 -4.35706902 -7.91666699 -5.9358902 ) (8.19927407 -26.157165 -8.24033929 -10.292959 -0.474626541 1.82187271 ) (-0.278379440 -35.539184 -8.7149658 -8.4710865 3.8151741 22.648395 ) (-7.0857582 -32.686073 -4.89979172 14.1773109 -14.786075 -20.415466 ) (-19.378585 -28.716499 -19.685867 -6.2381563 19.329124 23.013469 ) (-29.39989 -23.447917 -0.356739759 16.775314 -2.53043222 -11.6384296 ) (-31.021846 -12.491817 -2.88717222 5.13688374 -21.207397 -0.459736824 ) (-44.512718 -7.58480263 -24.09457 4.6771469 33.36003 7.47737885 ) (-51.927269 0.831033350 9.26546289 12.1545257 -4.23274899 -5.4497776 ) (-44.778183 10.2606697 5.03271389 6.70474816 13.570957 -3.67826986 ) (-32.959983 15.126283 18.603672 3.02647829 -14.051084 2.16285753 ) (-21.381855 19.234191 4.55258656 5.18933583 6.63338948 -10.9731578 ) (-13.512575 18.936946 11.185976 -5.783823 -6.4824705 17.729778 ) (-5.56783486 22.018013 4.7035055 11.945955 -4.7035055 -11.945955 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 66Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:40:25) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((11 ((314 260) (306 281) (287 297) (251 308) (210 307) (174 303) (144 291) (125 271) (117 255) (113 235) (110 192)) NIL ((-6.15634823 22.203887 0 0 -11.0619106 -7.2233467 ) (-11.687303 18.592216 -11.0619106 -7.2233467 -10.6904468 6.11673546 ) (-28.094436 14.427236 -21.752357 -1.10661101 17.823703 -17.243595 ) (-40.934944 4.6988287 -3.92865229 -18.350208 11.39562 20.857646 ) (-39.165779 -3.2225542 7.4669695 2.50744152 -3.40619659 -12.186998 ) (-33.401908 -6.80861188 4.0607729 -9.6795578 8.2291622 -2.10965156 ) (-25.226558 -17.542995 12.289936 -11.789209 0.489543915 20.625602 ) (-12.6918487 -19.019401 12.7794799 8.83639527 -10.1873417 -8.39276696 ) (-5.00603962 -14.3793907 2.59213829 0.443627298 -1.74017286 -35.054527 ) (-3.283988 -31.463031 0.851965309 -34.6109 -0.851965309 34.6109 )) NATURAL) (33 ((110 192) (143 210) (181 220) (232 225) (279 222) (310 213) (337 199) (357 180) (370 153) (376 124) (373 91) (363 60) (334 29) (289 8) (226 -1) (174 6) (135 20) (105 40) (87 60) (70 98) (64 164) (69 221) (76 252) (91 283) (111 306) (139 323) (177 335) (235 338) (279 333) (309 323) (331 309) (351 286) (357 260)) NIL ((32.591583 19.91341 0 0 2.45046902 -11.480478 ) (33.816818 14.173172 2.45046902 -11.480478 17.7476539 9.40239717 ) (45.141113 7.39389229 20.198123 -2.07808113 -25.441089 -8.12911416 ) (52.61869 1.25125384 -5.24296665 -10.207195 -17.983284 5.1140623 ) (38.384079 -6.39890957 -23.226253 -5.09313298 25.374244 -0.327138901 ) (27.844951 -11.6556129 2.14799404 -5.42027188 -11.5137119 2.19449425 ) (24.236091 -15.978637 -9.36571885 -3.22577763 2.68060589 -8.45083619 ) (16.210674 -23.429832 -6.68511296 -11.6766147 0.791287423 13.608858 ) (9.9212036 -28.30202 -5.89382553 1.93224478 -5.8457508 -9.9846058 ) (1.10450172 -31.362079 -11.739576 -8.05236245 10.5917167 14.3295707 ) (-5.33921623 -32.249656 -1.14785862 6.27720929 -24.521122 -11.333683 ) (-18.747634 -31.639289 -25.668983 -5.05647373 15.4927768 19.005157 ) (-36.670234 -27.19318 -10.1762066 13.948686 -19.449962 -4.68696213 ) (-56.571426 -15.587976 -29.62617 9.26172448 50.307067 11.742685 ) (-61.044059 -0.454907894 20.6809 21.004409 -7.77833939 -18.283779 ) (-44.252327 11.4076118 12.902561 2.72062778 -7.19371319 7.39244557 ) (-34.946617 17.824459 5.708848 10.113073 12.55319 -17.285995 ) (-22.961177 19.294536 18.262039 -7.17292214 -25.019046 25.751537 ) (-17.20866 24.997383 -6.7570076 18.578617 21.522995 22.279834 ) (-13.20417 54.71591 14.765987 40.85845 -1.07293892 -54.870864 ) (1.02534771 68.13893 13.693048 -14.0124149 -17.231231 -24.796375 ) (6.10277939 41.728324 -3.53818369 -38.808792 15.997869 52.056388 ) (10.5635299 28.94773 12.459686 13.2476 -10.760248 -27.429206 ) (17.643093 28.480728 1.69943738 -14.181606 9.04312516 9.6604328 ) (23.864093 19.129337 10.742563 -4.52117348 -7.412261 0.787478924 ) (30.900527 15.001905 3.33030224 -3.73369455 32.605918 -6.81034947 ) (50.53379 7.86303425 35.936225 -10.544044 -63.011444 2.45392418 ) (54.964294 -1.45404815 -27.075222 -8.0901203 15.439876 2.99464989 ) (35.609008 -8.04684258 -11.635345 -5.09547043 1.25195694 3.56747198 ) (24.599643 -11.3585777 -10.3833885 -1.52799845 15.5522918 -11.264534 ) (21.992401 -18.51884 5.16890335 -12.7925338 -27.461128 11.490667 ) (13.43074 -25.566043 -22.292224 -1.30186629 22.292224 1.30186629 )) NATURAL) (2 ((357 260) (314 260)) NIL ((-43. 0 0 0 0 0 )) NATURAL)) ((21 ((113 119) (121 149) (140 172) (164 185) (208 192) (228 194) (248 192) (291 185) (314 170) (327 147) (333 117) (330 86) (315 57) (290 40) (249 33) (229 31) (209 33) (163 42) (134 61) (119 84) (113 119)) NIL ((4.91333866 31.251632 0 0 18.519966 -7.5098009 ) (14.173322 27.49673 18.519966 -7.5098009 -26.599842 -4.45099545 ) (19.393367 17.761432 -8.07987596 -11.960796 51.879409 7.3137846 ) (37.253196 9.45752908 43.799537 -4.64701176 -90.917816 -0.804142953 ) (35.593818 4.4084463 -47.118286 -5.4511547 47.791908 1.90278578 ) (12.371492 -0.0913158953 0.673623085 -3.54836893 43.750167 -0.806997777 ) (34.920204 -4.04318428 44.423797 -4.3553667 -84.792617 -4.6747942 ) (36.947685 -10.7359466 -40.36882 -9.0301609 37.420303 1.50617122 ) (15.289024 -19.013023 -2.94851398 -7.52398968 -4.88860703 -1.34988689 ) (9.8962059 -27.211956 -7.837121 -8.87387658 0.134121895 9.8933773 ) (2.12614632 -31.139144 -7.7029991 1.01950121 -7.64788056 -2.22362852 ) (-9.40079309 -31.231456 -15.350879 -1.20412731 12.457403 17.0011329 ) (-18.522972 -23.935016 -2.893476 15.797006 -30.181732 -5.78090859 ) (-36.507316 -11.028463 -33.07521 10.016098 72.26953 -5.87750626 ) (-33.44776 -3.95111895 39.19432 4.13859177 -36.896385 -0.709060669 ) (-12.701635 -0.167057514 2.29793119 3.4295311 -50.683975 2.71375179 ) (-35.745689 4.61934948 -48.386047 6.1432829 83.632309 7.85405255 ) (-42.315582 14.689657 35.24626 13.997335 -25.845264 -16.129955 ) (-19.991954 20.622013 9.40099526 -2.13262224 1.7487545 20.665775 ) (-9.71658326 28.82228 11.1497497 18.533153 -11.1497497 -18.533153 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 67Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:42:36) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((3 ((82 337) (82 337) (82 295)) NIL ((0 10.5 0 0 0 -63. ) (0 -21. 0 -63. 0 63. )) NATURAL) (2 ((82 295) (317 295)) NIL ((235. 0 0 0 0 0 )) NATURAL) (2 ((317 295) (140 0)) NIL ((-177. -295. 0 0 0 0 )) NATURAL) (2 ((140 0) (207 0)) NIL ((67. 0 0 0 0 0 )) NATURAL) (2 ((207 0) (367 307)) NIL ((160. 307. 0 0 0 0 )) NATURAL) (2 ((367 307) (367 337)) NIL ((0 30. 0 0 0 0 )) NATURAL) (2 ((367 337) (82 337)) NIL ((-285. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 70Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:49:46) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((19 ((291 180) (315 191) (336 207) (351 232) (354 260) (345 290) (324 313) (298 326) (259 336) (219 340) (178 336) (139 326) (114 313) (93 290) (84 260) (87 232) (102 207) (123 191) (147 180)) NIL ((24.558052 10.265171 0 0 -3.34833002 4.4089651 ) (22.883888 12.469654 -3.34833002 4.4089651 -1.25834989 7.95517254 ) (18.906383 20.856205 -4.60667992 12.3641376 -9.61826898 -12.229656 ) (9.49056817 27.105514 -14.2249489 0.134480089 3.73142815 4.96345997 ) (-2.86866617 29.721725 -10.4935207 5.09794045 -5.3074398 -13.624183 ) (-16.015907 28.007572 -15.80096 -8.5262432 17.498333 -4.46672058 ) (-23.067699 17.247966 1.69737339 -12.9929638 -22.685901 13.4910698 ) (-32.713279 11.0005397 -20.988529 0.498106360 25.245277 -7.49756528 ) (-41.07917 7.74986458 4.25675106 -6.99945927 -6.2952261 -1.50080967 ) (-39.97003 -4.76837158E-7 -2.03847551 -8.50026895 -0.0643725395 1.50080967 ) (-42.040695 -7.74986458 -2.10284805 -6.99945927 24.552715 7.49756528 ) (-31.867183 -11.0005397 22.449867 0.498106659 -26.146499 -13.4910717 ) (-22.490562 -17.24797 -3.69663239 -12.9929657 20.03329 4.46672249 ) (-16.170547 -28.007572 16.336658 -8.5262432 -5.98667336 13.624183 ) (-2.82722759 -29.721725 10.349985 5.09794045 3.91341019 -4.96346092 ) (9.47946359 -27.105514 14.263395 0.134479522 -9.6669674 12.22966 ) (18.909374 -20.856205 4.59642697 12.364139 -1.24553394 -7.9551754 ) (22.883033 -12.469654 3.35089302 4.40896416 -3.35089302 -4.40896416 )) NATURAL) (21 ((147 180) (117 170) (87 154) (69 134) (60 100) (67 60) (88 34) (114 18) (139 9) (169 2) (219 -2) (268 2) (298 9) (324 18) (349 34) (370 60) (378 100) (369 134) (351 154) (321 170) (291 180)) NIL ((-29.24649 -8.45737458 0 0 -4.52104187 -9.25575067 ) (-31.50701 -13.0852489 -4.52104187 -9.25575067 22.605209 10.278753 ) (-24.725448 -17.201622 18.084167 1.02300405 -13.899799 -19.859268 ) (-13.5911808 -26.108253 4.18436814 -18.836265 14.993984 9.15831948 ) (-1.90981889 -40.365356 19.178352 -9.6779461 -4.07614327 31.225994 ) (15.230461 -34.430305 15.102209 21.548049 -10.6893997 -14.062305 ) (24.987968 -19.91341 4.41280842 7.4857435 -7.16625214 1.02323055 ) (25.817649 -11.9160499 -2.75344372 8.50897409 3.3544116 -8.03062058 ) (24.741413 -7.42238618 0.600968123 0.478352726 29.7486 1.09926128 ) (40.216682 -6.3944025 30.34957 1.57761407 -32.348823 9.63357545 ) (54.391838 7.15255737E-7 -1.99925756 11.211191 -26.353275 -9.63357736 ) (39.215942 6.3944025 -28.352535 1.57761335 29.761928 -1.09926057 ) (25.744373 7.42238618 1.40939593 0.478352666 -2.69444275 8.03062058 ) (25.806549 11.9160499 -1.28504705 8.50897409 -0.984160424 -1.02323150 ) (24.029418 19.91341 -2.26920748 7.48574258 -11.3689117 14.062307 ) (16.075756 34.430305 -13.63812 21.548049 -7.5401821 -31.225994 ) (-1.3324542 40.365356 -21.178302 -9.6779461 17.529632 -9.15831567 ) (-13.745939 26.108249 -3.64866877 -18.836261 -14.57835 19.859264 ) (-24.683784 17.201622 -18.22702 1.02300405 22.783775 -10.278753 ) (-31.518917 13.0852489 4.55675507 -9.25575067 -4.55675507 9.25575067 )) NATURAL)) ((9 ((131 253) (135 224) (156 204) (194 196) (221 194) (244 196) (281 204) (302 224) (307 253)) NIL ((0.832658768 -30.649482 0 0 19.004047 9.8969059 ) (10.334684 -25.701026 19.004047 9.8969059 6.97975159 4.51546479 ) (32.828605 -13.54639 25.983799 14.41237 -46.923042 -9.9587631 ) (35.350875 -4.1134014 -20.939247 4.45360756 12.712442 -0.680411816 ) (20.767856 1.59256160E-7 -8.22680474 3.77319574 38.073265 0.680411816 ) (31.577686 4.11340237 29.846466 4.45360756 -57.005523 9.9587612 ) (32.921386 13.546392 -27.159057 14.4123687 9.94882585 -4.51546097 ) (10.7367439 25.70103 -17.210231 9.8969078 17.210231 -9.8969078 )) NATURAL) (9 ((307 253) (298 283) (274 300) (244 307) (221 309) (194 307) (164 300) (140 283) (131 253)) NIL ((-5.5618553 32.845359 0 0 -20.628864 -17.072162 ) (-15.876289 24.309276 -20.628864 -17.072162 13.144329 7.36082268 ) (-29.932987 10.917524 -7.4845352 -9.71133996 22.051544 5.6288662 ) (-26.39175 4.02061749 14.5670089 -4.08247376 -23.350509 0.123711586 ) (-23.5 -3.18512320E-7 -8.78350259 -3.95876217 5.3505125 -0.123711586 ) (-29.608245 -4.02061844 -3.4329896 -4.08247376 7.94845296 -5.6288662 ) (-29.067009 -10.917526 4.51546383 -9.71133996 16.855667 -7.36082268 ) (-16.12371 -24.309276 21.371131 -17.072162 -21.371131 17.072162 )) NATURAL)) ((11 ((105 98) (113 128) (132 147) (155 158) (194 164) (220 165) (244 164) (283 158) (305 147) (325 128) (332 98)) NIL ((4.97496033 32.444747 0 0 18.150238 -14.668506 ) (14.050081 25.110496 18.150238 -14.668506 -24.751201 7.34253979 ) (19.824714 14.113258 -6.6009655 -7.32596684 38.854583 3.2983427 ) (32.651046 8.4364624 32.253624 -4.02762413 -58.667167 -2.53591156 ) (35.571083 3.14088345 -26.413543 -6.5635357 21.814094 6.84530354 ) (20.06459 -7.96280801E-8 -4.59944725 0.281768083 37.410774 -6.84530354 ) (34.170532 -3.14088392 32.811332 -6.5635357 -69.457214 2.53591251 ) (32.25325 -8.4364643 -36.645889 -4.02762318 48.41812 -3.2983427 ) (19.816429 -14.113258 11.7722377 -7.32596589 -34.215293 -7.34254265 ) (14.481018 -25.110496 -22.443058 -14.668508 22.443058 14.668508 )) NATURAL) (11 ((332 98) (326 69) (302 47) (275 36) (244 31) (220 29) (194 31) (162 36) (135 47) (111 69) (105 98)) NIL ((-1.27926373 -30.190605 0 0 -28.324417 7.14364625 ) (-15.441473 -26.618782 -28.324417 7.14364625 33.622093 6.2817669 ) (-26.954841 -16.334251 5.29768086 13.425413 -16.163986 -8.2707176 ) (-29.739154 -7.04419804 -10.866306 5.1546955 25.033847 -3.19889402 ) (-28.088535 -3.48895025 14.167543 1.95580148 -17.971408 3.06629705 ) (-22.906696 3.18512320E-7 -3.80386734 5.02209854 -7.1482048 -3.06629753 ) (-30.284668 3.48895025 -10.952072 1.95580101 22.564231 3.19889545 ) (-29.954624 7.044199 11.6121616 5.15469647 -17.1087379 8.2707157 ) (-26.896831 16.334251 -5.4965763 13.425413 33.870712 -6.2817669 ) (-15.4580459 26.618782 28.374141 7.14364625 -28.374141 -7.14364625 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 71Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 12:58:42) (MADE-FROM gachan.cu 0 140 0 0) (SPLINES ((2 ((118 77) (75 77)) NIL ((-43. 0 0 0 0 0 )) NATURAL) (32 ((75 77) (81 51) (100 28) (123 14) (153 4) (196 -1) (255 2) (294 13) (321 31) (340 54) (355 85) (363 116) (367 173) (364 239) (351 277) (333 297) (303 317) (264 331) (205 338) (142 329) (97 308) (67 277) (55 246) (54 213) (60 184) (75 157) (109 130) (153 115) (199 112) (260 118) (302 131) (322 145)) NIL ((2.70768738 -26.21757 0 0 19.753875 1.30543661 ) (12.584625 -25.564853 19.753875 1.30543661 -20.769386 11.472816 ) (21.953807 -18.523006 -1.01551056 12.778253 9.32367517 -11.1967029 ) (25.600135 -11.343107 8.3081646 1.58154917 1.47467994 3.31399965 ) (34.645637 -8.10455705 9.78284455 4.89554882 20.77761 3.94070339 ) (54.81729 -1.23865676 30.560455 8.8362522 -66.585128 -1.07681560 ) (52.085174 7.0591879 -36.024673 7.7594366 29.562927 0.366560936 ) (30.841968 15.001905 -6.46174336 8.12599755 -3.66660023 -6.3894329 ) (22.546924 19.933185 -10.1283435 1.73656463 9.1034622 13.191175 ) (16.970314 28.265338 -1.02488088 14.92774 -8.7472496 -28.375263 ) (11.5718078 29.005447 -9.77213098 -13.447525 7.88553906 52.309883 ) (5.7424469 41.712867 -1.88659143 38.862358 -4.79491043 -24.864299 ) (1.45840072 68.143066 -6.68150235 13.998058 -6.70589734 -54.852653 ) (-8.5760498 54.714805 -13.3873996 -40.854599 13.6184997 22.274959 ) (-15.154197 24.997684 0.231101900 -18.579639 -17.768104 25.752807 ) (-23.807151 19.294448 -17.537006 7.17316819 15.4539318 -17.286197 ) (-33.617187 17.824516 -2.08307314 -10.113031 -26.047618 7.3919878 ) (-48.724075 11.407478 -28.130695 -2.72104311 22.736557 -18.2817459 ) (-65.48648 -0.454440713 -5.39413643 -21.002792 31.101375 11.7350216 ) (-55.329933 -15.589721 25.70724 -9.26777078 -15.14208 -4.65834809 ) (-37.193733 -27.186668 10.5651607 -13.9261188 11.466947 18.898368 ) (-20.895099 -31.6636 22.032108 4.97225094 -12.725717 -10.9351349 ) (-5.2258501 -32.158912 9.30639077 -5.9628849 -2.5640707 12.842174 ) (2.7985053 -31.700714 6.74232007 6.87928963 -1.01799202 -4.43356228 ) (9.03182984 -27.038208 5.72432804 2.44572735 18.636032 -7.1079273 ) (24.074176 -28.146442 24.360363 -4.66219998 -13.526155 20.865268 ) (41.671463 -22.376003 10.8342075 16.203071 -18.53141 -4.35317803 ) (43.239959 -8.34952165 -7.69720364 11.849893 39.651802 -3.45254517 ) (55.368667 1.77409935 31.954605 8.3973484 -62.075828 0.163358688 ) (56.285354 10.253126 -30.121227 8.5607071 4.65153504 -9.20088388 ) (28.489894 14.213392 -25.469692 -0.640176893 25.469692 0.640176893 )) NATURAL) (12 ((322 145) (319 102) (314 82) (307 66) (287 46) (262 36) (226 33) (196 33) (162 36) (141 44) (126 58) (118 77)) NIL ((-2.36525059 -48.755897 0 0 -3.80849552 34.535408 ) (-4.26949787 -31.488193 -3.80849552 34.535408 7.0424776 -34.67704 ) (-4.55675507 -14.291311 3.23398209 -0.141639173 -24.361415 -9.8272133 ) (-13.5034828 -19.346557 -21.127433 -9.968853 24.403202 25.985908 ) (-22.429313 -16.322452 3.27577066 16.017055 -25.251411 -10.1164398 ) (-31.77925 -5.36361695 -21.975643 5.90061569 40.602447 -3.52014017 ) (-33.453666 -1.22307181 18.626808 2.38047552 -35.158393 0.197004795 ) (-32.406059 1.25590610 -16.531585 2.57748031 40.031112 2.73212242 ) (-28.922084 5.19944763 23.49953 5.30960274 -22.966072 0.874502183 ) (-16.90559 10.946302 0.533458472 6.1841049 9.83317567 -0.230131149 ) (-11.455543 17.0153389 10.366634 5.95397377 -10.366634 -5.95397377 )) NATURAL)) ((11 ((323 220) (316 188) (295 164) (268 150) (226 145) (202 143) (179 145) (138 152) (115 166) (99 190) (93 220)) NIL ((-3.30784607 -33.58744 0 0 -22.152923 9.52467538 ) (-14.3843078 -28.825103 -22.152923 9.52467538 26.764621 0.376617432 ) (-23.154918 -19.112121 4.61169815 9.9012928 -36.905563 0.968858719 ) (-36.996009 -8.72639848 -32.293869 10.870151 66.857666 -10.252054 ) (-35.861038 -2.98227548 34.563797 0.618097306 -32.525123 4.039361 ) (-17.559806 -0.344497323 2.03867292 4.6574583 -38.757156 0.0946092606 ) (-34.899719 4.36026573 -36.71849 4.75206757 73.553787 1.58220005 ) (-34.841308 9.90343286 36.835304 6.3342676 -39.458053 5.57659245 ) (-17.735031 19.025997 -2.62274933 11.91086 18.278434 -5.88857556 ) (-11.218561 27.992569 15.655687 6.0222845 -15.655687 -6.0222845 )) NATURAL) (11 ((93 220) (95 251) (111 280) (140 297) (180 307) (204 308) (227 306) (274 295) (302 276) (317 253) (323 220)) NIL ((-1.10016107 30.764175 0 0 18.600967 1.4149456 ) (8.2003212 31.471645 18.600967 1.4149456 -9.00483705 -19.074726 ) (22.29887 23.349227 9.59613038 -17.659782 11.4183807 14.883974 ) (37.604187 13.131431 21.014511 -2.7758069 -48.668686 -10.4611778 ) (34.284355 5.12503529 -27.654178 -13.236986 21.256389 14.9607429 ) (17.258373 -0.631578923 -6.39778805 1.72375726 53.64311 -13.3817978 ) (37.68215 -5.59872055 47.24533 -11.658041 -85.8289 2.5664463 ) (42.01303 -15.973539 -38.583572 -9.0915947 31.672523 9.1160202 ) (19.26572 -20.507122 -6.91104603 0.0244256891 -4.86119175 -15.0305309 ) (9.924078 -27.997962 -11.7722377 -15.006105 11.7722377 15.006105 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/GACHAE.S1-SF b/obsolete/lispusers/splinefonts/GACHAE.S1-SF deleted file mode 100644 index 8a13afa8..00000000 --- a/obsolete/lispusers/splinefonts/GACHAE.S1-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY gacha) (CHARACTER 40Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 13-SEP-77 15:50:28) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES)) ((FAMILY gacha) (CHARACTER 30Q) (FACE M R E) (WIDTH 0 0) (FIDUCIAL 480 480) (VERSION 0 13-SEP-77 15:52:00) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((3 ((0 -112) (0 -112) (441 -112)) NIL ((-110.25 0 0 0 661.5 0 ) (220.5 0 661.5 0 -661.5 0 )) NATURAL) (2 ((441 -112) (441 -76)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((441 -76) (0 -76)) NIL ((-441. 0 0 0 0 0 )) NATURAL) (2 ((0 -76) (0 -112)) NIL ((0 -36. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 41Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 13:12:55) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((13 ((219 -4) (231 -3) (251 9) (261 29) (251 49) (231 61) (219 62) (207 61) (187 49) (177 29) (187 9) (207 -3) (219 -4)) NIL ((9.72938157 0.167401611 -0.927834511 -5.42605019 16.407211 21.273738 ) (17.005153 5.3782215 15.479379 15.84769 -28.469066 -7.81240464 ) (18.249996 17.319709 -12.9896869 8.03528596 -10.530931 -8.02412416 ) (-0.00515493005 21.342933 -23.520618 0.0111602712 10.5927848 -8.09108735 ) (-18.229381 17.3085479 -12.927833 -8.07992745 28.15979 -7.61152077 ) (-17.077316 5.42286206 15.231958 -15.691448 -15.231958 20.53717 ) (-9.46133996 0 -5.11072471E-7 4.8457241 -15.231954 -20.53717 ) (-17.07732 -5.42286206 -15.231956 -15.691448 28.15979 7.61152077 ) (-18.229377 -17.3085479 12.927833 -8.07992745 10.592781 8.09108735 ) (-0.00515333563 -21.342933 23.520614 0.0111602917 -10.5309238 8.02412416 ) (18.25 -17.319709 12.9896908 8.03528596 -28.46907 7.81240464 ) (17.005153 -5.3782215 -15.479381 15.84769 16.407215 -21.273738 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 42Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 13:18:48) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((8 ((137 197) (130 223) (122 248) (115 273) (112 296) (114 313) (126 331) (147 338)) NIL ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 ) (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 ) (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 ) (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 ) (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 ) (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 ) (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 )) NATURAL) (8 ((147 338) (168 331) (180 313) (182 296) (179 273) (172 248) (164 223) (157 197)) NIL ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 ) (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 ) (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 ) (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 ) (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 ) (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 ) (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 )) NATURAL) (2 ((157 197) (137 197)) NIL ((-20. 0 0 0 0 0 )) NATURAL)) ((2 ((302 197) (282 197)) NIL ((-20. 0 0 0 0 0 )) NATURAL) (8 ((282 197) (275 223) (267 248) (260 273) (257 296) (259 313) (271 331) (292 338)) NIL ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 ) (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 ) (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 ) (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 ) (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 ) (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 ) (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 )) NATURAL) (8 ((292 338) (313 331) (325 313) (327 296) (324 273) (317 248) (309 223) (302 197)) NIL ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 ) (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 ) (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 ) (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 ) (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 ) (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 ) (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 43Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 13:21:04) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((39 0) (90 0)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((90 0) (144 113)) NIL ((54. 113. 0 0 0 0 )) NATURAL) (2 ((144 113) (246 113)) NIL ((102. 0 0 0 0 0 )) NATURAL) (2 ((246 113) (192 0)) NIL ((-54. -113. 0 0 0 0 )) NATURAL) (2 ((192 0) (243 0)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((243 0) (297 113)) NIL ((54. 113. 0 0 0 0 )) NATURAL) (2 ((297 113) (393 113)) NIL ((96. 0 0 0 0 0 )) NATURAL) (2 ((393 113) (393 148)) NIL ((0 35. 0 0 0 0 )) NATURAL) (2 ((393 148) (313 148)) NIL ((-80. 0 0 0 0 0 )) NATURAL) (2 ((313 148) (337 198)) NIL ((24. 50. 0 0 0 0 )) NATURAL) (2 ((337 198) (415 198)) NIL ((78. 0 0 0 0 0 )) NATURAL) (2 ((415 198) (417 232)) NIL ((2. 34. 0 0 0 0 )) NATURAL) (2 ((417 232) (354 232)) NIL ((-63. 0 0 0 0 0 )) NATURAL) (2 ((354 232) (405 337)) NIL ((51. 105. 0 0 0 0 )) NATURAL) (2 ((405 337) (354 337)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((354 337) (303 232)) NIL ((-51. -105. 0 0 0 0 )) NATURAL) (2 ((303 232) (201 232)) NIL ((-102. 0 0 0 0 0 )) NATURAL) (2 ((201 232) (252 337)) NIL ((51. 105. 0 0 0 0 )) NATURAL) (2 ((252 337) (201 337)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((201 337) (150 232)) NIL ((-51. -105. 0 0 0 0 )) NATURAL) (2 ((150 232) (54 232)) NIL ((-96. 0 0 0 0 0 )) NATURAL) (2 ((54 232) (54 197)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((54 197) (133 197)) NIL ((79. 0 0 0 0 0 )) NATURAL) (2 ((133 197) (109 147)) NIL ((-24. -50. 0 0 0 0 )) NATURAL) (2 ((109 147) (31 147)) NIL ((-78. 0 0 0 0 0 )) NATURAL) (2 ((31 147) (30 113)) NIL ((-1. -34. 0 0 0 0 )) NATURAL) (2 ((30 113) (93 113)) NIL ((63. 0 0 0 0 0 )) NATURAL) (2 ((93 113) (39 0)) NIL ((-54. -113. 0 0 0 0 )) NATURAL)) ((2 ((184 197) (160 147)) NIL ((-24. -50. 0 0 0 0 )) NATURAL) (2 ((160 147) (262 147)) NIL ((102. 0 0 0 0 0 )) NATURAL) (2 ((262 147) (286 197)) NIL ((24. 50. 0 0 0 0 )) NATURAL) (2 ((286 197) (184 197)) NIL ((-102. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 46Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:35:37) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((4 ((107 270) (123 246) (161 212) (174 202)) NIL ((8.46666719 -19.733333 0 0 45.199996 -25.599998 ) (31.066665 -32.533332 45.199996 -25.599998 -93.999984 67.999984 ) (29.266662 -24.133331 -48.799995 42.399993 48.799995 -42.399993 )) NATURAL) (13 ((174 202) (197 214) (222 228) (247 246) (259 270) (253 289) (235 303) (205 308) (182 310) (158 308) (131 303) (113 289) (107 270)) NIL ((22.63285 11.613859 0 0 2.202878 2.31683636 ) (23.73429 12.7722778 2.202878 2.31683636 0.985608578 0.415817738 ) (26.429973 15.2970237 3.18848658 2.73265409 -18.145309 8.01989175 ) (20.545803 22.039623 -14.956825 10.752546 -6.4043541 -20.495391 ) (2.38680172 22.544475 -21.361179 -9.74284555 13.7627258 7.9616804 ) (-12.0930137 16.7824669 -7.5984535 -1.78116488 -12.646549 -11.3513279 ) (-26.014743 9.3256397 -20.245002 -13.1324939 36.82347 13.4436359 ) (-27.848007 2.91496467 16.578468 0.311142981 -20.647338 -6.42321969 ) (-21.593212 0.0144983027 -4.0688715 -6.11207677 -2.23410892 6.24923993 ) (-26.779136 -2.97295809 -6.30298043 0.137163698 17.583774 -12.57374 ) (-24.290229 -9.1226635 11.280794 -12.4365768 3.8990078 8.04572106 ) (-11.0599327 -17.53638 15.1798019 -4.39085484 -15.1798019 4.39085484 )) NATURAL)) ((15 ((129 183) (72 242) (61 280) (73 309) (97 326) (132 339) (183 344) (234 339) (268 326) (291 309) (302 280) (294 242) (270 214) (238 196) (200 177)) NIL ((-67.869125 64.199096 0 0 65.214828 -31.194587 ) (-35.261718 48.601799 65.214828 -31.194587 -50.074157 29.972938 ) (4.91602898 32.393684 15.1406707 -1.22164702 -2.91818809 -16.697174 ) (18.597606 22.823448 12.2224827 -17.918823 -4.25308895 18.815761 ) (28.693542 14.312507 7.96939374 0.896939040 13.930542 -10.56587 ) (43.628204 9.92650987 21.899936 -9.66893197 -21.469078 -0.552272797 ) (54.7936 -0.0185569115 0.430855572 -10.2212047 -24.054214 0.774955750 ) (43.197349 -9.85228349 -23.623359 -9.446249 15.6859588 9.4524574 ) (27.416969 -14.5723037 -7.93739987 0.00620953180 -2.68962955 -14.584795 ) (18.134754 -21.858493 -10.627029 -14.578586 -10.927448 0.886726380 ) (2.04400062 -35.993713 -21.554477 -13.69186 4.39942932 29.03789 ) (-17.31076 -35.166626 -17.155048 15.346033 11.329729 -3.0383091 ) (-28.800945 -21.339752 -5.82531929 12.307724 -1.71835041 -16.884651 ) (-35.485443 -17.474353 -7.5436697 -4.57693005 7.5436697 4.57693005 )) NATURAL) (2 ((200 177) (318 80)) NIL ((118. -97. 0 0 0 0 )) NATURAL) (6 ((318 80) (335 99) (346 114) (356 130) (368 156) (372 178)) NIL ((18.459327 19.933013 0 0 -8.75597955 -5.5980854 ) (14.0813389 17.133968 -8.75597955 -5.5980854 7.77990246 3.99043036 ) (9.21531106 13.531099 -0.976076246 -1.60765481 7.63636208 19.63636 ) (12.057415 21.741626 6.66028596 18.028705 -20.325355 -28.53588 ) (8.5550232 25.502391 -13.665069 -10.507175 13.665069 10.507175 )) NATURAL) (2 ((372 178) (421 178)) NIL ((49. 0 0 0 0 0 )) NATURAL) (6 ((421 178) (412 145) (396 115) (373 85) (361 74) (346 59)) NIL ((-7.85167409 -34.186599 0 0 -6.88995267 7.1196165 ) (-11.2966499 -30.626792 -6.88995267 7.1196165 -7.5502367 -17.598083 ) (-21.961719 -32.306213 -14.440189 -10.4784679 37.090904 45.27272 ) (-17.856456 -20.148323 22.650714 34.794258 -32.813392 -49.49282 ) (-11.61244 -10.100477 -10.1626777 -14.698564 10.1626777 14.698564 )) NATURAL) (2 ((346 59) (424 0)) NIL ((78. -59. 0 0 0 0 )) NATURAL) (2 ((424 0) (352 0)) NIL ((-72. 0 0 0 0 0 )) NATURAL) (2 ((352 0) (309 32)) NIL ((-43. 32. 0 0 0 0 )) NATURAL) (12 ((309 32) (270 11) (228 -2) (163 -8) (105 0) (63 18) (37 45) (28 84) (40 124) (64 150) (94 168) (129 183)) NIL ((-39.917266 -22.867206 0 0 5.50363159 11.2032489 ) (-37.16545 -17.265583 5.50363159 11.2032489 -45.518158 -8.0162468 ) (-54.420906 -10.070457 -40.014526 3.18700123 56.569015 14.861742 ) (-66.150909 0.547416330 16.554489 18.048744 -0.757925034 -9.4307308 ) (-49.975395 13.880794 15.796564 8.61801339 0.462682724 -1.13881588 ) (-33.947486 21.929401 16.2592468 7.4791975 -1.09281921 7.98599148 ) (-18.234645 33.401596 15.166427 15.4651889 9.90859605 -12.805143 ) (1.88607931 42.46421 25.075023 2.66004515 -14.5415477 -22.765411 ) (19.690326 33.741546 10.5334758 -20.105369 -5.74240303 13.866802 ) (27.3526 20.56958 4.79107285 -6.23856736 1.51115894 3.29820967 ) (32.899253 15.9801178 6.30223179 -2.94035768 -6.30223179 2.94035768 )) NATURAL)) ((10 ((277 52) (243 38) (192 25) (147 26) (111 37) (86 53) (72 82) (81 112) (105 133) (150 157)) NIL ((-29.138164 -13.446022 0 0 -29.170993 -3.32386208 ) (-43.723663 -15.107954 -29.170993 -3.32386208 43.854972 22.619308 ) (-50.96717 -7.12215996 14.683979 19.295448 -8.2489071 -9.15338517 ) (-40.407638 7.59659577 6.43507195 10.142063 7.14065743 -10.0057678 ) (-30.40224 12.735775 13.575729 0.136293560 -8.3137245 19.176464 ) (-20.983375 22.460304 5.26200485 19.312759 26.114242 -18.700103 ) (-2.66424894 32.423004 31.376247 0.612653733 -24.143245 -16.376026 ) (16.640373 24.847648 7.23299885 -15.763374 22.458747 24.204216 ) (35.102745 21.186382 29.691749 8.44084359 -29.691749 -8.44084359 )) NATURAL) (2 ((150 157) (277 52)) NIL ((127. -105. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 47Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:38:09) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((8 ((210 197) (203 223) (195 248) (188 273) (185 296) (187 313) (199 331) (220 338)) NIL ((-6.72208787 26.270351 0 0 -1.66746807 -1.62212276 ) (-7.55582238 25.459289 -1.66746807 -1.62212276 2.33734083 2.1106143 ) (-8.05461885 24.892475 0.669872761 0.488491952 4.31810379 -0.820336819 ) (-5.2256956 24.970798 4.98797703 -0.331844926 -1.60975694 -10.8292656 ) (-1.04259658 19.224319 3.37822008 -11.1611118 8.12091828 20.137405 ) (6.39608384 18.131912 11.4991397 8.97629548 -0.873926163 -27.720367 ) (17.458259 13.248024 10.6252136 -18.7440719 -10.6252136 18.7440719 )) NATURAL) (8 ((220 338) (241 331) (253 313) (255 296) (252 273) (245 248) (237 223) (230 197)) NIL ((22.770866 -3.875988 0 0 -10.6252136 -18.7440719 ) (17.458259 -13.248024 -10.6252136 -18.7440719 -0.873926163 27.720367 ) (6.39608288 -18.131912 -11.4991397 8.97629548 8.12091828 -20.137409 ) (-1.04259729 -19.224319 -3.37822008 -11.1611137 -1.60975599 10.829267 ) (-5.2256956 -24.970798 -4.98797608 -0.331844509 4.31810284 0.820336342 ) (-8.05461885 -24.892475 -0.669872761 0.488491833 2.33734083 -2.1106143 ) (-7.55582238 -25.459289 1.66746831 -1.62212276 -1.66746831 1.62212276 )) NATURAL) (2 ((230 197) (210 197)) NIL ((-20. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 50Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:40:32) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((304 350) (256 350)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (11 ((256 350) (226 328) (190 291) (160 250) (140 202) (127 121) (139 40) (161 -8) (190 -49) (226 -86) (256 -108)) NIL ((-28.149116 -18.291866 0 0 -11.105289 -22.248802 ) (-33.701759 -29.416267 -11.105289 -22.248802 19.526447 21.244014 ) (-35.043823 -41.04306 8.42115785 -1.00478410 4.99949837 3.2727251 ) (-24.12292 -40.411483 13.420656 2.267941 -15.5244369 -52.334915 ) (-18.464481 -64.311004 -2.10378218 -50.066978 39.098243 50.066978 ) (-1.01913643 -89.34448 36.994468 0 -32.868583 50.066978 ) (19.541038 -64.310989 4.1258812 50.066978 2.37611484 -52.334915 ) (24.854976 -40.411476 6.50199605 -2.26794243 5.3641386 3.27272701 ) (34.039039 -41.04306 11.8661346 1.00478482 -23.832664 21.244014 ) (33.988838 -29.416267 -11.9665317 22.248802 11.9665317 -22.248802 )) NATURAL) (2 ((256 -108) (304 -108)) NIL ((48. 0 0 0 0 0 )) NATURAL) (11 ((304 -108) (274 -86) (238 -49) (210 -8) (187 40) (175 121) (189 202) (208 250) (238 291) (274 328) (304 350)) NIL ((-27.892368 18.291866 0 0 -12.6457729 22.248802 ) (-34.215255 29.416267 -12.6457729 22.248802 27.22887 -21.244014 ) (-33.246589 41.04306 14.583097 1.00478410 -12.269714 -3.2727251 ) (-24.798355 40.411483 2.3133831 -2.267941 3.84998512 52.334915 ) (-20.559978 64.311004 6.16336823 50.066978 32.869773 -50.066978 ) (2.03827906 89.34448 39.033142 0 -45.3291 -50.066978 ) (18.406868 64.310989 -6.29596043 -50.066978 22.446659 52.334915 ) (23.334239 40.411476 16.150699 2.26794243 -8.45755387 -3.27272701 ) (35.256164 41.04306 7.69314576 -1.00478482 -18.616432 -21.244014 ) (33.64109 29.416267 -10.923286 -22.248802 10.923286 22.248802 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 51Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:42:07) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((11 ((126 350) (156 328) (192 291) (222 250) (241 202) (255 121) (243 40) (220 -8) (192 -49) (156 -86) (126 -108)) NIL ((28.17945 -18.291866 0 0 10.923286 -22.248802 ) (33.64109 -29.416267 10.923286 -22.248802 -18.616432 21.244014 ) (35.256164 -41.04306 -7.69314576 -1.00478410 -8.45755769 3.2727251 ) (23.334239 -40.411483 -16.150703 2.267941 22.446666 -52.334915 ) (18.406868 -64.311004 6.29596425 -50.066978 -45.329109 50.066978 ) (2.03827715 -89.34448 -39.033149 0 32.86978 50.066978 ) (-20.559978 -64.310989 -6.16336537 50.066978 3.84998179 -52.334915 ) (-24.798355 -40.411476 -2.31338358 -2.26794243 -12.269712 3.27272701 ) (-33.246589 -41.04306 -14.583097 1.00478482 27.22887 21.244014 ) (-34.215255 -29.416267 12.6457748 22.248802 -12.6457748 -22.248802 )) NATURAL) (2 ((126 -108) (174 -108)) NIL ((48. 0 0 0 0 0 )) NATURAL) (11 ((174 -108) (204 -86) (240 -49) (269 -8) (291 40) (303 121) (290 202) (270 250) (240 291) (204 328) (174 350)) NIL ((28.005577 18.291866 0 0 11.9665336 22.248802 ) (33.988838 29.416267 11.9665336 22.248802 -23.832668 -21.244014 ) (34.039039 41.04306 -11.8661346 1.00478410 5.36413956 -3.2727251 ) (24.854976 40.411483 -6.50199509 -2.267941 2.37611198 52.334915 ) (19.541038 64.311004 -4.1258831 50.066978 -32.868583 -50.066978 ) (-1.01914072 89.34448 -36.994468 0 39.098243 -50.066978 ) (-18.464481 64.310989 2.10378218 -50.066978 -15.5244369 52.334915 ) (-24.12292 40.411476 -13.420656 2.26794243 4.99949837 -3.27272701 ) (-35.043823 41.04306 -8.42115785 -1.00478482 19.526447 -21.244014 ) (-33.701759 29.416267 11.105289 -22.248802 -11.105289 22.248802 )) NATURAL) (2 ((174 350) (126 350)) NIL ((-48. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 52Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 14:50:44) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((49 ((225 98) (205 106) (196 133) (202 169) (218 201) (186 185) (159 162) (132 150) (105 157) (93 184) (111 202) (144 209) (203 218) (144 227) (111 234) (93 252) (105 279) (132 286) (159 274) (186 251) (218 235) (202 267) (196 303) (205 330) (225 338) (245 330) (254 303) (248 267) (232 235) (264 251) (291 274) (318 286) (345 279) (357 252) (339 234) (306 227) (247 218) (306 209) (339 202) (357 184) (345 157) (318 150) (291 162) (264 185) (232 201) (248 169) (254 133) (245 106) (225 98)) NIL ((-22.53239 0.0906766206 0.746076346 11.4537448 12.9561367 13.094705 ) (-15.308248 18.091774 13.702213 24.54845 -3.25714302 -20.196006 ) (-3.23460579 32.54222 10.44507 4.3524437 24.072422 7.68932534 ) (19.246673 40.739326 34.517494 12.041769 -123.0325 -88.561279 ) (-7.7521 8.50045587 -88.515045 -76.519516 120.0577 82.5558 ) (-36.238273 -26.741153 31.542694 6.03629685 -39.198417 4.33803749 ) (-24.294792 -18.535835 -7.65572835 10.374334 6.73594475 8.09202767 ) (-28.582546 -4.11548805 -0.919782878 18.466362 12.254642 11.293846 ) (-23.375007 19.997795 11.3348598 29.760208 34.245483 -47.267402 ) (5.08259297 26.124298 45.580345 -17.507198 -59.236595 3.77578545 ) (21.044639 10.504995 -13.65625 -13.7314129 112.70089 20.164264 ) (63.738838 6.85571576 99.044647 6.43285275 -325.5669 -6.43285275 ) (5.08129596E-6 10.0721416 -226.5223 0 325.5669 -6.43285275 ) (-63.738838 6.8557148 99.044647 -6.43285275 -112.70089 20.164264 ) (-21.044639 10.504995 -13.6562519 13.7314129 59.2366 3.77578545 ) (-5.0825901 26.124301 45.580352 17.507198 -34.245513 -47.26741 ) (23.375003 19.997791 11.3348369 -29.760215 -12.254545 11.293884 ) (28.582569 -4.11548043 -0.919708253 -18.466331 -6.7362957 8.0918808 ) (24.294712 -18.535869 -7.65600396 -10.3744506 39.199722 4.33859158 ) (36.23857 -26.741024 31.543724 -6.0358591 -120.0626 82.55374 ) (7.75098897 8.49999238 -88.51889 76.51788 123.0507 -88.5536 ) (-19.24253 40.741066 34.531845 -12.0357227 -24.140338 7.6607275 ) (3.21914434 32.535705 10.391504 -4.37499523 3.51062012 -20.08929 ) (15.365957 18.116069 13.902124 -24.464286 -13.902124 12.69643 ) (22.31702 0 -5.11072471E-7 -11.7678566 -13.90212 -12.69643 ) (15.365957 -18.116069 -13.902122 -24.464286 3.5106144 20.089286 ) (3.21914196 -32.535713 -10.391508 -4.37499714 -24.140327 -7.6607256 ) (-19.24253 -40.741066 -34.531837 -12.0357227 123.0507 88.5536 ) (7.75099564 -8.49998284 88.518875 76.51788 -120.06259 -82.55374 ) (36.23857 26.741027 -31.543724 -6.035861 39.199722 -4.33858967 ) (24.294712 18.535869 7.6560049 -10.3744506 -6.73629666 -8.0918808 ) (28.582569 4.11547947 0.919708014 -18.466331 -12.254543 -11.293884 ) (23.375003 -19.997791 -11.3348369 -29.760215 -34.245513 47.26741 ) (-5.08259106 -26.124298 -45.580352 17.507198 59.2366 -3.77578545 ) (-21.044643 -10.504995 13.6562538 13.7314129 -112.70089 -20.164264 ) (-63.738838 -6.85571576 -99.044647 -6.43285275 325.5669 6.43285275 ) (-5.08129596E-6 -10.0721416 226.5223 0 -325.5669 6.43285275 ) (63.738838 -6.8557148 -99.044647 6.43285275 112.70089 -20.164264 ) (21.044639 -10.504995 13.65625 -13.7314129 -59.236595 -3.77578545 ) (5.08259106 -26.124298 -45.580345 -17.507198 34.245483 47.267402 ) (-23.375011 -19.997795 -11.334856 29.760204 12.2546367 -11.293842 ) (-28.582546 4.11548996 0.919782162 18.466362 6.7359457 -8.09202767 ) (-24.294792 18.535839 7.65572835 10.374334 -39.198417 -4.33804226 ) (-36.238273 26.741149 -31.542694 6.03629208 120.0577 -82.555786 ) (-7.75209904 -8.50045968 88.515045 -76.5195 -123.0325 88.56126 ) (19.246673 -40.739326 -34.517494 12.041765 24.072422 -7.6893215 ) (-3.2346077 -32.54222 -10.44507 4.3524437 -3.25714302 20.196006 ) (-15.308248 -18.091774 -13.702213 24.54845 12.9561367 -13.094705 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 53Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:00:01) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((195 28) (245 28)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((245 28) (245 143)) NIL ((0 115. 0 0 0 0 )) NATURAL) (2 ((245 143) (360 143)) NIL ((115. 0 0 0 0 0 )) NATURAL) (2 ((360 143) (360 193)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((360 193) (245 193)) NIL ((-115. 0 0 0 0 0 )) NATURAL) (2 ((245 193) (245 308)) NIL ((0 115. 0 0 0 0 )) NATURAL) (2 ((245 308) (195 308)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((195 308) (195 193)) NIL ((0 -115. 0 0 0 0 )) NATURAL) (2 ((195 193) (80 193)) NIL ((-115. 0 0 0 0 0 )) NATURAL) (2 ((80 193) (80 143)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (2 ((80 143) (195 143)) NIL ((115. 0 0 0 0 0 )) NATURAL) (2 ((195 143) (195 28)) NIL ((0 -115. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 54Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:04:46) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((20 ((218 -3) (205 -3) (185 9) (175 29) (181 49) (195 61) (213 66) (241 61) (255 50) (263 29) (259 -9) (247 -32) (234 -44) (215 -53) (186 -57) (170 -49) (177 -36) (195 -31) (215 -21) (218 -3)) NIL ((-10.673479 -2.67581272 0 0 -13.959116 16.054878 ) (-17.653038 5.3516264 -13.959116 16.054878 27.795578 -8.27439309 ) (-17.714363 17.269306 13.8364639 7.7804842 4.77679062 -6.95730019 ) (-1.48950290 21.57114 18.613254 0.823183776 -10.902744 -11.896402 ) (11.672378 16.446121 7.7105093 -11.073219 -9.1658039 6.54291535 ) (14.7999859 8.6443615 -1.4552958 -4.53030396 23.565967 -8.275259 ) (25.127674 -0.0235718079 22.110672 -12.8055629 -49.09806 8.5581188 ) (22.689312 -8.55007554 -26.987392 -4.2474432 28.826297 -1.95721721 ) (10.115068 -13.7761268 1.83890605 -6.2046604 -18.207134 -24.729248 ) (2.8504076 -32.345413 -16.3682289 -30.93391 8.00223924 58.874214 ) (-9.51670075 -33.842216 -8.36598969 27.940307 10.198177 -18.767623 ) (-12.7836017 -15.2857189 1.83218932 9.1726837 -6.7949562 -7.80373 ) (-14.34889 -10.0149 -4.9627676 1.3689537 -13.0183487 1.98254585 ) (-25.820835 -7.65467358 -17.981117 3.35149956 34.868362 11.8735466 ) (-26.367767 1.63359928 16.887249 15.225046 11.544872 -7.47673417 ) (-3.70808268 13.120277 28.43212 7.748312 -21.047866 -23.966606 ) (14.2001037 8.8852844 7.3842535 -16.218296 0.646611214 25.343174 ) (21.907661 5.3385763 8.0308647 9.12487985 -35.538574 0.593898773 ) (12.169237 14.760406 -27.507713 9.7187786 27.507713 -9.7187786 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 55Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:07:38) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((320 193) (120 193)) NIL ((-200. 0 0 0 0 0 )) NATURAL) (2 ((120 193) (120 143)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (2 ((120 143) (320 143)) NIL ((200. 0 0 0 0 0 )) NATURAL) (2 ((320 143) (320 193)) NIL ((0 50. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 56Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:10:01) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((13 ((218 63) (231 61) (251 49) (261 29) (251 9) (231 -3) (218 -5) (205 -3) (185 9) (175 29) (185 49) (205 61) (218 63)) NIL ((10.989046 -0.181750595 -0.894697548 1.09114074 14.749813 -14.182918 ) (17.469253 -6.18206978 13.8551159 -13.0917778 -26.380886 4.36775208 ) (18.133926 -17.089969 -12.52577 -8.7240257 -11.226255 8.71190835 ) (-0.00497087091 -21.458042 -23.752025 -0.0121169965 11.285902 8.78460885 ) (-18.114044 -17.077854 -12.466123 8.77249337 26.082653 4.14965058 ) (-17.538841 -6.2305355 13.616529 12.9221439 -13.616529 -13.3832149 ) (-10.730577 9.96515154E-8 0 -0.461072266 -13.616529 13.3832149 ) (-17.538841 6.23053647 -13.616529 12.9221439 26.082653 -4.14965058 ) (-18.114044 17.077854 12.466123 8.77249337 11.285898 -8.78460885 ) (-0.00496927649 21.458042 23.752021 -0.0121165085 -11.2262497 -8.71190835 ) (18.133926 17.089969 12.525772 -8.7240257 -26.380889 -4.36775208 ) (17.469253 6.18206883 -13.8551178 -13.0917778 14.749815 14.182918 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 57Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:11:04) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((73 0) (321 337)) NIL ((248. 337. 0 0 0 0 )) NATURAL) (2 ((321 337) (369 337)) NIL ((48. 0 0 0 0 0 )) NATURAL) (2 ((369 337) (121 0)) NIL ((-248. -337. 0 0 0 0 )) NATURAL) (2 ((121 0) (73 0)) NIL ((-48. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 73Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:15:21) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((13 ((219 232) (206 230) (186 218) (176 198) (186 178) (206 166) (219 164) (232 166) (252 178) (262 198) (252 218) (232 230) (219 232)) NIL ((-10.989046 -0.181750595 0.894697548 1.09114074 -14.749813 -14.182918 ) (-17.469253 -6.18206978 -13.8551159 -13.0917778 26.380886 4.36775208 ) (-18.133926 -17.089969 12.52577 -8.7240257 11.226255 8.71190835 ) (0.00497087091 -21.458042 23.752025 -0.0121169965 -11.285902 8.78460885 ) (18.114044 -17.077854 12.466123 8.77249337 -26.082653 4.14965058 ) (17.538841 -6.2305355 -13.616529 12.9221439 13.616529 -13.3832149 ) (10.730577 9.96515154E-8 0 -0.461072266 13.616529 13.3832149 ) (17.538841 6.23053647 13.616529 12.9221439 -26.082653 -4.14965058 ) (18.114044 17.077854 -12.466123 8.77249337 -11.285898 -8.78460885 ) (0.00496927649 21.458042 -23.752021 -0.0121165085 11.2262497 -8.71190835 ) (-18.133926 17.089969 -12.525772 -8.7240257 26.380889 -4.36775208 ) (-17.469253 6.18206883 13.8551178 -13.0917778 -14.749815 14.182918 )) PSEUDOCYCLIC)) ((20 ((218 -3) (215 -21) (195 -31) (177 -36) (170 -49) (186 -57) (215 -53) (234 -44) (247 -32) (259 -9) (263 29) (255 50) (241 61) (213 66) (195 61) (181 49) (175 29) (185 9) (205 -3) (218 -3)) NIL ((1.58461880 -19.619796 0 0 -27.507713 9.7187805 ) (-12.169239 -14.760406 -27.507713 9.7187805 35.538574 -0.593902588 ) (-21.907661 -5.3385763 8.0308647 9.1248779 -0.646611214 -25.343174 ) (-14.2001037 -8.88528634 7.3842535 -16.218296 21.047866 23.966606 ) (3.70808458 -13.120277 28.43212 7.748312 -11.544872 7.47673417 ) (26.367767 -1.63359856 16.887249 15.225046 -34.86837 -11.8735466 ) (25.820831 7.65467358 -17.981121 3.35149956 13.018354 -1.98254537 ) (14.34889 10.0149 -4.9627657 1.36895418 6.7949543 7.80372716 ) (12.7836017 15.2857208 1.8321886 9.1726818 -10.198175 18.767623 ) (9.51670075 33.842208 -8.36598779 27.940307 -8.00224114 -58.874214 ) (-2.85040808 32.345413 -16.3682289 -30.93391 18.207134 24.729248 ) (-10.115068 13.7761268 1.83890652 -6.20466138 -28.826297 1.95721817 ) (-22.689312 8.5500736 -26.987392 -4.2474432 49.09806 -8.5581188 ) (-25.127674 0.0235716477 22.110672 -12.8055629 -23.565967 8.275259 ) (-14.7999859 -8.6443615 -1.45529556 -4.53030396 9.1658039 -6.54291535 ) (-11.672378 -16.446121 7.7105093 -11.073219 10.902744 11.896402 ) (1.48950433 -21.57114 18.613254 0.823183776 -4.77679062 6.95730019 ) (17.714363 -17.269306 13.8364639 7.7804842 -27.795578 8.27439309 ) (17.653038 -5.35162544 -13.959116 16.054878 13.959116 -16.054878 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 72Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 20-SEP-77 15:16:21) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((7 ((219 164) (206 166) (186 178) (176 198) (186 218) (206 230) (219 232)) NIL ((-10.730768 -0.133333206 0 0 -13.615383 12.799999 ) (-17.538459 6.2666664 -13.615383 12.799999 26.076919 -4. ) (-18.115383 17.066665 12.461538 8.79999925 11.3076915 -8.79999925 ) (6.37024641E-7 21.466663 23.769229 0 -11.307693 -8.79999925 ) (18.115383 17.066665 12.461536 -8.79999925 -26.076919 -4. ) (17.538459 6.2666664 -13.615383 -12.799999 13.615383 12.799999 )) NATURAL) (7 ((219 232) (232 230) (252 218) (262 198) (252 178) (232 166) (219 164)) NIL ((10.730768 0.133333206 0 0 13.615383 -12.799999 ) (17.538459 -6.2666664 13.615383 -12.799999 -26.076919 4. ) (18.115383 -17.066665 -12.461538 -8.79999925 -11.3076915 8.79999925 ) (-6.37024641E-7 -21.466663 -23.769229 0 11.307693 8.79999925 ) (-18.115383 -17.066665 -12.461536 8.79999925 26.076919 4. ) (-17.538459 -6.2666664 13.615383 12.799999 -13.615383 -12.799999 )) NATURAL)) ((7 ((219 -3) (206 -1) (186 11) (176 31) (186 51) (206 63) (219 65)) NIL ((-10.730768 -0.133333206 0 0 -13.615383 12.799999 ) (-17.538459 6.2666664 -13.615383 12.799999 26.076919 -4. ) (-18.115383 17.066665 12.461538 8.79999925 11.3076915 -8.79999925 ) (6.37024641E-7 21.466663 23.769229 0 -11.307693 -8.79999925 ) (18.115383 17.066665 12.461536 -8.79999925 -26.076919 -4. ) (17.538459 6.2666664 -13.615383 -12.799999 13.615383 12.799999 )) NATURAL) (7 ((219 65) (232 63) (252 51) (262 31) (252 11) (232 -1) (219 -3)) NIL ((10.730768 0.133333206 0 0 13.615383 -12.799999 ) (17.538459 -6.2666664 13.615383 -12.799999 -26.076919 4. ) (18.115383 -17.066665 -12.461538 -8.79999925 -11.3076915 8.79999925 ) (-6.37024641E-7 -21.466663 -23.769229 0 11.307693 8.79999925 ) (-18.115383 -17.066665 -12.461536 8.79999925 26.076919 4. ) (-17.538459 -6.2666664 13.615383 12.799999 -13.615383 -12.799999 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 45Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 8:31:26) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((17 ((118 338) (159 333) (186 321) (201 303) (207 277) (201 251) (186 233) (159 221) (118 216) (78 221) (51 233) (36 251) (30 277) (36 303) (51 321) (78 333) (118 338)) NIL ((43.632125 -0.0974335671 1.31016326 -11.476913 -19.723274 5.01534176 ) (35.08065 -9.0666752 -18.413112 -6.4615717 6.75541115 1.78477382 ) (20.045242 -14.63586 -11.657701 -4.67679787 4.70163059 -6.1544361 ) (10.7383575 -22.389877 -6.9560709 -10.8312339 -7.56193638 10.832973 ) (0.00131877139 -27.804622 -14.518007 0.00173969077 7.5461092 10.8225345 ) (-10.743633 -22.391616 -6.97189809 10.8242759 -4.62250042 -6.1231203 ) (-20.026783 -14.6289 -11.594398 4.70115566 -7.05610657 1.66994285 ) (-35.14923 -9.09277345 -18.650505 6.3710985 20.846931 5.4433527 ) (-43.376274 0 2.19642639 11.814451 13.668373 -5.44335366 ) (-34.345657 9.09277345 15.864799 6.37109757 -3.52042198 -1.66994095 ) (-20.241073 14.6289 12.344377 4.70115662 -5.5866909 6.12311745 ) (-10.6900406 22.391616 6.7576866 10.824274 7.8671856 -10.8225326 ) (0.00123898312 27.804622 14.624872 0.00174020207 -7.8820505 -10.832975 ) (10.685085 22.389877 6.7428217 -10.8312358 5.6610155 6.154438 ) (20.258415 14.63586 12.403837 -4.67679787 3.23799324 -1.78477382 ) (34.281242 9.0666752 15.64183 -6.4615717 -12.6129837 -5.01534176 )) PSEUDOCYCLIC)) ((13 ((318 25) (342 29) (364 43) (370 61) (364 79) (342 93) (318 96) (294 93) (272 79) (266 61) (272 43) (294 29) (318 25)) NIL ((24.01675 0.0585110932 -1.65684819 5.3434658 4.87002945 7.618536 ) (24.794918 9.21124459 3.2131815 12.9620018 -26.409057 -10.1534767 ) (14.803571 17.096508 -23.195877 2.80852413 16.766201 -3.00462341 ) (-0.00920486450 18.402717 -6.42967606 -0.196099460 -16.655742 -1.82802653 ) (-14.766752 17.292606 -23.085418 -2.02412605 25.856773 -13.683267 ) (-24.923782 8.42684747 2.77135515 -15.707393 -2.77135515 14.56109 ) (-23.538105 -8.00937414E-8 -1.27768117E-7 -1.14630294 -2.7713542 -14.56109 ) (-24.923782 -8.42684747 -2.77135467 -15.707393 25.856773 13.6832657 ) (-14.766752 -17.292606 23.085418 -2.02412653 -16.655742 1.82802701 ) (-0.00920422748 -18.402717 6.42967606 -0.196099311 16.766197 3.00462294 ) (14.803571 -17.096508 23.195873 2.80852365 -26.409053 10.1534767 ) (24.794918 -9.21124459 -3.21318102 12.9620018 4.8700285 -7.61853696 )) PSEUDOCYCLIC)) ((2 ((324 337) (73 0)) NIL ((-251. -337. 0 0 0 0 )) NATURAL) (3 ((73 0) (73 0) (118 0)) NIL ((-11.25 0 0 0 67.5 0 ) (22.5 0 67.5 0 -67.5 0 )) NATURAL) (2 ((118 0) (369 337)) NIL ((251. 337. 0 0 0 0 )) NATURAL) (2 ((369 337) (324 337)) NIL ((-45. 0 0 0 0 0 )) NATURAL)) ((17 ((319 122) (360 117) (387 105) (402 87) (408 61) (402 35) (387 17) (360 5) (319 0) (279 5) (252 17) (237 35) (231 61) (237 87) (252 105) (279 117) (319 122)) NIL ((43.632125 -0.0974335671 1.31016326 -11.476913 -19.723274 5.01534176 ) (35.08065 -9.0666752 -18.413112 -6.4615717 6.75541115 1.78477382 ) (20.045242 -14.63586 -11.657701 -4.67679787 4.70163059 -6.1544361 ) (10.7383575 -22.389877 -6.9560709 -10.8312339 -7.56193638 10.832973 ) (0.00131877139 -27.804622 -14.518007 0.00173969077 7.5461092 10.8225345 ) (-10.743633 -22.391616 -6.97189809 10.8242759 -4.62250042 -6.1231203 ) (-20.026783 -14.6289 -11.594398 4.70115566 -7.05610657 1.66994285 ) (-35.14923 -9.09277345 -18.650505 6.3710985 20.846931 5.4433527 ) (-43.376274 0 2.19642639 11.814451 13.668373 -5.44335366 ) (-34.345657 9.09277345 15.864799 6.37109757 -3.52042198 -1.66994095 ) (-20.241073 14.6289 12.344377 4.70115662 -5.5866909 6.12311745 ) (-10.6900406 22.391616 6.7576866 10.824274 7.8671856 -10.8225326 ) (0.00123898312 27.804622 14.624872 0.00174020207 -7.8820505 -10.832975 ) (10.685085 22.389877 6.7428217 -10.8312358 5.6610155 6.154438 ) (20.258415 14.63586 12.403837 -4.67679787 3.23799324 -1.78477382 ) (34.281242 9.0666752 15.64183 -6.4615717 -12.6129837 -5.01534176 )) PSEUDOCYCLIC)) ((13 ((118 312) (142 309) (164 295) (170 277) (164 259) (142 245) (118 241) (94 245) (72 259) (66 277) (72 295) (94 309) (118 312)) NIL ((23.538459 -0.330866456 0 0 2.76922989 -16.014801 ) (24.923076 -8.33826829 2.76922989 -16.014801 -25.846149 14.074016 ) (14.769228 -17.316059 -23.076919 -1.94078445 16.615379 1.71872663 ) (-6.37024641E-7 -18.39748 -6.4615383 -0.222057670 -16.615379 3.0510726 ) (-14.7692318 -17.094001 -23.076919 2.82901525 25.846149 10.0769786 ) (-24.923076 -9.22649766 2.76923036 12.905994 -2.76922989 -7.35899258 ) (-23.538459 3.18512320E-7 2.55536235E-7 5.54700184 -2.76923132 7.35899258 ) (-24.923076 9.22649766 -2.76923132 12.905994 25.846153 -10.0769786 ) (-14.7692299 17.094001 23.076923 2.82901478 -16.6153869 -3.05107212 ) (6.37024641E-7 18.39748 6.4615364 -0.222057640 16.6153869 -1.71872687 ) (14.7692299 17.316059 23.076923 -1.94078469 -25.846153 -14.074014 ) (24.923076 8.33826638 -2.76923084 -16.014801 2.76923084 16.014801 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 44Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 9:30:26) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((236 364) (236 344)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (7 ((236 344) (277 339) (309 330) (331 320) (348 309) (363 291) (367 260)) NIL ((42.793586 -4. 0 0 -10.7615375 -6. ) (37.412818 -7. -10.7615375 -6. -0.192308426 6. ) (26.555126 -9.9999981 -10.9538459 6.81195899E-8 5.5307703 -3.23568030E-7 ) (18.366664 -10. -5.42307568 -2.55448469E-7 8.0692272 -5.9999981 ) (16.978202 -13. 2.6461525 -5.99999905 -19.807685 -12. ) (9.72051049 -25. -17.161533 -18. 17.161533 18. )) NATURAL) (2 ((367 260) (329 260)) NIL ((-38. 0 0 0 0 0 )) NATURAL) (6 ((329 260) (324 280) (312 294) (288 305) (261 312) (236 316)) NIL ((-3.91866016 21.454544 0 0 -6.488039 -8.72727204 ) (-7.16267968 17.090908 -6.488039 -8.72727204 -9.5598049 7.63636208 ) (-18.430622 12.181818 -16.0478439 -1.09090924 14.727268 -3.81818056 ) (-27.11483 9.1818161 -1.32057404 -4.90909004 4.65071678 1.63636303 ) (-26.110046 5.090909 3.33014345 -3.27272701 -3.33014345 3.27272701 )) NATURAL) (2 ((236 316) (236 197)) NIL ((0 -119. 0 0 0 0 )) NATURAL) (11 ((236 197) (280 187) (313 177) (342 161) (366 136) (376 92) (370 55) (346 27) (313 9) (274 -1) (236 -6)) NIL ((46.700439 -10.36273 0 0 -16.202648 2.17638588 ) (38.599113 -9.27453805 -16.202648 2.17638588 15.013242 -10.881929 ) (29.903087 -12.5391159 -1.18940448 -8.7055435 -1.85032797 5.3513317 ) (27.78852 -18.568992 -3.03973246 -3.35421133 -13.6119308 -28.523391 ) (17.942817 -36.184898 -16.651664 -31.877605 2.29807663 48.74224 ) (2.44018984 -43.691383 -14.353588 16.864639 -7.58037568 -10.4455948 ) (-15.703586 -32.049545 -21.933963 6.41904355 16.023418 5.0401411 ) (-29.625843 -23.110427 -5.9105444 11.4591846 -2.51330852 -3.71496868 ) (-36.793037 -13.508728 -8.4238529 7.74421597 12.0298156 -2.18027019 ) (-39.20198 -6.8546486 3.60596323 5.56394577 -3.60596323 -5.56394577 )) NATURAL) (2 ((236 -6) (236 -35)) NIL ((0 -29. 0 0 0 0 )) NATURAL) (2 ((236 -35) (192 -35)) NIL ((-44. 0 0 0 0 0 )) NATURAL) (2 ((192 -35) (192 -6)) NIL ((0 29. 0 0 0 0 )) NATURAL) (6 ((192 -6) (141 -4) (99 8) (75 23) (55 49) (46 85)) NIL ((-52.143539 -0.626794100 0 0 6.8612442 15.760765 ) (-48.712913 7.2535877 6.8612442 15.760765 19.693779 -18.803825 ) (-32.004783 13.61244 26.555023 -3.04306173 -31.63636 17.45454 ) (-21.26794 19.296649 -5.08133984 14.4114818 22.851673 -3.0143528 ) (-14.9234447 32.20095 17.770336 11.397129 -17.770336 -11.397129 )) NATURAL) (2 ((46 85) (90 85)) NIL ((44. 0 0 0 0 0 )) NATURAL) (6 ((90 85) (93 69) (103 49) (127 33) (162 25) (192 22)) NIL ((1.89473676 -14.770334 0 0 6.63157845 -7.37798978 ) (5.21052647 -18.459327 6.63157845 -7.37798978 8.84210588 12.8899498 ) (16.2631569 -19.392341 15.473684 5.51196099 -1.90734863E-6 3.81818199 ) (31.736839 -11.9712906 15.473682 9.33014298 -26.842102 -4.16267872 ) (33.789466 -4.72248745 -11.3684196 5.16746426 11.3684196 -5.16746426 )) NATURAL) (2 ((192 22) (192 159)) NIL ((0 137. 0 0 0 0 )) NATURAL) (11 ((192 159) (151 173) (118 185) (93 197) (70 219) (61 263) (73 296) (94 315) (124 331) (160 341) (192 344)) NIL ((-42.561904 14.467121 0 0 9.37145997 -2.80273056 ) (-37.876174 13.0657558 9.37145997 -2.80273056 1.14269447 2.01365328 ) (-27.933368 11.2698516 10.514154 -0.789076925 -13.9422378 6.74811555 ) (-24.390335 13.854833 -3.4280839 5.95903874 18.626262 30.993877 ) (-18.505283 35.310806 15.198179 36.952919 11.437181 -58.72363 ) (2.41148281 42.901908 26.63536 -21.770717 -22.374977 5.900671 ) (17.859352 24.081527 4.26038075 -15.870046 6.06273175 17.120952 ) (25.1511 16.771957 10.323112 1.25090599 -1.87594414 -8.38448144 ) (34.536239 13.830625 8.44716836 -7.13357545 -16.5589599 -1.5830307 ) (34.703926 5.90553475 -8.1117916 -8.71660615 8.1117916 8.71660615 )) NATURAL) (2 ((192 344) (192 364)) NIL ((0 20. 0 0 0 0 )) NATURAL) (2 ((192 364) (236 364)) NIL ((44. 0 0 0 0 0 )) NATURAL)) ((2 ((192 316) (192 212)) NIL ((0 -104. 0 0 0 0 )) NATURAL) (9 ((192 212) (160 221) (133 229) (109 243) (103 266) (115 290) (134 304) (161 312) (192 316)) NIL ((-33.384933 9.54270936 0 0 8.3096447 -3.25625897 ) (-29.230114 7.9145794 8.3096447 -3.25625897 -11.548229 10.2812957 ) (-26.694583 9.79896928 -3.238585 7.0250368 25.883277 4.13107395 ) (-16.991527 18.889541 22.644695 11.1561107 -1.98490143 -8.8055935 ) (4.66071415 25.642856 20.659793 2.35051584 -17.943664 -16.908687 ) (16.348674 19.539024 2.71612644 -14.558174 7.75957204 10.440353 ) (22.944587 10.2010288 10.475698 -4.11781979 -7.09462357 -0.852724076 ) (29.872974 5.65684796 3.3810749 -4.97054386 -3.3810749 4.97054386 )) NATURAL)) ((10 ((236 143) (268 135) (301 125) (326 111) (339 86) (333 61) (313 41) (286 31) (262 26) (236 23)) NIL ((31.306991 -7.5433216 0 0 4.15804672 -2.74006653 ) (33.386009 -8.91335488 4.15804672 -2.74006653 -14.790233 1.70033264 ) (30.148944 -10.803255 -10.6321869 -1.03973388 1.00288772 -16.061264 ) (20.018199 -19.873619 -9.62929917 -17.1009979 -13.221313 20.544723 ) (3.77824688 -26.702255 -22.850612 3.44372892 9.88235665 -0.117646694 ) (-14.131187 -23.317348 -12.968256 3.32608223 3.69189644 9.92585755 ) (-25.253494 -15.028337 -9.27635957 13.2519397 17.350055 -9.58579064 ) (-25.854827 -6.56929303 8.07369615 3.66614914 -13.092119 -1.58268642 ) (-24.32719 -3.69448757 -5.01842404 2.08346271 5.01842404 -2.08346271 )) NATURAL) (2 ((236 23) (236 143)) NIL ((0 120. 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/GACHAE.S2-SF b/obsolete/lispusers/splinefonts/GACHAE.S2-SF deleted file mode 100644 index e293c5ed..00000000 --- a/obsolete/lispusers/splinefonts/GACHAE.S2-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY gacha) (CHARACTER 74Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:22:05) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((60 169) (312 0)) NIL ((252. -169. 0 0 0 0 )) NATURAL) (2 ((312 0) (372 0)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((372 0) (120 169)) NIL ((-252. 169. 0 0 0 0 )) NATURAL) (2 ((120 169) (370 337)) NIL ((250. 168. 0 0 0 0 )) NATURAL) (2 ((370 337) (310 337)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((310 337) (60 169)) NIL ((-250. -168. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 75Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:22:46) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((82 148) (82 148)) NIL ((0 0 0 0 0 0 )) NATURAL)) ((2 ((82 148) (357 148)) NIL ((275. 0 0 0 0 0 )) NATURAL) (2 ((357 148) (357 108)) NIL ((0 -40. 0 0 0 0 )) NATURAL) (2 ((357 108) (82 108)) NIL ((-275. 0 0 0 0 0 )) NATURAL) (2 ((82 108) (82 148)) NIL ((0 40. 0 0 0 0 )) NATURAL)) ((2 ((82 190) (357 190)) NIL ((275. 0 0 0 0 0 )) NATURAL) (2 ((357 190) (357 230)) NIL ((0 40. 0 0 0 0 )) NATURAL) (2 ((357 230) (82 230)) NIL ((-275. 0 0 0 0 0 )) NATURAL) (2 ((82 230) (82 190)) NIL ((0 -40. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 76Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:24:09) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((2 ((370 169) (118 0)) NIL ((-252. -169. 0 0 0 0 )) NATURAL) (2 ((118 0) (58 0)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((58 0) (310 169)) NIL ((252. 169. 0 0 0 0 )) NATURAL) (2 ((310 169) (60 337)) NIL ((-250. 168. 0 0 0 0 )) NATURAL) (2 ((60 337) (120 337)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((120 337) (370 169)) NIL ((250. -168. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 77Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:35:10) (MADE-FROM gacha.cu 0 140 0 0) (SPLINES ((13 ((248 24) (243 6) (228 -9) (204 -14) (180 -9) (165 6) (160 24) (165 42) (180 57) (204 62) (228 57) (243 42) (248 24)) NIL ((-2.93116188 -18.230766 0 0 -12.4130268 1.38461542 ) (-9.13767625 -17.538459 -12.4130268 1.38461542 2.06513786 11.076921 ) (-20.518135 -10.615383 -10.3478889 12.461538 10.152477 -3.69230843 ) (-25.789783 3.18512320E-7 -0.195410430 8.7692299 11.3249416 3.69230843 ) (-20.322723 10.615383 11.1295318 12.461538 -1.45225525 -11.076921 ) (-9.91931916 17.538459 9.6772766 1.38461518 0.484085083 -1.38461518 ) (3.18512320E-7 18.230766 10.1613617 -1.91652190E-7 -0.484086990 -1.38461423 ) (9.91931916 17.538459 9.6772747 -1.38461446 1.45225715 -11.076923 ) (20.322723 10.615383 11.1295318 -12.461538 -11.3249416 3.69230843 ) (25.789783 -3.18512320E-7 -0.195410639 -8.7692299 -10.152477 -3.69230843 ) (20.518131 -10.615383 -10.3478889 -12.461538 -2.06513786 11.076921 ) (9.13767434 -17.538459 -12.4130268 -1.38461518 12.4130268 1.38461518 )) NATURAL)) ((18 ((76 258) (82 281) (100 310) (141 337) (184 345) (222 347) (265 344) (301 336) (330 322) (351 301) (358 272) (351 242) (325 219) (291 200) (256 185) (234 163) (230 120) (230 82)) NIL ((4.36275196 21.588817 0 0 9.8234863 8.46708489 ) (9.27449418 25.82236 9.8234863 8.46708489 22.882568 -6.33543015 ) (30.539264 31.12173 32.706054 2.13165474 -35.353759 -31.125358 ) (45.568435 17.690704 -2.64770508 -28.993705 -7.4675293 28.836875 ) (39.186965 3.11543942 -10.115234 -0.156827688 23.223876 -6.22215367 ) (40.68367 -0.152465343 13.108642 -6.3789816 -25.427978 2.05173683 ) (41.078323 -5.505579 -12.3193378 -4.32724476 6.48805333 -1.9847908 ) (32.003013 -10.825218 -5.83128453 -6.31203557 -0.524238587 -0.112575531 ) (25.909606 -17.193542 -6.3555231 -6.4246111 -10.391092 -3.56490803 ) (14.358539 -25.400604 -16.746616 -9.9895191 6.0886116 8.3722038 ) (0.656227112 -31.20402 -10.6580047 -1.61731481 -13.963348 12.0760917 ) (-16.983448 -26.78329 -24.621353 10.458778 19.764766 -8.6765785 ) (-31.722419 -20.662803 -4.85658455 1.78219914 0.904281617 4.63022518 ) (-36.12686 -16.56549 -3.95230293 6.41242505 18.618099 -9.8443241 ) (-30.770114 -15.075229 14.665796 -3.43189907 8.6233196 -31.252922 ) (-11.7926578 -34.13359 23.289115 -34.684822 -23.111393 50.856025 ) (-0.0592400506 -43.390396 0.177720159 16.171203 -0.177720159 -16.171203 )) NATURAL) (2 ((230 82) (178 82)) NIL ((-52. 0 0 0 0 0 )) NATURAL) (9 ((178 82) (176 130) (179 173) (191 195) (215 207) (241 217) (277 231) (300 247) (306 274)) NIL ((-2.93114853 48.008277 0 0 5.58689213 -0.0497055054 ) (-0.137702286 47.983429 5.58689213 -0.0497055054 2.06553745 -29.751472 ) (6.4819584 33.057983 7.65242959 -29.801178 10.150957 23.055595 ) (19.209865 14.7846088 17.803386 -6.74558068 -24.669364 3.52908611 ) (24.678569 9.8035698 -6.86597825 -3.21649456 28.526504 10.828054 ) (32.075843 12.001104 21.660526 7.6115608 -41.43666 -10.8413086 ) (33.018035 14.1920089 -19.776138 -3.2297492 -0.779823304 20.537181 ) (12.8519859 21.230854 -20.555961 17.307434 20.555961 -17.307434 )) NATURAL) (8 ((306 274) (300 293) (276 312) (234 318) (202 317) (155 308) (133 281) (128 258)) NIL ((-2.76743364 18.186187 0 0 -19.395397 4.88285733 ) (-12.4651317 20.627616 -19.395397 4.88285733 -11.023014 -24.414283 ) (-37.372032 13.303329 -30.41841 -19.531429 63.487457 14.774301 ) (-36.046714 1.15905142 33.069046 -4.7571268 -74.926818 1.31707191 ) (-40.441085 -2.9395399 -41.85778 -3.44005489 86.219848 -26.042594 ) (-39.188934 -19.40089 44.362075 -29.48265 -29.952594 42.853309 ) (-9.8031597 -27.456886 14.409479 13.3706627 -14.409479 -13.3706627 )) NATURAL) (2 ((128 258) (76 258)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 100Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:41:59) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((25 ((274 84) (315 89) (349 101) (378 127) (388 169) (382 261) (346 310) (312 329) (274 340) (222 346) (169 340) (132 329) (97 310) (61 261) (49 169) (61 77) (99 29) (132 9) (169 -2) (222 -8) (273 -1) (312 10) (339 25) (357 40) (372 65)) NIL ((42.841934 4.12846947 0 0 -11.051645 5.22917843 ) (37.316116 6.74305916 -11.051645 5.22917843 13.25823 15.8541069 ) (32.893585 19.899292 2.2065854 21.083286 -29.98128 -26.645618 ) (20.109527 27.659767 -27.774696 -5.562335 22.666904 102.72837 ) (3.66828489 73.461624 -5.10779095 97.166046 -42.686332 -180.2678 ) (-22.782672 80.49371 -47.794128 -83.101837 64.07843 60.343216 ) (-38.537582 27.563484 16.284305 -22.758621 -21.627391 16.8949508 ) (-33.066978 13.252338 -5.3430872 -5.8636694 -13.568861 4.07696724 ) (-45.194496 9.42715455 -18.911949 -1.78670144 15.902847 -15.202821 ) (-56.15502 0.0390407219 -3.00910091 -16.9895248 27.957454 14.734329 ) (-45.185394 -9.5833187 24.948356 -2.25519466 -25.732685 -1.7344985 ) (-33.103378 -12.7057628 -0.784330249 -3.98969317 -9.0267067 -25.796333 ) (-38.401062 -29.593627 -9.81103707 -29.786029 43.839515 -27.080135 ) (-26.292339 -72.91972 34.02848 -56.866165 -16.33139 56.116867 ) (-0.429553986 -101.7274 17.69709 -0.749291659 21.486053 60.612625 ) (28.010566 -72.170425 39.183143 59.863334 -57.61283 -34.567375 ) (38.38729 -29.590789 -18.429687 25.295959 22.96529 -18.343135 ) (31.440254 -13.466398 4.53560543 6.95282174 19.751655 -6.06007004 ) (45.851684 -9.5436115 24.287262 0.892751694 -29.971923 18.583416 ) (55.152984 0.640850663 -5.68466473 19.476169 -7.86394025 -20.273609 ) (45.536346 9.98021318 -13.5486049 -0.797443152 1.42769622 8.51104165 ) (32.70159 13.438291 -12.1209087 7.71360016 2.15315056 -13.770559 ) (21.65726 14.266613 -9.96775819 -6.0569601 7.9596977 22.571197 ) (15.669353 19.49525 -2.00806045 16.51424 2.00806045 -16.51424 )) NATURAL) (2 ((372 65) (326 65)) NIL ((-46. 0 0 0 0 0 )) NATURAL) (13 ((326 65) (310 43) (285 30) (260 22) (223 17) (194 19) (167 25) (140 37) (120 53) (103 82) (98 111) (96 143) (95 169)) NIL ((-13.31982 -24.077533 0 0 -16.0810699 12.4652157 ) (-21.360355 -17.8449249 -16.0810699 12.4652157 26.405349 -8.32608224 ) (-24.23875 -9.5427513 10.3242817 4.1391325 -35.540336 -3.16088247 ) (-31.684639 -6.98406029 -25.21606 0.978249670 43.756027 8.96961595 ) (-35.022682 -1.52100181 18.53997 9.94786645 -19.483806 -8.7175865 ) (-26.224617 4.0680704 -0.943838716 1.23027920 -1.82078004 7.90073395 ) (-28.078846 9.24871636 -2.76461887 9.13101388 14.766931 -10.885349 ) (-23.459995 12.937055 12.0023136 -1.75433612 -15.246952 23.640663 ) (-19.081157 23.003051 -3.24463844 21.886329 22.220874 -29.677307 ) (-11.2153568 30.050727 18.976238 -7.79098035 -19.636566 17.068573 ) (-2.05740309 30.794033 -0.660330892 9.2775936 2.32541323 -20.596992 ) (-1.55502748 29.773132 1.66508269 -11.3193988 -1.66508269 11.3193988 )) NATURAL) (9 ((95 169) (96 195) (98 227) (103 256) (120 285) (140 301) (167 313) (194 319) (223 321)) NIL ((0.722201824 24.113586 0 0 1.66678905 11.318481 ) (1.55559635 29.772827 1.66678905 11.318481 -2.33394575 -20.592411 ) (2.05541229 30.7951 -0.667156935 -9.2739315 19.668994 17.051174 ) (11.222753 30.046756 19.001838 7.7772455 -22.34204 -29.612293 ) (19.053569 23.017852 -3.34020567 -21.835048 15.699186 23.398006 ) (23.562957 12.881811 12.358982 1.56295967 -16.454708 -9.97974778 ) (27.694583 9.454895 -4.09572888 -8.4167881 8.11966134 4.52098465 ) (27.658687 3.29860067 4.02393246 -3.89580298 -4.02393246 3.89580298 )) NATURAL) (7 ((223 321) (252 319) (279 313) (306 301) (326 285) (343 256) (348 227)) NIL ((29.670509 -1.34871792 0 0 -4.02307606 -3.90769243 ) (27.658973 -3.30256414 -4.02307606 -3.90769243 8.11538316 -4.46153736 ) (27.693588 -9.44102479 4.09230709 -8.36923028 -16.438457 9.7538433 ) (23.566665 -12.933332 -12.346153 1.38461446 15.63846 -22.55384 ) (19.039741 -22.825641 3.29230738 -21.169227 -22.115379 26.461532 ) (11.2743568 -30.764099 -18.823074 5.2923069 18.823074 -5.2923069 )) NATURAL) (12 ((348 227) (324 241) (300 250) (262 253) (217 242) (192 227) (174 204) (166 168) (181 124) (204 103) (231 91) (274 84)) NIL ((-24.775428 15.165264 0 0 4.6525793 -6.99158669 ) (-22.449138 11.6694698 4.6525793 -6.99158669 -23.262893 4.95793438 ) (-29.428009 7.1568508 -18.610317 -2.0336523 4.3990097 -18.8401489 ) (-45.83882 -4.2968769 -14.211307 -20.873802 47.666854 22.402671 ) (-36.216697 -13.969343 33.45555 1.52886963 -33.066444 -10.770544 ) (-19.294372 -17.825744 0.389100015 -9.2416744 6.59894753 -3.32049179 ) (-15.605798 -28.727664 6.9880476 -12.562166 24.670658 -5.9474926 ) (3.71757555 -44.26358 31.658706 -18.509658 -27.281574 57.110458 ) (21.735492 -34.218002 4.37713242 38.600799 -5.54436779 -36.494346 ) (23.340442 -13.8643818 -1.16723537 2.10645246 25.459041 4.86693383 ) (34.902725 -9.32446099 24.291809 6.97338677 -24.291809 -6.97338677 )) NATURAL)) ((21 ((203 170) (205 183) (211 201) (225 217) (249 226) (270 229) (291 226) (315 217) (329 201) (335 183) (337 170) (335 157) (329 139) (315 123) (291 114) (270 111) (249 114) (225 123) (211 139) (205 157) (203 170)) NIL ((1.29664564 11.627071 0 0 4.2201252 8.2375679 ) (3.40670824 15.745855 4.2201252 8.2375679 2.89937305 -11.187843 ) (9.076519 18.389499 7.11949826 -2.95027637 8.18238069 -5.48618603 ) (20.287208 12.6961307 15.3018799 -8.4364624 -23.628898 3.13259506 ) (23.774639 5.82596588 -8.32702066 -5.30386734 8.33322335 -1.04419803 ) (19.614231 -3.18512320E-7 0.00620389823 -6.34806538 8.29599954 1.04419803 ) (23.768432 -5.82596684 8.30220414 -5.30386734 -23.517223 -3.13259506 ) (20.312023 -12.6961326 -15.215021 -8.4364624 7.772912 5.48618603 ) (8.98345948 -18.389499 -7.4421091 -2.9502759 4.42556858 11.187843 ) (3.75413466 -15.745855 -3.01654005 8.2375679 -1.47518968 -8.2375679 ) (-8.00937414E-8 -11.627071 -4.49172974 0 1.47518968 -8.2375679 ) (-3.75413513 -15.745855 -3.01654005 -8.2375679 -4.42556763 11.187843 ) (-8.98345948 -18.389499 -7.44210816 2.95027685 -7.77291489 5.48618508 ) (-20.312023 -12.6961307 -15.215023 8.4364624 23.517227 -3.13259506 ) (-23.768432 -5.82596588 8.30220414 5.30386734 -8.29599954 1.04419803 ) (-19.614231 1.59256160E-7 0.00620390940 6.34806538 -8.33322335 -1.04419708 ) (-23.774639 5.82596684 -8.32702066 5.3038683 23.628898 3.1325941 ) (-20.287208 12.6961326 15.3018779 8.4364624 -8.18237878 -5.48618603 ) (-9.076519 18.389499 7.11949826 2.9502759 -2.89937305 -11.187843 ) (-3.40670824 15.745855 4.2201252 -8.2375679 -4.2201252 8.2375679 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 133Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:43:08) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((346 351) (94 351)) NIL ((-252. 0 0 0 0 0 )) NATURAL) (2 ((94 351) (94 -112)) NIL ((0 -463. 0 0 0 0 )) NATURAL) (2 ((94 -112) (346 -112)) NIL ((252. 0 0 0 0 0 )) NATURAL) (2 ((346 -112) (346 -76)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((346 -76) (141 -76)) NIL ((-205. 0 0 0 0 0 )) NATURAL) (2 ((141 -76) (141 315)) NIL ((0 391. 0 0 0 0 )) NATURAL) (2 ((141 315) (346 315)) NIL ((205. 0 0 0 0 0 )) NATURAL) (2 ((346 315) (346 351)) NIL ((0 36. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 134Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:44:28) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((117 337) (370 0)) NIL ((253. -337. 0 0 0 0 )) NATURAL) (2 ((370 0) (322 0)) NIL ((-48. 0 0 0 0 0 )) NATURAL) (2 ((322 0) (69 337)) NIL ((-253. 337. 0 0 0 0 )) NATURAL) (2 ((69 337) (117 337)) NIL ((48. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 135Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:45:24) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((346 351) (94 351)) NIL ((-252. 0 0 0 0 0 )) NATURAL) (2 ((94 351) (94 315)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((94 315) (299 315)) NIL ((205. 0 0 0 0 0 )) NATURAL) (2 ((299 315) (299 -76)) NIL ((0 -391. 0 0 0 0 )) NATURAL) (2 ((299 -76) (94 -76)) NIL ((-205. 0 0 0 0 0 )) NATURAL) (2 ((94 -76) (94 -112)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((94 -112) (346 -112)) NIL ((252. 0 0 0 0 0 )) NATURAL) (2 ((346 -112) (346 351)) NIL ((0 463. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 136Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:48:17) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((219 302) (71 183)) NIL ((-148. -119. 0 0 0 0 )) NATURAL) (2 ((71 183) (121 183)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((121 183) (198 239)) NIL ((77. 56. 0 0 0 0 )) NATURAL) (2 ((198 239) (198 42)) NIL ((0 -197. 0 0 0 0 )) NATURAL) (2 ((198 42) (240 42)) NIL ((42. 0 0 0 0 0 )) NATURAL) (2 ((240 42) (240 239)) NIL ((0 197. 0 0 0 0 )) NATURAL) (2 ((240 239) (316 183)) NIL ((76. -56. 0 0 0 0 )) NATURAL) (2 ((316 183) (366 183)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((366 183) (219 302)) NIL ((-147. 119. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 137Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:49:20) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((22 169) (198 285)) NIL ((176. 116. 0 0 0 0 )) NATURAL) (2 ((198 285) (198 233)) NIL ((0 -52. 0 0 0 0 )) NATURAL) (2 ((198 233) (130 191)) NIL ((-68. -42. 0 0 0 0 )) NATURAL) (2 ((130 191) (411 191)) NIL ((281. 0 0 0 0 0 )) NATURAL) (2 ((411 191) (411 147)) NIL ((0 -44. 0 0 0 0 )) NATURAL) (2 ((411 147) (130 147)) NIL ((-281. 0 0 0 0 0 )) NATURAL) (2 ((130 147) (198 105)) NIL ((68. -42. 0 0 0 0 )) NATURAL) (2 ((198 105) (198 53)) NIL ((0 -52. 0 0 0 0 )) NATURAL) (2 ((198 53) (22 169)) NIL ((-176. 116. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 173Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:53:08) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((7 ((313 351) (284 348) (250 338) (224 326) (205 311) (191 293) (182 259)) NIL ((-27.201278 -1.20512819 0 0 -10.7923069 -10.7692299 ) (-32.597435 -6.5897436 -10.7923069 -10.7692299 23.961536 11.846151 ) (-31.408973 -11.4358959 13.169229 1.07692265 -7.0538454 -6.61538315 ) (-21.766666 -13.666666 6.1153841 -5.53846073 -1.74615383 8.61538316 ) (-16.5243568 -14.897436 4.36923027 3.07692337 2.03846168 -27.846153 ) (-11.1358966 -25.743587 6.40769196 -24.769229 -6.40769196 24.769229 )) NATURAL) (2 ((182 259) (182 179)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (6 ((182 179) (176 162) (154 142) (130 133) (103 128) (79 126)) NIL ((-1.78468942 -15.4688987 0 0 -25.291862 -9.18660165 ) (-14.430622 -20.062198 -25.291862 -9.18660165 30.459323 27.93301 ) (-24.49282 -15.282295 5.1674633 18.74641 -12.545452 -18.545452 ) (-25.598083 -5.80861187 -7.37798978 0.200957238 13.722486 4.24880219 ) (-26.11483 -3.483253 6.34449769 4.44975949 -6.34449769 -4.44975949 )) NATURAL) (2 ((79 126) (79 106)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (6 ((79 106) (103 104) (130 99) (154 90) (176 70) (182 53)) NIL ((22.942581 -1.25837326 0 0 6.34449673 -4.44976044 ) (26.11483 -3.48325348 6.34449673 -4.44976044 -13.722486 4.24880314 ) (25.598083 -5.80861187 -7.37798978 -0.200957209 12.545454 -18.545452 ) (24.49282 -15.282297 5.16746426 -18.74641 -30.459327 27.933013 ) (14.430622 -20.062198 -25.291866 9.18660356 25.291866 -9.18660356 )) NATURAL) (2 ((182 53) (182 -27)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (7 ((182 -27) (191 -61) (205 -79) (224 -94) (250 -106) (284 -116) (313 -119)) NIL ((7.9320507 -38.128204 0 0 6.40769196 24.769229 ) (11.1358966 -25.743587 6.40769196 24.769229 -2.03846168 -27.846149 ) (16.5243568 -14.897434 4.36923027 -3.07692242 1.74615478 8.61538316 ) (21.766666 -13.666666 6.11538506 5.53846073 7.05384446 -6.61538315 ) (31.408973 -11.4358959 13.169229 -1.07692289 -23.961536 11.846151 ) (32.597435 -6.58974267 -10.7923069 10.7692299 10.7923069 -10.7692299 )) NATURAL) (2 ((313 -119) (332 -119)) NIL ((19. 0 0 0 0 0 )) NATURAL) (2 ((332 -119) (332 -83)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((332 -83) (307 -83)) NIL ((-25. 0 0 0 0 0 )) NATURAL) (5 ((307 -83) (276 -78) (255 -69) (237 -54) (229 -29)) NIL ((-33.642852 4.17857075 0 0 15.857141 4.92857075 ) (-25.714283 6.6428566 15.857141 4.92857075 -19.285709 -0.642856598 ) (-19.5 11.25 -3.42857075 4.28571415 19.285709 9.6428566 ) (-13.285713 20.357139 15.857141 13.9285717 -15.857141 -13.9285717 )) NATURAL) (2 ((229 -29) (229 41)) NIL ((0 70. 0 0 0 0 )) NATURAL) (6 ((229 41) (223 63) (210 84) (195 96) (180 106) (157 116)) NIL ((-4.30622006 21.660285 0 0 -10.1626777 2.03827715 ) (-9.3875599 22.679424 -10.1626777 2.03827715 8.81339456 -16.191383 ) (-15.143539 16.622005 -1.34928202 -14.153108 4.90909004 14.72727 ) (-14.038276 9.8325348 3.55980825 0.574162603 -16.449756 -0.717703223 ) (-18.703346 10.0478458 -12.8899517 -0.143540680 12.8899517 0.143540680 )) NATURAL) (6 ((157 116) (180 126) (195 136) (210 148) (223 169) (229 191)) NIL ((25.148323 9.9760761 0 0 -12.8899517 0.143540561 ) (18.703346 10.0478458 -12.8899517 0.143540561 16.449756 -0.717702747 ) (14.038276 9.8325348 3.55980825 -0.574162245 -4.90909004 14.72727 ) (15.143539 16.622009 -1.3492825 14.153108 -8.81339456 -16.191383 ) (9.38755799 22.679424 -10.1626777 -2.03827715 10.1626777 2.03827715 )) NATURAL) (2 ((229 191) (229 261)) NIL ((0 70. 0 0 0 0 )) NATURAL) (5 ((229 261) (237 286) (255 301) (276 310) (307 315)) NIL ((5.35714245 27.321426 0 0 15.857141 -13.9285698 ) (13.285713 20.357139 15.857141 -13.9285698 -19.285709 9.6428547 ) (19.5 11.249998 -3.42857075 -4.28571415 19.285709 -0.642856598 ) (25.714283 6.6428566 15.857141 -4.92857075 -15.857141 4.92857075 )) NATURAL) (2 ((307 315) (332 315)) NIL ((25. 0 0 0 0 0 )) NATURAL) (2 ((332 315) (332 351)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((332 351) (313 351)) NIL ((-19. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 174Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:54:25) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((195 351) (195 -112)) NIL ((0 -463. 0 0 0 0 )) NATURAL) (2 ((195 -112) (246 -112)) NIL ((51. 0 0 0 0 0 )) NATURAL) (2 ((246 -112) (246 351)) NIL ((0 463. 0 0 0 0 )) NATURAL) (2 ((246 351) (195 351)) NIL ((-51. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 175Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 7:58:20) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((139 351) (158 351)) NIL ((19. 0 0 0 0 0 )) NATURAL) (7 ((158 351) (187 348) (221 338) (247 326) (266 311) (280 293) (289 259)) NIL ((27.201278 -1.20512819 0 0 10.7923069 -10.7692299 ) (32.597435 -6.5897436 10.7923069 -10.7692299 -23.961536 11.846151 ) (31.408973 -11.4358959 -13.169229 1.07692265 7.0538454 -6.61538315 ) (21.766666 -13.666666 -6.1153841 -5.53846073 1.74615383 8.61538316 ) (16.5243568 -14.897436 -4.36923027 3.07692337 -2.03846168 -27.846153 ) (11.1358966 -25.743587 -6.40769196 -24.769229 6.40769196 24.769229 )) NATURAL) (2 ((289 259) (289 179)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (6 ((289 179) (295 162) (317 142) (341 133) (368 128) (392 126)) NIL ((1.78468942 -15.4688987 0 0 25.291862 -9.18660165 ) (14.430622 -20.062198 25.291862 -9.18660165 -30.459323 27.93301 ) (24.49282 -15.282295 -5.1674633 18.74641 12.545452 -18.545452 ) (25.598083 -5.80861187 7.37798978 0.200957238 -13.722486 4.24880219 ) (26.11483 -3.483253 -6.34449769 4.44975949 6.34449769 -4.44975949 )) NATURAL) (2 ((392 126) (392 106)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (6 ((392 106) (368 104) (341 99) (317 90) (295 70) (289 53)) NIL ((-22.942581 -1.25837326 0 0 -6.34449673 -4.44976044 ) (-26.11483 -3.48325348 -6.34449673 -4.44976044 13.722486 4.24880314 ) (-25.598083 -5.80861187 7.37798978 -0.200957209 -12.545454 -18.545452 ) (-24.49282 -15.282297 -5.16746426 -18.74641 30.459327 27.933013 ) (-14.430622 -20.062198 25.291866 9.18660356 -25.291866 -9.18660356 )) NATURAL) (2 ((289 53) (289 -27)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (7 ((289 -27) (280 -61) (266 -79) (247 -94) (221 -106) (187 -116) (158 -119)) NIL ((-7.9320507 -38.128204 0 0 -6.40769196 24.769229 ) (-11.1358966 -25.743587 -6.40769196 24.769229 2.03846168 -27.846149 ) (-16.5243568 -14.897434 -4.36923027 -3.07692242 -1.74615478 8.61538316 ) (-21.766666 -13.666666 -6.11538506 5.53846073 -7.05384446 -6.61538315 ) (-31.408973 -11.4358959 -13.169229 -1.07692289 23.961536 11.846151 ) (-32.597435 -6.58974267 10.7923069 10.7692299 -10.7923069 -10.7692299 )) NATURAL) (2 ((158 -119) (139 -119)) NIL ((-19. 0 0 0 0 0 )) NATURAL) (2 ((139 -119) (139 -83)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((139 -83) (164 -83)) NIL ((25. 0 0 0 0 0 )) NATURAL) (5 ((164 -83) (195 -78) (216 -69) (234 -54) (242 -29)) NIL ((33.642852 4.17857075 0 0 -15.857141 4.92857075 ) (25.714283 6.6428566 -15.857141 4.92857075 19.285709 -0.642856598 ) (19.5 11.25 3.42857075 4.28571415 -19.285709 9.6428566 ) (13.285713 20.357139 -15.857141 13.9285717 15.857141 -13.9285717 )) NATURAL) (2 ((242 -29) (242 41)) NIL ((0 70. 0 0 0 0 )) NATURAL) (6 ((242 41) (248 63) (261 84) (276 96) (291 106) (314 116)) NIL ((4.30622006 21.660285 0 0 10.1626777 2.03827715 ) (9.3875599 22.679424 10.1626777 2.03827715 -8.81339456 -16.191383 ) (15.143539 16.622005 1.34928202 -14.153108 -4.90909004 14.72727 ) (14.038276 9.8325348 -3.55980825 0.574162603 16.449756 -0.717703223 ) (18.703346 10.0478458 12.8899517 -0.143540680 -12.8899517 0.143540680 )) NATURAL) (6 ((314 116) (291 126) (276 136) (261 148) (248 169) (242 191)) NIL ((-25.148323 9.9760761 0 0 12.8899517 0.143540561 ) (-18.703346 10.0478458 12.8899517 0.143540561 -16.449756 -0.717702747 ) (-14.038276 9.8325348 -3.55980825 -0.574162245 4.90909004 14.72727 ) (-15.143539 16.622009 1.3492825 14.153108 8.81339456 -16.191383 ) (-9.38755799 22.679424 10.1626777 -2.03827715 -10.1626777 2.03827715 )) NATURAL) (2 ((242 191) (242 261)) NIL ((0 70. 0 0 0 0 )) NATURAL) (5 ((242 261) (234 286) (216 301) (195 310) (164 315)) NIL ((-5.35714245 27.321426 0 0 -15.857141 -13.9285698 ) (-13.285713 20.357139 -15.857141 -13.9285698 19.285709 9.6428547 ) (-19.5 11.249998 3.42857075 -4.28571415 -19.285709 -0.642856598 ) (-25.714283 6.6428566 -15.857141 -4.92857075 15.857141 4.92857075 )) NATURAL) (2 ((164 315) (139 315)) NIL ((-25. 0 0 0 0 0 )) NATURAL) (2 ((139 315) (139 351)) NIL ((0 36. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 176Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 8:03:50) (MADE-FROM gachalc.cu 0 140 0 0) (SPLINES ((2 ((70 84) (30 84)) NIL ((-40. 0 0 0 0 0 )) NATURAL) (13 ((30 84) (39 111) (55 131) (76 147) (106 158) (144 161) (184 156) (222 142) (249 131) (286 122) (327 124) (356 145) (366 161)) NIL ((7.34924794 28.65084 0 0 9.9045086 -9.9050579 ) (12.301502 23.69831 9.9045086 -9.9050579 -7.5225458 7.52529336 ) (18.444736 17.5559 2.3819623 -2.37976408 8.18567658 -2.19611978 ) (24.91954 14.078077 10.56764 -4.57588387 -1.22017288 -4.7408142 ) (34.87709 7.1317854 9.3474674 -9.31669808 -9.30498506 3.15938091 ) (39.572067 -0.605221987 0.0424815491 -6.15731717 2.44012308 -7.8967161 ) (40.83461 -10.710897 2.48260498 -14.054033 -24.455505 22.427482 ) (31.089466 -13.551187 -21.9729 8.37345124 41.381904 -9.8132267 ) (29.807518 -10.0843486 19.409004 -1.43977689 -15.07213 10.8254299 ) (41.680458 -6.1114111 4.33687306 9.38565446 -17.093372 20.511505 ) (37.470642 13.5299949 -12.7565 29.897159 -12.5543709 -44.871444 ) (18.436954 20.991428 -25.31087 -14.9742908 25.31087 14.9742908 )) NATURAL) (2 ((366 161) (406 161)) NIL ((40. 0 0 0 0 0 )) NATURAL) (7 ((406 161) (397 134) (381 114) (360 98) (330 87) (292 84) (252 89)) NIL ((-7.3487177 -28.653842 0 0 -9.90769197 9.9230766 ) (-12.3025627 -23.692306 -9.90769197 9.9230766 7.53846074 -7.6153841 ) (-18.441024 -17.576919 -2.36923075 2.30769205 -8.24615098 2.5384612 ) (-24.93333 -13.999998 -10.615383 4.84615326 1.44615364 3.46153832 ) (-34.825637 -7.42307664 -9.1692295 8.30769158 8.4615364 1.61538505 ) (-39.764099 1.69230771 -0.707692385 9.9230766 0.707692385 -9.9230766 )) NATURAL) (7 ((252 89) (214 103) (187 114) (150 123) (109 121) (80 100) (70 84)) NIL ((-41.551277 14.767948 0 0 21.307689 -4.60769177 ) (-30.897434 12.4641018 21.307689 -4.60769177 -40.538452 5.03846073 ) (-29.858974 10.3756408 -19.230766 0.430769324 14.846151 -9.546154 ) (-41.666664 6.03333283 -4.38461495 -9.11538507 17.1538429 -20.853843 ) (-37.474357 -13.508974 12.7692299 -29.96923 12.5384597 44.961532 ) (-18.435894 -20.997432 25.307689 14.992307 -25.307689 -14.992307 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/GACHAE.UC1-SF b/obsolete/lispusers/splinefonts/GACHAE.UC1-SF deleted file mode 100644 index 9cc43ef0..00000000 --- a/obsolete/lispusers/splinefonts/GACHAE.UC1-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY gacha) (CHARACTER 101Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 10:14:09) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((25 0) (157 337)) NIL ((132. 337. 0 0 0 0 )) NATURAL) (2 ((157 337) (280 337)) NIL ((123. 0 0 0 0 0 )) NATURAL) (2 ((280 337) (412 0)) NIL ((132. -337. 0 0 0 0 )) NATURAL) (2 ((412 0) (359 0)) NIL ((-53. 0 0 0 0 0 )) NATURAL) (2 ((359 0) (321 98)) NIL ((-38. 98. 0 0 0 0 )) NATURAL) (2 ((321 98) (116 98)) NIL ((-205. 0 0 0 0 0 )) NATURAL) (2 ((116 98) (78 0)) NIL ((-38. -98. 0 0 0 0 )) NATURAL) (2 ((78 0) (25 0)) NIL ((-53. 0 0 0 0 0 )) NATURAL)) ((2 ((305 141) (132 141)) NIL ((-173. 0 0 0 0 0 )) NATURAL) (2 ((132 141) (194 301)) NIL ((62. 160. 0 0 0 0 )) NATURAL) (2 ((194 301) (243 301)) NIL ((49. 0 0 0 0 0 )) NATURAL) (2 ((243 301) (305 141)) NIL ((62. -160. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 102Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 10:21:33) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((60 337) (60 337) (60 0)) NIL ((0 84.25 0 0 0 -505.5 ) (0 -168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((60 0) (225 0)) NIL ((165. 0 0 0 0 0 )) NATURAL) (11 ((225 0) (268 5) (307 15) (340 32) (364 59) (376 97) (370 132) (355 154) (339 167) (312 178) (283 185)) NIL ((43.77365 4.02735329 0 0 -4.64191437 5.83587933 ) (41.45269 6.94529343 -4.64191437 5.83587933 -0.790425301 0.820601464 ) (36.415565 13.191473 -5.43233967 6.6564808 -4.19638348 2.88171577 ) (28.885032 21.28881 -9.62872315 9.53819657 -0.424039841 5.65253067 ) (19.044288 33.653274 -10.052763 15.190727 -12.107458 -19.491832 ) (2.9377985 39.098083 -22.160221 -4.3011055 12.85387 -11.6851997 ) (-12.795486 28.954376 -9.3063507 -15.986305 14.691978 6.2326393 ) (-14.7558479 16.084388 5.3856287 -9.7536659 -23.621791 10.754642 ) (-21.181118 11.7080478 -18.236164 1.00097775 19.795204 -7.25122166 ) (-29.51968 9.08341409 1.5590415 -6.25024415 -1.5590415 6.25024415 )) NATURAL) (12 ((283 185) (318 199) (336 212) (349 227) (358 254) (352 287) (338 306) (319 319) (297 328) (279 332) (256 335) (225 337)) NIL ((39.205406 14.229002 0 0 -25.232437 -1.37401437 ) (26.589183 13.541994 -25.232437 -1.37401437 24.162193 0.870072127 ) (13.437845 12.6030159 -1.07024192 -0.503942251 0.583649278 15.893724 ) (12.6594276 20.045936 -0.486592591 15.3897838 -20.496791 -4.44498253 ) (1.924438 33.213226 -20.983387 10.944801 15.403532 -34.113792 ) (-11.357181 27.101131 -5.579854 -23.16899 0.882661820 20.900169 ) (-16.495704 14.3822269 -4.69719219 -2.26882028 -0.934181214 -1.48690176 ) (-21.659988 11.369955 -5.6313734 -3.75572205 14.854061 -2.9525671 ) (-19.86433 6.13794995 9.22268868 -6.70828915 -16.4820709 7.29716588 ) (-18.882679 3.07824373 -7.25938416 0.588877082 -2.9257679 -2.2360959 ) (-27.604946 2.54907274 -10.185152 -1.64721918 10.185152 1.64721918 )) NATURAL) (2 ((225 337) (60 337)) NIL ((-165. 0 0 0 0 0 )) NATURAL)) ((6 ((236 168) (269 163) (292 153) (304 143) (314 128) (319 101)) NIL ((34.904304 -3.62200928 0 0 -11.4258365 -8.26794244 ) (29.191387 -7.7559805 -11.4258365 -8.26794244 -2.87081337 11.339712 ) (16.330143 -10.3540668 -14.2966499 3.07177019 16.909088 -7.090909 ) (10.488037 -10.827751 2.6124401 -4.01913929 -10.7655506 -12.976072 ) (7.71770287 -21.334926 -8.1531105 -16.995212 8.1531105 16.995212 )) NATURAL) (6 ((319 101) (316 75) (304 57) (287 45) (268 39) (236 36)) NIL ((-0.971291781 -27.813396 0 0 -12.1722488 10.8803825 ) (-7.05741597 -22.373203 -12.1722488 10.8803825 6.8612442 -6.40191365 ) (-15.799041 -14.693779 -5.31100464 4.4784689 8.72727204 2.72727203 ) (-16.74641 -8.8516731 3.4162674 7.20574093 -23.770332 -4.5071764 ) (-25.215309 -3.89952135 -20.354064 2.69856453 20.354064 -2.69856453 )) NATURAL) (3 ((236 36) (211 36) (113 36)) NIL ((-6.75 0 0 0 -109.5 0 ) (-61.5 0 -109.5 0 109.5 0 )) NATURAL) (2 ((113 36) (113 168)) NIL ((0 132. 0 0 0 0 )) NATURAL) (2 ((113 168) (236 168)) NIL ((123. 0 0 0 0 0 )) NATURAL)) ((2 ((113 204) (113 302)) NIL ((0 98. 0 0 0 0 )) NATURAL) (2 ((113 302) (220 302)) NIL ((107. 0 0 0 0 0 )) NATURAL) (2 ((220 302) (245 302)) NIL ((25. 0 0 0 0 0 )) NATURAL) (5 ((245 302) (266 299) (291 291) (305 274) (308 253)) NIL ((19.339283 -2.23214292 0 0 9.9642849 -4.60714245 ) (24.321426 -4.53571415 9.9642849 -4.60714245 -25.821426 -6.96428586 ) (21.374996 -12.625 -15.857141 -11.571428 3.3214283 8.4642849 ) (7.17857075 -19.964283 -12.535713 -3.10714245 12.535713 3.10714245 )) NATURAL) (5 ((308 253) (303 231) (290 217) (266 208) (245 204)) NIL ((-3.6964283 -23.875 0 0 -7.82142926 11.25 ) (-7.60714245 -18.25 -7.82142926 11.25 -8.89285279 -8.25 ) (-19.875 -11.124998 -16.714283 3. 25.392852 3.74999905 ) (-23.892856 -6.24999905 8.6785698 6.74999905 -8.6785698 -6.74999905 )) NATURAL) (2 ((245 204) (220 204)) NIL ((-25. 0 0 0 0 0 )) NATURAL) (2 ((220 204) (113 204)) NIL ((-107. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 103Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 11:50:25) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((25 ((378 260) (370 287) (352 310) (318 332) (271 343) (229 345) (186 342) (141 330) (109 310) (85 285) (69 260) (60 236) (49 169) (60 102) (69 78) (85 53) (109 28) (141 8) (186 -4) (229 -7) (271 -5) (318 6) (352 28) (370 51) (378 78)) NIL ((-6.19386483 28.169479 0 0 -10.836809 -7.01689053 ) (-11.61227 24.661033 -10.836809 -7.01689053 -5.8159504 11.0844516 ) (-25.357055 23.18637 -16.652759 4.0675621 -1.89938736 -19.320919 ) (-42.95951 17.593471 -18.5521469 -15.2533588 31.413505 6.199234 ) (-45.8049 5.43973065 12.8613586 -9.05412484 -15.754644 6.5239849 ) (-40.82086 -0.352400899 -2.8932867 -2.53013944 -4.39492512 -8.29517556 ) (-45.911613 -7.03012753 -7.2882118 -10.825315 27.334346 2.65671539 ) (-39.532653 -16.527084 20.046134 -8.16860009 -14.942476 3.6683216 ) (-26.957756 -22.861526 5.10365868 -4.50027848 2.43556595 0.669996739 ) (-20.636314 -27.026805 7.5392246 -3.83028174 5.20021248 23.651683 ) (-10.4969825 -19.031242 12.739437 19.821403 -29.236415 -89.27673 ) (-12.375753 -43.848213 -16.496978 -69.455337 57.74546 69.45532 ) (3.18139791E-6 -78.57588 41.24848 -4.08857977E-6 -57.74546 69.45535 ) (12.375753 -43.848213 -16.496982 69.45535 29.236419 -89.27676 ) (10.4969825 -19.031242 12.739439 -19.821411 -5.20021439 23.651691 ) (20.636314 -27.026805 7.5392246 3.83028364 -2.43556785 0.669993878 ) (26.957756 -22.861522 5.10365677 4.50027752 14.942482 3.66832447 ) (39.532653 -16.527084 20.046138 8.168602 -27.33435 2.65670967 ) (45.911613 -7.03012658 -7.28821374 10.8253116 4.39492703 -8.29516984 ) (40.82086 -0.352400601 -2.89328623 2.5301404 15.754644 6.52398205 ) (45.8049 5.4397316 12.8613586 9.0541229 -31.413505 6.19923783 ) (42.959503 17.593471 -18.5521469 15.2533607 1.89938736 -19.320922 ) (25.357051 23.18637 -16.652759 -4.0675621 5.8159504 11.0844516 ) (11.612268 24.661033 -10.836809 7.01689053 10.836809 -7.01689053 )) NATURAL) (2 ((378 78) (326 78)) NIL ((-52. 0 0 0 0 0 )) NATURAL) (14 ((326 78) (320 55) (309 40) (286 28) (256 24) (230 23) (199 26) (177 32) (150 46) (132 64) (116 90) (106 120) (102 142) (101 169)) NIL ((-5.3555641 -25.071785 0 0 -3.86661339 12.4307289 ) (-7.2888708 -18.856422 -3.86661339 12.4307289 -10.666933 -14.153646 ) (-16.4889488 -13.5025177 -14.533546 -1.72291755 4.53435135 14.1838588 ) (-28.755321 -8.13350488 -9.9991951 12.460941 22.529521 -12.5817928 ) (-27.489753 -1.9634602 12.5303287 -0.120852127 -28.652446 6.14331818 ) (-29.285652 0.987347246 -16.1221199 6.02246667 38.080276 -5.99148369 ) (-26.36763 4.01407147 21.95816 0.0309827476 -39.668693 11.822618 ) (-24.243816 9.95636369 -17.710533 11.853601 36.594505 -11.298988 ) (-23.657093 16.160469 18.883976 0.554612279 -22.709346 9.37333489 ) (-16.127792 21.401752 -3.82537174 9.927948 12.2428798 -2.19436264 ) (-13.831724 30.232517 8.41750909 7.73358536 -2.26217842 -24.595874 ) (-6.5453043 25.668167 6.15533066 -16.862289 -3.1941638 28.577858 ) (-1.98705554 23.094806 2.96116686 11.71557 -2.96116686 -11.71557 )) NATURAL) (14 ((101 169) (102 196) (106 218) (116 248) (132 274) (150 292) (177 306) (199 312) (230 315) (256 314) (286 310) (309 298) (321 284) (326 260)) NIL ((0.506471396 28.95259 0 0 2.96117163 -11.7155666 ) (1.98705721 23.09481 2.96117163 -11.7155666 3.19414091 28.577835 ) (6.54529954 25.668159 6.15531254 16.86227 2.2622652 -24.595783 ) (13.831745 30.232536 8.41757775 -7.73351479 -12.243206 -2.1946907 ) (16.1277199 21.401676 -3.82562828 -9.9282055 22.710559 9.37454988 ) (23.657371 16.160743 18.884933 -0.553655625 -36.599037 -11.303514 ) (24.242786 9.9553318 -17.714103 -11.85717 39.685585 11.8395099 ) (26.371479 4.01791764 21.971485 -0.0176593437 -38.143325 -6.0545311 ) (29.271297 0.972992898 -16.171844 -6.07219124 28.887744 6.37861539 ) (27.543323 -1.90989017 12.7159 0.306424796 -23.407657 -13.45993 ) (28.555393 -8.33343125 -10.691759 -13.153507 -1.25710296 17.461109 ) (17.235084 -12.7563839 -11.948862 4.30760193 4.43607807 -20.384502 ) (7.504261 -18.641033 -7.512784 -16.0769 7.512784 16.0769 )) NATURAL) (2 ((326 260) (378 260)) NIL ((52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 105Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:00:54) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((82 337) (82 337) (82 0)) NIL ((0 84.25 0 0 0 -505.5 ) (0 -168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((82 0) (369 0)) NIL ((287. 0 0 0 0 0 )) NATURAL) (2 ((369 0) (369 36)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((369 36) (134 36)) NIL ((-235. 0 0 0 0 0 )) NATURAL) (2 ((134 36) (134 161)) NIL ((0 125. 0 0 0 0 )) NATURAL) (2 ((134 161) (315 161)) NIL ((181. 0 0 0 0 0 )) NATURAL) (2 ((315 161) (315 197)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((315 197) (134 197)) NIL ((-181. 0 0 0 0 0 )) NATURAL) (2 ((134 197) (134 301)) NIL ((0 104. 0 0 0 0 )) NATURAL) (2 ((134 301) (355 301)) NIL ((221. 0 0 0 0 0 )) NATURAL) (2 ((355 301) (355 337)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((355 337) (82 337)) NIL ((-273. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 106Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:01:55) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((328 197) (328 161)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((328 161) (147 161)) NIL ((-181. 0 0 0 0 0 )) NATURAL) (2 ((147 161) (147 0)) NIL ((0 -161. 0 0 0 0 )) NATURAL) (2 ((147 0) (96 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (3 ((96 0) (96 337) (96 337)) NIL ((0 421.25 0 0 0 -505.5 ) (0 168.5 0 -505.5 0 505.5 )) NATURAL) (2 ((96 337) (369 337)) NIL ((273. 0 0 0 0 0 )) NATURAL) (2 ((369 337) (369 301)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((369 301) (147 301)) NIL ((-222. 0 0 0 0 0 )) NATURAL) (2 ((147 301) (147 197)) NIL ((0 -104. 0 0 0 0 )) NATURAL) (2 ((147 197) (328 197)) NIL ((181. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 107Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:14:10) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((354 0) (388 0)) NIL ((34. 0 0 0 0 0 )) NATURAL) (2 ((388 0) (388 169)) NIL ((0 169. 0 0 0 0 )) NATURAL) (2 ((388 169) (208 169)) NIL ((-180. 0 0 0 0 0 )) NATURAL) (2 ((208 169) (208 134)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((208 134) (336 134)) NIL ((128. 0 0 0 0 0 )) NATURAL) (8 ((336 134) (336 109) (330 76) (314 51) (285 33) (249 24) (224 22) (199 26)) NIL ((1.08862924 -22.377876 0 0 -6.53177548 -15.732736 ) (-2.17725849 -30.244243 -6.53177548 -15.732736 -3.34112072 30.663684 ) (-10.3795948 -30.645137 -9.8728962 14.93095 -4.1037426 -10.922018 ) (-22.304363 -21.175193 -13.9766388 4.00893116 1.75609588 7.0243902 ) (-35.402954 -13.6540699 -12.2205429 11.033321 33.079353 -5.17554093 ) (-31.083816 -5.20851898 20.85881 5.85778046 -26.073513 1.67777347 ) (-23.261764 1.48814869 -5.2147026 7.53555394 5.2147026 -7.53555394 )) NATURAL) (23 ((199 26) (177 32) (150 46) (131 63) (114 88) (104 118) (100 141) (99 169) (101 196) (104 218) (114 250) (129 277) (148 294) (173 306) (199 312) (230 315) (259 314) (289 309) (309 299) (320 286) (325 270) (325 270) (326 260)) NIL ((-20.09576 3.9550767 0 0 -11.425428 12.2695389 ) (-25.808475 10.0898456 -11.425428 12.2695389 27.127147 -13.347694 ) (-23.67033 15.685537 15.701719 -1.07815694 -19.083168 11.121244 ) (-17.5101928 20.168003 -3.38144875 10.0430889 13.205524 -1.13729667 ) (-14.288881 29.642444 9.8240757 8.90579225 -3.73893929 -24.572052 ) (-6.3342743 26.26221 6.0851364 -15.666261 -4.24976254 27.425514 ) (-2.37401914 24.308708 1.83537364 11.759254 2.73799419 -13.130014 ) (0.830351830 29.502952 4.57336807 -1.37075996 -6.7022152 -10.9054546 ) (2.0526123 22.679466 -2.12884712 -12.2762146 12.070867 32.75183 ) (5.959198 26.77917 9.9420204 20.475616 -5.58125305 -30.101875 ) (13.1105919 32.203842 4.36076737 -9.62625886 -1.74585771 -2.3443203 ) (16.59843 21.405426 2.61490965 -11.970579 6.564682 9.4791603 ) (22.495681 14.1744289 9.17959214 -2.49141884 -12.5128708 -5.57232285 ) (25.418838 8.89684678 -3.3332796 -8.06374169 13.4868049 6.81013394 ) (28.82896 4.23817349 10.153526 -1.25360703 -17.4343529 -3.668221 ) (30.265308 1.15045547 -7.2808275 -4.92182827 14.250612 1.86275148 ) (30.109787 -2.83999729 6.9697857 -3.05907679 -21.5681 -3.78278589 ) (26.295524 -7.7904663 -14.598314 -6.84186268 6.02178765 7.26839066 ) (14.708103 -10.9981346 -8.57652665 0.426528394 3.48095322 -13.290775 ) (7.8720541 -17.216991 -5.09557343 -12.864248 -1.94560623 45.894706 ) (1.80367732 -7.13388539 -7.04117966 33.030464 10.3014736 -56.288078 ) (-0.0867649615 -2.24746179 3.26029491 -23.257614 -3.26029491 23.257614 )) NATURAL) (2 ((326 260) (378 260)) NIL ((52. 0 0 0 0 0 )) NATURAL) (25 ((378 260) (370 287) (352 310) (318 332) (271 343) (229 345) (186 342) (144 331) (109 310) (85 285) (69 260) (60 236) (53 209) (49 169) (52 127) (64 83) (83 52) (108 28) (141 9) (183 -3) (229 -7) (271 -1) (300 9) (326 26) (344 49)) NIL ((-6.1920843 28.170055 0 0 -10.84749 -7.02033616 ) (-11.615829 24.659885 -10.84749 -7.02033616 -5.76254845 11.1016826 ) (-25.344593 23.190391 -16.610038 4.08134747 -2.10231399 -19.386398 ) (-43.00579 17.578537 -18.712352 -15.305053 32.171806 6.44392205 ) (-45.632232 5.4954462 13.459455 -8.86113168 -18.584922 5.6107149 ) (-41.46524 -0.560327769 -5.12547016 -3.25041676 6.16789437 -4.88678265 ) (-43.506767 -6.25413609 1.0424242 -8.1371994 5.9133482 -4.06358147 ) (-39.507667 -16.423126 6.9557724 -12.2007808 6.17871476 9.14110566 ) (-29.462539 -24.053352 13.134487 -3.05967522 -6.62821198 3.49915838 ) (-19.642158 -25.363449 6.50627518 0.439483404 2.33413124 0.862258196 ) (-11.9688167 -24.492836 8.8404064 1.3017416 -8.708313 -0.948191763 ) (-7.48256779 -23.665191 0.132091939 0.353549778 2.49913216 -21.069484 ) (-6.10090924 -33.846382 2.63122415 -20.715938 4.71178627 25.226146 ) (-1.11379099 -41.949249 7.3430109 4.51021099 2.65371418 -13.835115 ) (7.556077 -44.356597 9.99672509 -9.3249054 -3.32663918 30.114315 ) (15.889482 -38.624343 6.6700859 20.789409 -1.34715652 -16.622142 ) (21.88599 -26.146007 5.32292938 4.16726685 2.71526527 0.374253273 ) (28.56655 -21.791614 8.03819467 4.54152012 2.48609352 3.12512875 ) (37.847793 -15.687528 10.524288 7.66664887 -6.6596422 -0.874764443 ) (45.042259 -8.4582615 3.86464596 6.7918844 -5.84751797 6.3739252 ) (45.983146 1.52058458 -1.98287248 13.165809 -17.950279 -12.620937 ) (35.02513 8.37592507 -19.933155 0.544872284 23.648662 8.10982705 ) (26.916309 12.9757118 3.71550894 8.6546993 -16.644382 -1.81837463 ) (22.309623 20.721221 -12.9288768 6.8363247 12.9288768 -6.8363247 )) NATURAL) (2 ((344 49) (354 0)) NIL ((10. -49. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 110Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:14:57) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((61 0) (61 337)) NIL ((0 337. 0 0 0 0 )) NATURAL) (2 ((61 337) (113 337)) NIL ((52. 0 0 0 0 0 )) NATURAL) (2 ((113 337) (113 197)) NIL ((0 -140. 0 0 0 0 )) NATURAL) (2 ((113 197) (326 197)) NIL ((213. 0 0 0 0 0 )) NATURAL) (2 ((326 197) (326 337)) NIL ((0 140. 0 0 0 0 )) NATURAL) (2 ((326 337) (378 337)) NIL ((52. 0 0 0 0 0 )) NATURAL) (2 ((378 337) (378 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL) (2 ((378 0) (326 0)) NIL ((-52. 0 0 0 0 0 )) NATURAL) (2 ((326 0) (326 161)) NIL ((0 161. 0 0 0 0 )) NATURAL) (2 ((326 161) (113 161)) NIL ((-213. 0 0 0 0 0 )) NATURAL) (2 ((113 161) (113 0)) NIL ((0 -161. 0 0 0 0 )) NATURAL) (2 ((113 0) (61 0)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 111Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:21:10) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((194 35) (94 35)) NIL ((-100. 0 0 0 0 0 )) NATURAL) (2 ((94 35) (94 0)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((94 0) (346 0)) NIL ((252. 0 0 0 0 0 )) NATURAL) (2 ((346 0) (346 35)) NIL ((0 35. 0 0 0 0 )) NATURAL) (2 ((346 35) (245 35)) NIL ((-101. 0 0 0 0 0 )) NATURAL) (2 ((245 35) (245 302)) NIL ((0 267. 0 0 0 0 )) NATURAL) (2 ((245 302) (346 302)) NIL ((101. 0 0 0 0 0 )) NATURAL) (2 ((346 302) (346 337)) NIL ((0 35. 0 0 0 0 )) NATURAL) (2 ((346 337) (94 337)) NIL ((-252. 0 0 0 0 0 )) NATURAL) (2 ((94 337) (94 302)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((94 302) (194 302)) NIL ((100. 0 0 0 0 0 )) NATURAL) (2 ((194 302) (194 35)) NIL ((0 -267. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 112Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:24:11) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((13 ((367 83) (358 56) (342 35) (318 18) (286 5) (249 -4) (213 -7) (177 -4) (139 5) (108 18) (84 35) (67 56) (58 83)) NIL ((-7.5716381 -28.383419 0 0 -8.57017137 8.30051805 ) (-11.8567238 -24.233158 -8.57017137 8.30051805 0.850863457 -5.50259018 ) (-20.001464 -18.683937 -7.7193079 2.79792738 -0.833287240 1.70984411 ) (-28.137416 -15.0310878 -8.55259515 4.50777149 2.48228836 -1.33678722 ) (-35.448867 -11.191709 -6.07030678 3.17098427 8.90413095 3.63730621 ) (-37.067108 -6.20207215 2.83382416 6.80829049 -2.09881306 -1.21243572 ) (-35.282692 0 0.735010863 5.59585476 -6.50887776 1.21243572 ) (-37.802116 6.20207215 -5.7738676 6.80829049 16.1343269 -3.63730621 ) (-35.508819 11.191709 10.360462 3.17098427 -4.02844429 1.33678722 ) (-27.162582 15.0310878 6.3320179 4.50777149 -0.0205554962 -1.70984459 ) (-20.840839 18.683937 6.3114624 2.7979269 4.11067009 5.50259114 ) (-12.4740429 24.233158 10.422132 8.30051805 -10.422132 -8.30051805 )) NATURAL) (2 ((58 83) (58 125)) NIL ((0 42. 0 0 0 0 )) NATURAL) (2 ((58 125) (108 125)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((108 125) (108 83)) NIL ((0 -42. 0 0 0 0 )) NATURAL) (11 ((108 83) (117 61) (134 46) (156 37) (185 31) (214 29) (241 31) (269 37) (291 46) (308 61) (317 83)) NIL ((7.0843725 -23.486187 0 0 11.493761 8.9171257 ) (12.831253 -19.027622 11.493761 8.9171257 -9.4688053 -2.58563423 ) (19.59061 -11.4033146 2.02495432 6.33149148 8.381464 -4.5745859 ) (25.806297 -7.3591156 10.4064197 1.75690555 -12.057056 2.88397884 ) (30.184188 -4.1602211 -1.65063834 4.6408844 -2.15322876 -0.961326600 ) (27.456935 1.59256160E-7 -3.80386734 3.6795578 8.66997529 0.961325646 ) (27.988056 4.1602211 4.86610794 4.64088345 -14.526672 -2.88397694 ) (25.590827 7.3591156 -9.6605644 1.75690627 7.43671513 4.574584 ) (19.64862 11.4033146 -2.22384882 6.3314905 -9.22018624 2.58563518 ) (12.814678 19.027622 -11.444036 8.9171257 11.444036 -8.9171257 )) NATURAL) (2 ((317 83) (317 301)) NIL ((0 218. 0 0 0 0 )) NATURAL) (2 ((317 301) (187 301)) NIL ((-130. 0 0 0 0 0 )) NATURAL) (2 ((187 301) (187 337)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((187 337) (367 337)) NIL ((180. 0 0 0 0 0 )) NATURAL) (2 ((367 337) (367 83)) NIL ((0 -254. 0 0 0 0 )) NATURAL)))) ((FAMILY GACHA) (CHARACTER 113Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:28:21) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((73 0) (73 0) (73 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((73 337) (120 337)) NIL ((47. 0 0 0 0 0 )) NATURAL) (2 ((120 337) (120 191)) NIL ((0 -146. 0 0 0 0 )) NATURAL) (2 ((120 191) (175 191)) NIL ((55. 0 0 0 0 0 )) NATURAL) (2 ((175 191) (320 338)) NIL ((145. 147. 0 0 0 0 )) NATURAL) (2 ((320 338) (373 338)) NIL ((53. 0 0 0 0 0 )) NATURAL) (2 ((373 338) (214 176)) NIL ((-159. -162. 0 0 0 0 )) NATURAL) (2 ((214 176) (418 0)) NIL ((204. -176. 0 0 0 0 )) NATURAL) (2 ((418 0) (347 0)) NIL ((-71. 0 0 0 0 0 )) NATURAL) (2 ((347 0) (170 155)) NIL ((-177. 155. 0 0 0 0 )) NATURAL) (2 ((170 155) (120 155)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((120 155) (120 0)) NIL ((0 -155. 0 0 0 0 )) NATURAL) (2 ((120 0) (73 0)) NIL ((-47. 0 0 0 0 0 )) NATURAL)))) ((FAMILY GACHA) (CHARACTER 114Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:29:42) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((82 337) (82 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL) (2 ((82 0) (390 0)) NIL ((308. 0 0 0 0 0 )) NATURAL) (2 ((390 0) (390 36)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((390 36) (134 36)) NIL ((-256. 0 0 0 0 0 )) NATURAL) (2 ((134 36) (134 337)) NIL ((0 301. 0 0 0 0 )) NATURAL) (2 ((134 337) (82 337)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY GACHA) (CHARACTER 115Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:34:46) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((40 0) (40 337)) NIL ((0 337. 0 0 0 0 )) NATURAL) (2 ((40 337) (102 337)) NIL ((62. 0 0 0 0 0 )) NATURAL) (2 ((102 337) (219 80)) NIL ((117. -257. 0 0 0 0 )) NATURAL) (2 ((219 80) (335 337)) NIL ((116. 257. 0 0 0 0 )) NATURAL) (2 ((335 337) (397 337)) NIL ((62. 0 0 0 0 0 )) NATURAL) (2 ((397 337) (397 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL) (2 ((397 0) (346 0)) NIL ((-51. 0 0 0 0 0 )) NATURAL) (2 ((346 0) (346 260)) NIL ((0 260. 0 0 0 0 )) NATURAL) (2 ((346 260) (219 -8)) NIL ((-127. -268. 0 0 0 0 )) NATURAL) (2 ((219 -8) (92 260)) NIL ((-127. 268. 0 0 0 0 )) NATURAL) (2 ((92 260) (92 0)) NIL ((0 -260. 0 0 0 0 )) NATURAL) (2 ((92 0) (40 0)) NIL ((-52. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 104Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 21-SEP-77 13:35:12) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((51 0) (51 0) (51 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((51 337) (231 337)) NIL ((180. 0 0 0 0 0 )) NATURAL) (13 ((231 337) (280 330) (322 313) (352 291) (373 264) (388 220) (393 169) (388 118) (373 74) (352 47) (322 25) (280 8) (231 0)) NIL ((50.16728 -4.66153813 0 0 -7.0037012 -14.030771 ) (46.665428 -11.6769237 -7.0037012 -14.030771 -6.98149396 10.153858 ) (36.170982 -20.630764 -13.985195 -3.87691164 4.92968178 3.4153304 ) (24.650627 -22.80001 -9.05551339 -0.461581111 5.26276684 -23.815181 ) (18.226497 -35.169181 -3.79274607 -24.276763 -7.9807539 19.845397 ) (10.4433746 -49.523246 -11.7735 -4.4313631 2.66025162 4.43358326 ) (-3.18512320E-7 -51.737815 -9.1132488 0.00222035451 -2.66025162 4.42026043 ) (-10.4433746 -49.525467 -11.7735 4.42248154 7.98075486 19.885368 ) (-18.226497 -35.1603 -3.79274559 24.307849 -5.26276779 -23.961738 ) (-24.650627 -22.83332 -9.05551339 0.346110821 -4.92968178 3.96159315 ) (-36.170982 -20.506412 -13.985195 4.30770397 6.9814949 8.1153679 ) (-46.665428 -12.1410236 -7.00370026 12.4230728 7.00370026 -12.4230728 )) NATURAL) (2 ((231 0) (51 0)) NIL ((-180. 0 0 0 0 0 )) NATURAL)) ((2 ((101 301) (225 301)) NIL ((124. 0 0 0 0 0 )) NATURAL) (15 ((225 301) (250 300) (278 295) (298 286) (314 273) (331 245) (340 208) (343 169) (340 130) (331 93) (314 65) (298 52) (278 43) (250 38) (225 37)) NIL ((23.713207 -0.204053551 0 0 7.72074509 -4.77567864 ) (27.573581 -2.59189272 7.72074509 -4.77567864 -20.603725 -0.121606826 ) (24.992462 -7.42837525 -12.882982 -4.89728546 8.6941681 5.2621088 ) (16.456562 -9.69460679 -4.18881417 0.364823341 9.82705308 -20.926826 ) (17.181274 -19.793197 5.6382389 -20.562004 -18.00238 12.4452057 ) (13.818325 -34.132598 -12.364141 -8.1167984 8.1824684 7.145998 ) (5.54541779 -38.676399 -4.18167305 -0.970800281 -2.72749042 0.970800281 ) (1.58324837E-7 -39.161796 -6.90916348 3.19420294E-8 2.72748947 0.970800043 ) (-5.54541779 -38.676399 -4.181674 0.970800162 -8.1824665 7.145998 ) (-13.818325 -34.132598 -12.364141 8.1167984 18.002376 12.4452057 ) (-17.181274 -19.793193 5.63823796 20.562004 -9.82705117 -20.926826 ) (-16.456562 -9.69460488 -4.1888132 -0.364823401 -8.6941681 5.2621088 ) (-24.992462 -7.4283743 -12.882982 4.89728546 20.603725 -0.121606826 ) (-27.573581 -2.59189272 7.72074509 4.77567864 -7.72074509 -4.77567864 )) NATURAL) (2 ((225 37) (101 36)) NIL ((-124. -1. 0 0 0 0 )) NATURAL) (2 ((101 36) (101 301)) NIL ((0 265. 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/GACHAE.UC2-SF b/obsolete/lispusers/splinefonts/GACHAE.UC2-SF deleted file mode 100644 index 56a9f2bd..00000000 --- a/obsolete/lispusers/splinefonts/GACHAE.UC2-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY GACHA) (CHARACTER 116Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:42:48) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((61 0) (61 0) (111 0)) NIL ((-12.5 0 0 0 75. 0 ) (25. 0 75. 0 -75. 0 )) NATURAL) (2 ((111 0) (111 295)) NIL ((0 295. 0 0 0 0 )) NATURAL) (2 ((111 295) (312 0)) NIL ((201. -295. 0 0 0 0 )) NATURAL) (2 ((312 0) (376 0)) NIL ((64. 0 0 0 0 0 )) NATURAL) (2 ((376 0) (376 337)) NIL ((0 337. 0 0 0 0 )) NATURAL) (2 ((376 337) (326 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((326 337) (326 42)) NIL ((0 -295. 0 0 0 0 )) NATURAL) (2 ((326 42) (125 337)) NIL ((-201. 295. 0 0 0 0 )) NATURAL) (2 ((125 337) (61 337)) NIL ((-64. 0 0 0 0 0 )) NATURAL) (2 ((61 337) (61 0)) NIL ((0 -337. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 117Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 12:52:08) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((29 ((222 22) (257 25) (286 34) (316 51) (334 75) (346 105) (351 140) (353 169) (351 198) (346 233) (334 263) (316 287) (286 304) (255 313) (222 316) (189 313) (158 304) (128 287) (110 263) (98 233) (93 198) (91 169) (93 140) (98 105) (110 75) (128 51) (158 34) (187 25) (222 22)) NIL ((36.888336 1.854002 0 0 -11.3300247 6.875988 ) (31.223323 5.291996 -11.3300247 6.875988 20.650123 1.62005996 ) (30.21836 12.978014 9.32010079 8.49604798 -29.270477 -1.35623073 ) (24.90322 20.795944 -19.950378 7.13981724 18.431793 -2.19513702 ) (14.168741 26.838195 -1.51858186 4.9446802 -8.456707 4.13677883 ) (8.42180444 33.851265 -9.9752903 9.08145906 9.3950348 -20.351982 ) (3.14403296 32.756729 -0.580255032 -11.270523 -5.1234331 11.271158 ) (0.00206090975 27.121788 -5.70368862 6.36285287E-4 5.09869957 11.2673397 ) (-3.15227747 32.756095 -0.604988218 11.2679767 -9.2713661 -20.340518 ) (-8.39294816 33.853813 -9.8763561 -9.0725422 7.98676587 4.09474373 ) (-14.2759208 26.82864 -1.88958955 -4.97779846 -16.675693 -2.03846168 ) (-24.50336 20.831611 -18.565284 -7.01626015 22.716026 -1.94089889 ) (-31.710632 12.844902 4.15074253 -8.95715905 -8.18842698 3.80206299 ) (-31.654102 5.78877354 -4.0376854 -5.15509606 4.0376854 -1.26735592 ) (-33.672943 1.58324837E-7 0 -6.42245198 4.0376854 1.26735496 ) (-31.654102 -5.78877449 4.0376854 -5.155097 -8.18842698 -3.80206204 ) (-31.710632 -12.844902 -4.15074253 -8.95715905 22.716026 1.94089889 ) (-24.503356 -20.831611 18.565284 -7.01626015 -16.675693 2.03846168 ) (-14.2759208 -26.82864 1.88958955 -4.97779846 7.98676396 -4.09474564 ) (-8.39294816 -33.853813 9.8763542 -9.0725441 -9.2713642 20.340518 ) (-3.15227747 -32.756095 0.604989052 11.2679767 5.09869957 -11.2673397 ) (0.00206130743 -27.121788 5.70368862 6.36285287E-4 -5.1234331 -11.271158 ) (3.14403296 -32.756729 0.580254913 -11.270523 9.3950348 20.351982 ) (8.42180444 -33.851265 9.9752903 9.08146096 -8.456707 -4.13678074 ) (14.168741 -26.838195 1.51858258 4.9446802 18.431793 2.19513607 ) (24.90322 -20.795944 19.950378 7.13981629 -29.270477 1.35623169 ) (30.21836 -12.978012 -9.32010079 8.49604798 20.650123 -1.62006092 ) (31.223323 -5.29199505 11.3300247 6.87598706 -11.3300247 -6.87598706 )) NATURAL)) ((29 ((42 169) (47 117) (61 78) (80 48) (102 28) (133 10) (180 -3) (222 -7) (264 -3) (311 10) (342 28) (364 48) (383 78) (397 117) (402 169) (397 221) (383 260) (364 290) (342 310) (311 328) (264 341) (222 345) (180 341) (133 328) (102 310) (80 290) (61 260) (47 221) (42 169)) NIL ((0.0957953036 -55.136116 9.7570095 0.390455067 0.154199600 17.645336 ) (9.92990495 -45.922988 9.9112091 18.035793 -5.3130598 -12.5694408 ) (17.184581 -34.171913 4.5981493 5.46635247 -2.90195894 8.63244058 ) (20.331752 -24.389339 1.69619012 14.098793 4.92089939 -15.960325 ) (24.488395 -18.27071 6.61709023 -1.86153316 19.218349 7.20887089 ) (40.71466 -16.527809 25.835441 5.34733773 -39.794303 5.12484169 ) (46.652946 -8.6180496 -13.958868 10.472179 13.9589 -3.70823574 ) (39.67353 1.14440918E-5 3.27086381E-5 6.76394368 13.958702 3.70810032 ) (46.652915 8.61800576 13.958736 10.472044 -39.793716 -5.12416935 ) (40.71479 16.527965 -25.834983 5.34787464 19.216178 -7.21142007 ) (24.487899 18.27013 -6.61880208 -1.86354613 4.92899609 15.969852 ) (20.333595 24.39151 -1.68980574 14.106308 -2.93216896 -8.66798974 ) (17.1777038 34.163818 -4.62197495 5.4383173 -5.20031739 12.7020969 ) (9.9555721 45.953193 -9.8222923 18.140415 -0.266559601 -18.140411 ) (-6.37024641E-7 55.023399 -10.0888519 1.02214494E-6 0.266559601 -18.140419 ) (-9.9555721 45.953186 -9.8222923 -18.140419 5.20031739 12.7021007 ) (-17.1777038 34.163818 -4.62197495 -5.4383173 2.93216944 -8.6679878 ) (-20.333595 24.39151 -1.68980551 -14.106306 -4.92899609 15.96985 ) (-24.487899 18.27013 -6.61880208 1.86354565 -19.216178 -7.21142007 ) (-40.71479 16.527965 -25.834983 -5.34787464 39.793716 -5.12416935 ) (-46.652915 8.61800386 13.958738 -10.472044 -13.958704 3.70809937 ) (-39.67353 1.11255794E-5 3.27086381E-5 -6.76394463 -13.9589 -3.70823288 ) (-46.652946 -8.6180496 -13.958868 -10.472177 39.794303 5.12483883 ) (-40.71466 -16.527809 25.835441 -5.34733868 -19.218349 7.20887185 ) (-24.488391 -18.27071 6.61709119 1.86153364 -4.9209013 -15.960327 ) (-20.331752 -24.389339 1.6961894 -14.0987949 2.90196085 8.63244248 ) (-17.184581 -34.171913 4.59815026 -5.4663515 5.31305886 -12.5694408 ) (-9.929903 -45.922988 9.9112091 -18.035793 -0.154199600 17.645336 )) PSEUDOCYCLIC)))) ((FAMILY gacha) (CHARACTER 120Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:02:12) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((81 0) (81 0) (81 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((81 337) (261 337)) NIL ((180. 0 0 0 0 0 )) NATURAL) (13 ((261 337) (287 336) (318 331) (346 318) (363 300) (375 272) (381 236) (375 200) (363 172) (346 154) (318 141) (287 136) (261 135)) NIL ((24.635082 -0.447435856 0 0 8.18948937 -3.31538487 ) (28.729827 -2.10512829 8.18948937 -3.31538487 -10.9474468 -7.42307568 ) (31.445594 -9.13205148 -2.75795746 -10.7384605 -12.399702 9.0076904 ) (22.487785 -15.3666668 -15.157659 -1.73076916 12.5462589 -10.6076908 ) (13.603256 -22.401279 -2.61139917 -12.3384609 -1.78534364 3.42307854 ) (10.099184 -33.028198 -4.39674282 -8.9153824 -11.404884 8.91538049 ) (-1.60187482E-7 -37.485893 -15.801628 -5.11072471E-7 11.404884 8.9153843 ) (-10.099184 -33.028198 -4.39674282 8.9153843 1.78534364 3.42307472 ) (-13.603256 -22.401279 -2.61139917 12.338459 -12.5462589 -10.6076889 ) (-22.487785 -15.3666649 -15.157659 1.73077011 12.399702 9.0076885 ) (-31.445594 -9.13204957 -2.7579565 10.7384586 10.947443 -7.42307377 ) (-28.729827 -2.10512829 8.18948747 3.31538487 -8.18948747 -3.31538487 )) NATURAL) (2 ((261 135) (134 135)) NIL ((-127. 0 0 0 0 0 )) NATURAL) (2 ((134 135) (134 0)) NIL ((0 -135. 0 0 0 0 )) NATURAL) (2 ((134 0) (81 0)) NIL ((-53. 0 0 0 0 0 )) NATURAL)) ((9 ((261 301) (283 299) (306 293) (323 270) (329 238) (323 206) (306 183) (283 177) (261 175)) NIL ((21.463916 -1.98214268 0 0 3.21649456 -0.107143402 ) (23.072162 -2.03571415 3.21649456 -0.107143402 -10.0824737 -23.464283 ) (21.247421 -13.875 -6.8659792 -23.571426 -4.88659764 15.964283 ) (11.9381427 -29.464283 -11.7525768 -7.60714245 -0.371133804 7.60714245 ) (-3.18512320E-7 -33.267852 -12.1237106 2.55529982E-7 0.371133804 7.60714055 ) (-11.9381446 -29.464283 -11.7525768 7.6071415 4.88659859 15.9642849 ) (-21.247421 -13.874998 -6.86597825 23.571426 10.0824718 -23.464283 ) (-23.072162 -2.03571415 3.21649504 0.107142448 -3.21649504 -0.107142448 )) NATURAL) (2 ((261 175) (134 175)) NIL ((-127. 0 0 0 0 0 )) NATURAL) (2 ((134 175) (134 301)) NIL ((0 126. 0 0 0 0 )) NATURAL) (2 ((134 301) (261 301)) NIL ((127. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 121Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:08:33) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((29 ((222 22) (187 25) (158 34) (128 51) (110 75) (98 105) (93 140) (91 169) (93 198) (98 233) (110 263) (128 287) (158 304) (189 313) (222 316) (255 313) (286 304) (316 287) (334 263) (346 233) (351 198) (353 169) (351 140) (346 105) (334 75) (316 51) (286 34) (257 25) (222 22)) NIL ((-36.888336 1.854002 0 0 11.3300247 6.875988 ) (-31.223323 5.291996 11.3300247 6.875988 -20.650123 1.62005996 ) (-30.21836 12.978014 -9.32010079 8.49604798 29.270477 -1.35623073 ) (-24.90322 20.795944 19.950378 7.13981724 -18.431793 -2.19513702 ) (-14.168741 26.838195 1.51858186 4.9446802 8.456707 4.13677883 ) (-8.42180444 33.851265 9.9752903 9.08145906 -9.3950348 -20.351982 ) (-3.14403296 32.756729 0.580255032 -11.270523 5.1234331 11.271158 ) (-0.00206090975 27.121788 5.70368862 6.36285287E-4 -5.09869957 11.2673397 ) (3.15227747 32.756095 0.604988218 11.2679767 9.2713661 -20.340518 ) (8.39294816 33.853813 9.8763561 -9.0725422 -7.98676587 4.09474373 ) (14.2759208 26.82864 1.88958955 -4.97779846 16.675693 -2.03846168 ) (24.50336 20.831611 18.565284 -7.01626015 -22.716026 -1.94089889 ) (31.710632 12.844902 -4.15074253 -8.95715905 8.18842698 3.80206299 ) (31.654102 5.78877354 4.0376854 -5.15509606 -4.0376854 -1.26735592 ) (33.672943 1.58324837E-7 0 -6.42245198 -4.0376854 1.26735496 ) (31.654102 -5.78877449 -4.0376854 -5.155097 8.18842698 -3.80206204 ) (31.710632 -12.844902 4.15074253 -8.95715905 -22.716026 1.94089889 ) (24.503356 -20.831611 -18.565284 -7.01626015 16.675693 2.03846168 ) (14.2759208 -26.82864 -1.88958955 -4.97779846 -7.98676396 -4.09474564 ) (8.39294816 -33.853813 -9.8763542 -9.0725441 9.2713642 20.340518 ) (3.15227747 -32.756095 -0.604989052 11.2679767 -5.09869957 -11.2673397 ) (-0.00206130743 -27.121788 -5.70368862 6.36285287E-4 5.1234331 -11.271158 ) (-3.14403296 -32.756729 -0.580254913 -11.270523 -9.3950348 20.351982 ) (-8.42180444 -33.851265 -9.9752903 9.08146096 8.456707 -4.13678074 ) (-14.168741 -26.838195 -1.51858258 4.9446802 -18.431793 2.19513607 ) (-24.90322 -20.795944 -19.950378 7.13981629 29.270477 1.35623169 ) (-30.21836 -12.978012 9.32010079 8.49604798 -20.650123 -1.62006092 ) (-31.223323 -5.29199505 -11.3300247 6.87598706 11.3300247 -6.87598706 )) NATURAL)) ((2 ((264 -3) (256 -5)) NIL ((-8. -2. 0 0 0 0 )) NATURAL) (5 ((256 -5) (255 -17) (261 -29) (273 -34) (285 -34)) NIL ((-2.4464283 -11.5892849 0 0 8.6785698 -2.46428537 ) (1.89285755 -12.821428 8.6785698 -2.46428537 -1.39285564 12.321426 ) (9.875 -9.1249981 7.28571416 9.8571415 -9.1071415 -4.82142735 ) (12.607141 -1.67857122 -1.8214283 5.03571415 1.8214283 -5.03571415 )) NATURAL) (2 ((285 -34) (367 -34)) NIL ((82. 0 0 0 0 0 )) NATURAL) (2 ((367 -34) (367 -69)) NIL ((0 -35. 0 0 0 0 )) NATURAL) (2 ((367 -69) (262 -69)) NIL ((-105. 0 0 0 0 0 )) NATURAL) (6 ((262 -69) (243 -66) (225 -58) (213 -44) (208 -22) (208 -4)) NIL ((-18.947364 1.91866016 0 0 -0.315789461 6.48803807 ) (-19.105262 5.16267872 -0.315789461 6.48803807 7.57894707 -2.44019127 ) (-15.631578 10.430622 7.26315785 4.0478468 -9.53674316E-7 9.27272416 ) (-8.36841966 19.11483 7.2631569 13.3205719 -1.57894706 -22.650714 ) (-1.89473653 21.110046 5.68420983 -9.33014298 -5.68420983 9.33014298 )) NATURAL) (2 ((208 -4) (180 -3)) NIL ((-28. 1. 0 0 0 0 )) NATURAL) (27 ((180 -3) (133 10) (102 28) (80 48) (61 78) (47 117) (42 169) (47 221) (61 260) (80 290) (102 310) (133 328) (180 341) (222 345) (264 341) (311 328) (342 310) (364 290) (383 260) (397 221) (402 169) (397 117) (383 78) (364 48) (342 28) (311 10) (264 -3)) NIL ((-50.682457 11.6410236 0 0 22.094749 8.15385057 ) (-39.635078 15.7179489 22.094749 8.15385057 -14.4737549 -10.7692546 ) (-24.777206 18.487171 7.62099457 -2.61540413 -6.19972516 16.923168 ) (-20.256076 24.333354 1.4212687 14.3077659 3.27266073 -8.92342759 ) (-17.1984749 34.179405 4.69392967 5.38433743 5.10908127 12.7705459 ) (-9.95000649 45.949012 9.80301095 18.154884 0.291007995 -18.15876 ) (-0.00149090960 55.02452 10.0940189 -0.00387597363 -0.273111343 -18.135498 ) (9.95597268 45.952888 9.8209076 -18.139377 -5.19856167 12.7007808 ) (17.177597 34.163902 4.62234593 -5.43859673 -2.93264007 -8.66763497 ) (20.333625 24.391487 1.68970585 -14.1062317 4.92912293 15.969757 ) (24.487892 18.2701339 6.61882878 1.86352634 19.216144 -7.2113981 ) (40.714798 16.527961 25.834976 -5.34787178 -39.793716 -5.12416458 ) (46.652908 8.61800767 -13.958744 -10.472036 13.958744 3.7080555 ) (39.673538 -6.37024641E-7 0 -6.76398087 13.958744 -3.70805359 ) (46.652908 -8.61800958 13.958744 -10.472034 -39.793716 5.12416172 ) (40.71479 -16.527961 -25.834976 -5.34787274 19.216144 7.21139908 ) (24.487892 -18.2701339 -6.61882878 1.86352634 4.92912197 -15.969757 ) (20.333625 -24.391487 -1.68970608 -14.1062317 -2.93264055 8.66763497 ) (17.177597 -34.163902 -4.62234688 -5.43859577 -5.1985607 -12.7007808 ) (9.95597077 -45.952888 -9.8209076 -18.139377 -0.273111343 18.135498 ) (-0.00149186514 -55.02452 -10.0940189 -0.00387699622 0.291007995 18.15876 ) (-9.95000649 -45.949012 -9.80301095 18.154884 5.10908127 -12.7705478 ) (-17.198478 -34.179405 -4.69392967 5.38433647 3.2726612 8.9234295 ) (-20.256076 -24.33335 -1.42126846 14.3077659 -6.19972706 -16.923168 ) (-24.777206 -18.487171 -7.6209955 -2.6154046 -14.4737529 10.7692546 ) (-39.635078 -15.7179489 -22.094749 8.15385057 22.094749 -8.15385057 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 122Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:19:31) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((3 ((73 0) (73 0) (73 337)) NIL ((0 -84.25 0 0 0 505.5 ) (0 168.5 0 505.5 0 -505.5 )) NATURAL) (2 ((73 337) (244 337)) NIL ((171. 0 0 0 0 0 )) NATURAL) (7 ((244 337) (280 335) (316 328) (345 311) (362 286) (367 255) (367 242)) NIL ((35.673072 -1.27820491 0 0 1.96153855 -4.33076954 ) (36.653839 -3.44358969 1.96153855 -4.33076954 -9.80769158 -8.34615136 ) (33.711532 -11.947435 -7.8461542 -12.6769218 -4.73076725 7.71538354 ) (23.499996 -20.766666 -12.576921 -4.9615383 -1.26923179 -10.5153846 ) (10.2884597 -30.985897 -13.846153 -15.476923 9.80769158 46.346145 ) (1.34615373 -23.289741 -4.03846169 30.869228 4.03846169 -30.869228 )) NATURAL) (6 ((367 242) (367 229) (362 198) (345 173) (316 156) (292 151)) NIL ((0.732057333 -7.84210587 0 0 -4.39234448 -30.947364 ) (-1.46411466 -23.315788 -4.39234448 -30.947364 -8.03827668 46.73683 ) (-9.875597 -30.894733 -12.430622 15.789472 -5.45454407 -11.999998 ) (-25.033493 -21.105262 -17.885166 3.78947306 29.856456 13.2631569 ) (-27.990428 -10.6842098 11.9712906 17.052631 -11.9712906 -17.052631 )) NATURAL) (2 ((292 151) (360 0)) NIL ((68. -151. 0 0 0 0 )) NATURAL) (2 ((360 0) (305 0)) NIL ((-55. 0 0 0 0 0 )) NATURAL) (2 ((305 0) (239 147)) NIL ((-66. 147. 0 0 0 0 )) NATURAL) (2 ((239 147) (120 147)) NIL ((-119. 0 0 0 0 0 )) NATURAL) (2 ((120 147) (120 0)) NIL ((0 -147. 0 0 0 0 )) NATURAL) (2 ((120 0) (73 0)) NIL ((-47. 0 0 0 0 0 )) NATURAL)) ((2 ((120 183) (120 301)) NIL ((0 118. 0 0 0 0 )) NATURAL) (2 ((120 301) (226 301)) NIL ((106. 0 0 0 0 0 )) NATURAL) (6 ((226 301) (272 299) (293 292) (307 280) (313 265) (315 242)) NIL ((52.330139 -1. 0 0 -37.980857 -6. ) (33.339706 -4. -37.980857 -6. 39.904296 0 ) (15.311004 -10. 1.92344451 -6. -13.63636 6. ) (10.416267 -13. -11.712917 0 8.6411457 -12. ) (3.0239234 -19. -3.07177019 -12. 3.07177019 12. )) NATURAL) (6 ((315 242) (313 219) (307 204) (293 192) (272 185) (226 183)) NIL ((-1.48803806 -24.999996 0 0 -3.07177067 11.999998 ) (-3.0239234 -18.999996 -3.07177067 11.999998 -8.6411457 -11.999996 ) (-10.416267 -12.999998 -11.712917 2.54313135E-7 13.636358 5.9999981 ) (-15.311004 -9.9999981 1.92344212 5.99999905 -39.904289 9.53674316E-7 ) (-33.339714 -4. -37.98085 6. 37.98085 -6. )) NATURAL) (2 ((226 183) (120 183)) NIL ((-106. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 123Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:39:15) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((370 259) (328 259)) NIL ((-42. 0 0 0 0 0 )) NATURAL) (19 ((328 259) (319 283) (296 300) (270 309) (220 313) (178 311) (154 307) (129 297) (113 280) (109 264) (115 239) (145 218) (182 212) (218 209) (273 203) (318 191) (350 172) (371 140) (378 88)) NIL ((-4.98698998 25.367855 0 0 -24.07806 -8.2071476 ) (-17.02602 21.264282 -24.07806 -8.2071476 36.390304 -0.964258195 ) (-22.908927 12.575006 12.312244 -9.1714058 -55.48316 6.06417847 ) (-38.338264 6.43568993 -43.17092 -3.10722733 59.54238 -5.29245758 ) (-51.737999 0.682233811 16.371463 -8.3996849 9.31360246 9.10564996 ) (-30.709728 -3.16462517 25.685066 0.705966711 -36.796806 -7.13014699 ) (-23.423069 -6.02373219 -11.1117458 -6.42418099 23.873664 -4.58506012 ) (-22.597984 -14.740444 12.761919 -11.009241 1.30215072 19.470386 ) (-9.1849899 -16.014488 14.0640697 8.4611473 -11.0822677 -25.296493 ) (-0.662053824 -20.201587 2.9818015 -16.835346 31.026916 21.71558 ) (17.833206 -26.179142 34.00872 4.88023567 -29.025417 16.434162 ) (37.329216 -13.081827 4.98330307 21.314399 -16.925239 -21.452232 ) (33.849899 -2.4935441 -11.941936 -0.137833327 48.72637 -2.62523365 ) (46.271156 -3.943995 36.784439 -2.76306724 -57.98026 -4.04682827 ) (54.06546 -8.73047639 -21.195827 -6.8098955 9.19470979 0.812546731 ) (37.466987 -15.134098 -12.0011177 -5.99734879 3.20141602 -5.20335579 ) (27.066577 -23.733127 -8.7997017 -11.2007045 -10.00037 -15.9991169 ) (13.266689 -42.933387 -18.800071 -27.199821 18.800071 27.199821 )) NATURAL) (11 ((378 88) (369 49) (349 23) (314 4) (273 -6) (214 -9) (151 -5) (106 7) (73 25) (46 52) (36 84)) NIL ((-7.0958252 -42.124916 0 0 -11.425045 18.749504 ) (-12.8083477 -32.75016 -11.425045 18.749504 -8.87477494 -15.74752 ) (-28.67078 -21.87442 -20.299819 3.00198221 22.924152 8.2405815 ) (-37.508522 -14.752147 2.62433576 11.242565 -28.821849 -5.2148094 ) (-49.295112 -6.11698628 -26.197517 6.02775574 20.363262 0.618652344 ) (-65.311004 0.220096260 -5.8342533 6.64640809 31.368785 2.74019813 ) (-55.46086 8.2366047 25.534534 9.3866062 -13.838428 -5.57944775 ) (-36.845535 14.833486 11.6961059 3.80715847 -12.015068 7.5775995 ) (-31.156967 22.429443 -0.318962395 11.384758 25.898704 -6.7309475 ) (-18.52658 30.448726 25.579742 4.6538105 -25.579742 -4.6538105 )) NATURAL) (2 ((36 84) (88 84)) NIL ((52. 0 0 0 0 0 )) NATURAL) (4 ((88 84) (103 56) (127 40) (166 28)) NIL ((13.599998 -30.93333 0 0 8.3999996 17.599998 ) (17.799999 -22.133331 8.3999996 17.599998 11.999998 -15.999998 ) (32.199997 -12.5333328 20.399997 1.5999999 -20.399997 -1.5999999 )) NATURAL) (25 ((166 28) (208 23) (248 25) (287 31) (320 57) (330 99) (322 135) (292 152) (248 159) (193 165) (140 174) (103 188) (75 209) (60 237) (57 264) (69 299) (91 320) (124 334) (165 343) (216 345) (261 343) (300 335) (336 316) (360 289) (370 259)) NIL ((42.478797 -6.88853169 0 0 -2.87278843 11.331192 ) (41.042396 -1.22293496 -2.87278843 11.331192 2.36394262 -14.6559658 ) (39.351585 2.78027391 -0.508845687 -3.32477379 -0.582982898 29.292675 ) (38.551246 14.1018409 -1.09182858 25.967903 -30.032005 -6.51475526 ) (22.443412 36.812362 -31.123836 19.453147 18.711029 -27.23365 ) (0.675090075 42.648689 -12.412805 -7.7805023 -14.812124 -16.550632 ) (-19.1437759 26.592868 -27.224929 -24.331134 16.53746 15.43618 ) (-38.099975 9.97982408 -10.6874675 -8.89495469 -3.3377304 8.805912 ) (-50.456306 5.48782635 -14.025198 -0.0890419930 14.813459 3.34016419 ) (-57.074775 7.06886674 0.788262964 3.25112248 22.083881 1.83342743 ) (-45.244567 11.2367038 22.872146 5.0845499 -19.14899 1.3261261 ) (-31.946922 16.984317 3.7231555 6.410676 12.512073 4.8620653 ) (-21.967727 25.826026 16.235229 11.272741 -6.89930726 -20.774387 ) (-9.1821537 26.711574 9.33592225 -9.50164796 9.0851593 30.235496 ) (4.69634819 32.327667 18.421081 20.733848 -11.4413375 -46.167587 ) (17.3967628 29.977726 6.97974396 -25.433738 6.68019105 22.434852 ) (27.716602 15.761413 13.659935 -2.9988861 -9.27941896 -1.57182884 ) (36.736824 11.976614 4.3805151 -4.57071495 12.4374847 -4.14753914 ) (47.336082 5.33212757 16.818 -8.7182541 -28.470516 6.1619911 ) (49.918823 -0.305130005 -11.652515 -2.55626249 5.4445772 -2.50043249 ) (40.988594 -4.1116085 -6.2079382 -5.05669499 6.69220734 -8.16025926 ) (38.126762 -13.248434 0.484269857 -13.216955 -14.213407 5.14147759 ) (31.504329 -23.894649 -13.729139 -8.0754776 -3.83857536 5.59434796 ) (15.855903 -29.172954 -17.567714 -2.48112965 17.567714 2.48112965 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 124Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:44:08) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((192 0) (192 301)) NIL ((0 301. 0 0 0 0 )) NATURAL) (2 ((192 301) (52 301)) NIL ((-140. 0 0 0 0 0 )) NATURAL) (2 ((52 301) (52 337)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((52 337) (388 337)) NIL ((336. 0 0 0 0 0 )) NATURAL) (2 ((388 337) (388 301)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((388 301) (254 301)) NIL ((-134. 0 0 0 0 0 )) NATURAL) (2 ((254 301) (254 0)) NIL ((0 -301. 0 0 0 0 )) NATURAL) (2 ((254 0) (192 0)) NIL ((-62. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 125Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:47:06) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((13 ((390 83) (381 56) (364 35) (340 18) (309 5) (271 -4) (220 -8) (169 -4) (132 5) (100 18) (76 35) (60 56) (51 83)) NIL ((-7.24374676 -28.381198 0 0 -10.5375175 8.2871933 ) (-12.512506 -24.237598 -10.5375175 8.2871933 4.6875944 -5.4359722 ) (-20.706226 -18.668392 -5.84992314 2.85122108 -2.21286487 1.45669841 ) (-27.662582 -15.088821 -8.062788 4.3079195 4.16386414 -0.390820980 ) (-33.643432 -10.9763126 -3.8989234 3.91709852 -14.4425907 0.106587886 ) (-44.763656 -7.00592137 -18.341514 4.0236864 17.606502 5.96446896 ) (-54.301918 6.37024641E-7 -0.735011101 9.98815537 22.016567 -5.9644699 ) (-44.02864 7.00592137 21.281559 4.02368546 -21.67279 -0.106587410 ) (-33.58348 10.9763126 -0.391231656 3.91709805 10.6745968 0.390821457 ) (-28.637413 15.088821 10.283365 4.3079195 -3.02559567 -1.45669794 ) (-19.866848 18.668392 7.25776959 2.85122156 1.42778682 5.43597126 ) (-11.895185 24.237602 8.6855564 8.2871933 -8.6855564 -8.2871933 )) NATURAL) (2 ((51 83) (51 337)) NIL ((0 254. 0 0 0 0 )) NATURAL) (2 ((51 337) (101 337)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((101 337) (101 83)) NIL ((0 -254. 0 0 0 0 )) NATURAL) (10 ((101 83) (110 61) (127 46) (149 37) (196 30) (245 30) (292 37) (314 46) (331 61) (340 83)) NIL ((6.73856164 -23.4566 0 0 13.568626 8.7396221 ) (13.5228748 -19.086792 13.568626 8.7396221 -19.843132 -1.69811344 ) (17.169933 -11.196226 -6.27450753 7.04150868 47.803909 -7.94716836 ) (34.797386 -8.1283016 41.529403 -0.905660153 -51.372535 9.4867897 ) (50.640518 -4.29056549 -9.8431358 8.58113099 19.686271 0 ) (50.640518 4.29056549 9.8431358 8.58113099 -51.372535 -9.4867897 ) (34.797378 8.1283016 -41.529403 -0.905660153 47.803909 7.94716836 ) (17.169933 11.196226 6.27450944 7.04150868 -19.843135 1.69811344 ) (13.5228748 19.086792 -13.568626 8.7396221 13.568626 -8.7396221 )) NATURAL) (2 ((340 83) (340 337)) NIL ((0 254. 0 0 0 0 )) NATURAL) (2 ((340 337) (390 337)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((390 337) (390 83)) NIL ((0 -254. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 126Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:51:38) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((21 337) (192 0)) NIL ((171. -337. 0 0 0 0 )) NATURAL) (2 ((192 0) (248 0)) NIL ((56. 0 0 0 0 0 )) NATURAL) (2 ((248 0) (420 337)) NIL ((172. 337. 0 0 0 0 )) NATURAL) (2 ((420 337) (370 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((370 337) (220 44)) NIL ((-150. -293. 0 0 0 0 )) NATURAL) (2 ((220 44) (71 337)) NIL ((-149. 293. 0 0 0 0 )) NATURAL) (2 ((71 337) (21 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 127Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 13:57:20) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((24 337) (90 0)) NIL ((66. -337. 0 0 0 0 )) NATURAL) (2 ((90 0) (143 0)) NIL ((53. 0 0 0 0 0 )) NATURAL) (2 ((143 0) (221 288)) NIL ((78. 288. 0 0 0 0 )) NATURAL) (2 ((221 288) (298 0)) NIL ((77. -288. 0 0 0 0 )) NATURAL) (2 ((298 0) (351 0)) NIL ((53. 0 0 0 0 0 )) NATURAL) (2 ((351 0) (417 337)) NIL ((66. 337. 0 0 0 0 )) NATURAL) (2 ((417 337) (367 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((367 337) (317 79)) NIL ((-50. -258. 0 0 0 0 )) NATURAL) (2 ((317 79) (247 337)) NIL ((-70. 258. 0 0 0 0 )) NATURAL) (2 ((247 337) (194 337)) NIL ((-53. 0 0 0 0 0 )) NATURAL) (2 ((194 337) (124 79)) NIL ((-70. -258. 0 0 0 0 )) NATURAL) (2 ((124 79) (74 337)) NIL ((-50. 258. 0 0 0 0 )) NATURAL) (2 ((74 337) (24 337)) NIL ((-50. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 130Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:06:06) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((49 0) (107 0)) NIL ((58. 0 0 0 0 0 )) NATURAL) (2 ((107 0) (219 142)) NIL ((112. 142. 0 0 0 0 )) NATURAL) (2 ((219 142) (331 0)) NIL ((112. -142. 0 0 0 0 )) NATURAL) (2 ((331 0) (389 0)) NIL ((58. 0 0 0 0 0 )) NATURAL) (2 ((389 0) (248 179)) NIL ((-141. 179. 0 0 0 0 )) NATURAL) (2 ((248 179) (372 337)) NIL ((124. 158. 0 0 0 0 )) NATURAL) (2 ((372 337) (314 337)) NIL ((-58. 0 0 0 0 0 )) NATURAL) (2 ((314 337) (219 216)) NIL ((-95. -121. 0 0 0 0 )) NATURAL) (2 ((219 216) (125 337)) NIL ((-94. 121. 0 0 0 0 )) NATURAL) (2 ((125 337) (66 337)) NIL ((-59. 0 0 0 0 0 )) NATURAL) (2 ((66 337) (189 179)) NIL ((123. -158. 0 0 0 0 )) NATURAL) (2 ((189 179) (49 0)) NIL ((-140. -179. 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 131Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:08:44) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((190 0) (190 154)) NIL ((0 154. 0 0 0 0 )) NATURAL) (2 ((190 154) (30 337)) NIL ((-160. 183. 0 0 0 0 )) NATURAL) (2 ((30 337) (91 337)) NIL ((61. 0 0 0 0 0 )) NATURAL) (2 ((91 337) (219 188)) NIL ((128. -149. 0 0 0 0 )) NATURAL) (2 ((219 188) (347 337)) NIL ((128. 149. 0 0 0 0 )) NATURAL) (2 ((347 337) (408 337)) NIL ((61. 0 0 0 0 0 )) NATURAL) (2 ((408 337) (247 154)) NIL ((-161. -183. 0 0 0 0 )) NATURAL) (2 ((247 154) (247 0)) NIL ((0 -154. 0 0 0 0 )) NATURAL) (2 ((247 0) (190 0)) NIL ((-57. 0 0 0 0 0 )) NATURAL)))) ((FAMILY gacha) (CHARACTER 132Q) (FACE M R E) (WIDTH 441 0) (FIDUCIAL 480 480) (VERSION 0 19-SEP-77 14:10:13) (MADE-FROM gachac.cu 0 140 0 0) (SPLINES ((2 ((72 337) (72 301)) NIL ((0 -36. 0 0 0 0 )) NATURAL) (2 ((72 301) (293 301)) NIL ((221. 0 0 0 0 0 )) NATURAL) (2 ((293 301) (61 29)) NIL ((-232. -272. 0 0 0 0 )) NATURAL) (2 ((61 29) (61 0)) NIL ((0 -29. 0 0 0 0 )) NATURAL) (2 ((61 0) (378 0)) NIL ((317. 0 0 0 0 0 )) NATURAL) (2 ((378 0) (378 36)) NIL ((0 36. 0 0 0 0 )) NATURAL) (2 ((378 36) (124 36)) NIL ((-254. 0 0 0 0 0 )) NATURAL) (2 ((124 36) (355 308)) NIL ((231. 272. 0 0 0 0 )) NATURAL) (2 ((355 308) (355 337)) NIL ((0 29. 0 0 0 0 )) NATURAL) (2 ((355 337) (72 337)) NIL ((-283. 0 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/SFFONT b/obsolete/lispusers/splinefonts/SFFONT deleted file mode 100644 index 5723b532..00000000 --- a/obsolete/lispusers/splinefonts/SFFONT +++ /dev/null @@ -1,717 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED " 1-Oct-91 14:10:29" |{PELE:MV:ENVOS}MEDLEY>SFFONT.;2| 36558 - - changes to%: (VARS SFFONTCOMS) - - previous date%: " 4-Feb-87 23:04:29" |{PELE:MV:ENVOS}MEDLEY>SFFONT.;1|) - - -(* ; " -Copyright (c) 1991 by Venue. All rights reserved. -") - -(PRETTYCOMPRINT SFFONTCOMS) - -(RPAQQ SFFONTCOMS - ((RECORDS SF.CHARACTER SF.CHARDESC SF.DERIVATIVE SF.FACE SF.FAMILY SF.FIDUCIAL SF.MADE-FROM - SF.SPLINE SF.SPLINES SF.VERSION SF.WIDTH) - (FNS READ.SPLINE.FONT SF.DERIVS.TO.BEZIER SF.PRINT SFDRAW SFDRAW.CLOSED.CURVE TEST - VIEW.FONT.FILES \LOOKUPSPLINEFONT \SETSPLINEFONT ginit) - (DECLARE%: EVAL@LOAD DONTCOPY (FILES (LOADCOMP) - IRISSTREAM) - (VARS TIMESROMANDFILES TRA TRB TRC TRFILES)) - (INITVARS (\SPLINEFONTSINCORE (LIST NIL))) - (GLOBALVARS \SPLINEFONTSINCORE) - (CONSTANTS (\CHARSEGMENTS.IRIS 10)))) -(DECLARE%: EVAL@COMPILE - -(RECORD SF.CHARACTER (CHARCODE)) - -(ASSOCRECORD SF.CHARDESC (FAMILY CHARACTER FACE WIDTH FIDUCIAL VERSION SPLINES) - (ACCESSFNS (SF.WIDTH (FETCH WIDTH OF DATUM)))) - -(RECORD SF.DERIVATIVE (XPRIME YPRIME XDPRIME YDPRIME XTPRIME YTPRIME)) - -(RECORD SF.FACE (WEIGHT SLOPE EXPANSION)) - -(RECORD SF.FAMILY (SFFAMILY)) - -(RECORD SF.FIDUCIAL (XFIDUCIAL YFIDUCIAL)) - -(RECORD SF.MADE-FROM (FILENAME XCHAR.ORIGIN YCHAR.ORIGIN XFIDUCIAL.ORIGIN YFIDUCIAL.ORIGIN)) - -(RECORD SF.SPLINE (%#OFKNOTS KNOTLIST WEIGHTLIST DERIVATIVELIST . OPTIONALSOLNMETHOD)) - -(RECORD SF.SPLINES (CLOSEDCURVELIST)) - -(RECORD SF.VERSION (VERSION DATE TIME)) - -(RECORD SF.WIDTH (XWIDTH YWIDTH)) -) -(DEFINEQ - -(READ.SPLINE.FONT - [LAMBDA (FILES FAMILY CHARSET) (* ; "Edited 4-Feb-87 22:54 by gbn") - -(* ;;; "reads SF files and updates \SPLINEFONTSINCORE. \SPLINEFONTSINCORE looks like (((FAMILY1 CHARSET#) FONTARRAY1) ...)") - -(* ;;; "should learn about sd files") - - (PROG (FONTARRAY FAM I CHAR) - (PROG1 (RETURN (BIND INPUTSTREAM for F in (OR (LISTP FILES) - (LIST FILES)) - collect (RESETLST (RESETSAVE NIL (LIST 'CLOSEF? INPUTSTREAM)) - (SETQ INPUTSTREAM (OPENSTREAM F 'INPUT)) - (SETQ CHAR (READ INPUTSTREAM FILERDTBL)) - [SETQ FAM (OR FAMILY (U-CASE (fetch SFFAMILY - of (fetch FAMILY - of CHAR] - (* ; - "the fontarray can already be here, since a single file need not contain a whole character set.") - [if (NOT (SETQ FONTARRAY (\LOOKUPSPLINEFONT FAM CHARSET))) - then (\SETSPLINEFONT FAM CHARSET (SETQ FONTARRAY - (ARRAY (ADD1 - \MAXTHINCHAR - ] - (PROG1 (CONS FAM - (bind C - repeatwhile (NEQ 'STOP (SETQ CHAR - (READ INPUTSTREAM - FILERDTBL))) - collect (SETA FONTARRAY - (SETQ C - (fetch CHARCODE - of (fetch CHARACTER - of CHAR))) - CHAR) - (PRINTOUT PROMPTWINDOW - (SETQ C (CHARACTER C))) - C)) - (CLOSEF INPUTSTREAM]) - -(SF.DERIVS.TO.BEZIER - [LAMBDA (KNOT XOFFSET YOFFSET SCALE DERIVATIVES) (* gbn " 1-Aug-84 05:51") - - (* * Compute the Bezier control points from the derivative coefficients. - Stolen from graphics>cgcubicimpl.mesa Returns an array of 4 xyz - points suitable for handing to the iris draw curve function - (IRIS.CURVE format)) - - (PROG [[BEZ (create BEZIER - B0X _ (PLUS XOFFSET (TIMES SCALE (fetch XCOORD of KNOT))) - B0Y _ (PLUS YOFFSET (TIMES SCALE (fetch YCOORD of KNOT] - (DERIVS (for I from 1 to (LENGTH DERIVATIVES) - collect (TIMES SCALE (QUOTIENT (CAR (NTH DERIVATIVES I)) - (ELT \FACT.IRIS (IQUOTIENT (ADD1 I) - 2] - (replace B1X of BEZ with (PLUS (fetch B0X of BEZ) - (QUOTIENT (fetch XPRIME of DERIVS) - 3))) - (replace B1Y of BEZ with (PLUS (fetch B0Y of BEZ) - (QUOTIENT (fetch YPRIME of DERIVS) - 3))) - (replace B2X of BEZ with (PLUS (fetch B1X of BEZ) - (QUOTIENT (PLUS (fetch XPRIME of DERIVS) - (fetch XDPRIME of DERIVS)) - 3))) - (replace B2Y of BEZ with (PLUS (fetch B1Y of BEZ) - (QUOTIENT (PLUS (fetch YPRIME of DERIVS) - (fetch YDPRIME of DERIVS)) - 3))) - (replace B3X of BEZ with (PLUS (fetch B0X of BEZ) - (fetch XPRIME of DERIVS) - (fetch XDPRIME of DERIVS) - (fetch XTPRIME of DERIVS))) - (replace B3Y of BEZ with (PLUS (fetch B0Y of BEZ) - (fetch YPRIME of DERIVS) - (fetch YDPRIME of DERIVS) - (fetch YTPRIME of DERIVS))) - (RETURN BEZ]) - -(SF.PRINT - [LAMBDA (STRING FONTFAMILY SCALE STREAM) (* ; "Edited 16-Jan-87 16:22 by gbn") - (DECLARE%: (GLOBALVARS \SPLINEFONTSINCORE)) - -(* ;;; "Uses SFDRAW to draw a single char at a time to print out a string in the chosen font. Defaults to GACHA") - - (PROG ((FONTARRAY (ASSOC (OR FONTFAMILY 'GACHA) - \SPLINEFONTSINCORE)) - CHAR CHARDESC) - (if FONTARRAY - then (SETQ FONTARRAY (CADR FONTARRAY)) - else (printout T "Spline font" %, FONTFAMILY %, - "not in core. Load it with READ.SPLINE.FONT") - (LISPERROR)) - (for I to (NCHARS STRING) do (SETQ CHAR (NTHCHARCODE STRING I)) - (SETQ CHARDESC (ELT FONTARRAY CHAR)) - (if CHARDESC - then (SFDRAW CHARDESC NIL NIL NIL SCALE STREAM) - else (* ; - "well, what to do? ignore for now. The char is not currently there") - )) - (FLUSHOUTPUT STREAM) - (RETURN STRING]) - -(SFDRAW - [LAMBDA (CHARDESC PRECISION XOFFSET YOFFSET SCALE STREAM) (* gbn "24-Oct-85 16:59") - - (* * takes a character descriptor in SF format and draws it on STREAM) - - (PROG ((PRECISION (OR PRECISION \CHARSEGMENTS.IRIS)) - (X (OR XOFFSET (DSPXPOSITION NIL STREAM))) - (Y (OR YOFFSET (DSPYPOSITION NIL STREAM))) - (SCALE (OR SCALE 1.0)) - XWIDTH) - (for CCURVE in (fetch SPLINES of CHARDESC) - do (SFDRAW.CLOSED.CURVE CCURVE PRECISION X Y SCALE STREAM)) - (MOVETO [IPLUS X (SETQ XWIDTH (TIMES SCALE (fetch XWIDTH of (fetch SF.WIDTH of CHARDESC] - [IPLUS Y (TIMES SCALE (fetch YWIDTH of (fetch SF.WIDTH of CHARDESC] - STREAM) - (RETURN XWIDTH]) - -(SFDRAW.CLOSED.CURVE - [LAMBDA (CCURVE PRECISION XOFFSET YOFFSET SCALE STREAM) (* gbn "21-Jun-85 03:00") - - (* * A closed curve looks like a list of splines. - Each spline is described by the record SF.SPLINE) - - (PROG ((STREAM (if (EQ (TYPENAME STREAM) - 'WINDOW) - then (WINDOWPROP STREAM 'DSP) - else STREAM)) - (SCALE (OR SCALE 1.0)) - SPPOUTSTREAM) - [for SPLINE in CCURVE - do - - (* if necessary destructively change the knot list to be a list of postions) - - [if [NOT (type? POSITION (CAR (fetch KNOTLIST of SPLINE] - then (for KNOT in (fetch KNOTLIST of SPLINE) do (RPLACD KNOT (CADR KNOT] - (* draw a single spline, driven off - the stream type) - (SELECTQ (TYPENAME (fetch IMAGEDATA of STREAM)) - (IRISDATA - - (* this is for the iris colour monitor, which is interested in Bezier control - points. Use the knots together with the derivative list to produce the Bezier - points to send to the Iris) - - (SETQ SPPOUTSTREAM (fetch SPPOUTSTREAM of (fetch IRISDATA of STREAM))) - (bind BEZIER for I to (SUB1 (fetch %#OFKNOTS of SPLINE)) as KNOT - in (fetch KNOTLIST of SPLINE) as DERIVS - in (fetch DERIVATIVELIST of SPLINE) - do (SETQ BEZIER (SF.DERIVS.TO.BEZIER KNOT XOFFSET YOFFSET SCALE - DERIVS)) - - (* get the bezier control points corresponding to the parametric - (derivative) definition) - - (SELECTQ \IRIS.VERSION - (GL2 (IRIS.CRV BEZIER SPPOUTSTREAM)) - (R1C (IRIS.CURVE PRECISION \BEZIERBASIS.IRIS BEZIER - SPPOUTSTREAM)) - (ERROR)))) - (\DISPLAYDATA - - (* since the display is interested in the control points in the derivative form - as found here, just call the internal parametric spline drawing routine for the - display) - (* (GLOBALRESOURCE \BRUSHBBT - (PROG ((%#KNOTS (fetch %#OFKNOTS of - SPLINE)) (BBT \BRUSHBBT) - (RESULT)) (SETQ RESULT - (create SPLINE %#KNOTS _ %#KNOTS DX _ - (ARRAY %#KNOTS 0 0.0) DDX _ - (ARRAY %#KNOTS 0 0.0) DDDX _ - (ARRAY %#KNOTS 0 0.0) DY _ - (ARRAY %#KNOTS 0 0.0) DDY _ - (ARRAY %#KNOTS 0 0.0) DDDY _ - (ARRAY %#KNOTS 0 0.0) X _ - (ARRAY %#KNOTS 0 0.0) Y _ - (ARRAY %#KNOTS 0 0.0))) - (for I to (SUB1 %#KNOTS) as KNOT in - (fetch KNOTLIST of SPLINE) as DERIVS - in (fetch DERIVATIVELIST of SPLINE) do - (SETA (fetch X of RESULT) I - (PLUS XOFFSET (TIMES SCALE - (fetch XCOORD of KNOT)))) - (SETA (fetch Y of RESULT) I - (PLUS YOFFSET (TIMES SCALE - (fetch YCOORD of KNOT)))) - (SETA (fetch (SPLINE DX) of RESULT) I - (TIMES SCALE (fetch XPRIME of DERIVS))) - (SETA (fetch DY of RESULT) I - (TIMES SCALE (fetch YPRIME of DERIVS))) - (SETA (fetch DDX of RESULT) I - (TIMES SCALE (fetch XDPRIME of DERIVS))) - (SETA (fetch DDY of RESULT) I - (TIMES SCALE (fetch YDPRIME of DERIVS))) - (SETA (fetch DDDX of RESULT) I - (TIMES SCALE (fetch XTPRIME of DERIVS))) - (SETA (fetch DDDY of RESULT) I - (TIMES SCALE (fetch YTPRIME of DERIVS))) - finally (\CURVE2 RESULT 1 NIL BBT - STREAM))))) - ) - (PROGN - - (* Don't know what kind of stream so just do it using the standard DSP fns.) - - (* * "JUNK TO NOT TYPE AGAIN" (SETQ %#KNOTS - (fetch %#OFKNOTS of SPLINE)) (replace %#KNOTS of RESULT with %#KNOTS) - (replace DX OF RESULT WITH (ARRAY %#KNOTS 0 0.0)) - (replace DDX of RESULT with (ARRAY %#KNOTS 0 0.0)) - (replace DDDX of RESULT with (ARRAY %#KNOTS 0 0.0)) - (replace DY of RESULT with (ARRAY %#KNOTS 0 0.0)) - (replace DDY of RESULT with (ARRAY %#KNOTS 0 0.0)) - (replace DDDY of RESULT with (ARRAY %#KNOTS 0 0.0)) - (replace X of RESULT with (ARRAY %#KNOTS 0 0.0)) - (replace Y of RESULT with (ARRAY %#KNOTS 0 0.0))) - - (if SCALE - then (printout T - "SCALE specified for device which does not support it") - (LISPERROR)) - (DRAWCURVE (for KNOT in (fetch KNOTLIST of SPLINE) - collect (create POSITION - XCOORD _ (PLUS (fetch XCOORD of KNOT) - XOFFSET) - YCOORD _ (PLUS (fetch YCOORD of KNOT) - YOFFSET))) - NIL NIL NIL STREAM] - (RETURN]) - -(TEST - [LAMBDA (STRING COLOR SCALE) (* gbn " 1-Aug-84 02:45") - - (* * comment) - - (PROG NIL - (IRIS.COLOR IRIS.BLACK) - (IRIS.CLEAR) - (IRIS.COLOR (OR COLOR IRIS.BLUE)) - (SF.PRINT (OR STRING "Greg") - NIL SCALE STR) - (IRIS.GFLUSH) - (RETURN]) - -(VIEW.FONT.FILES - [LAMBDA (FILES) (* edited%: " 9-Aug-84 05:35") - - (* * comment) - - (PROG (FONTARRAY FAMILY I CHAR) - (RETURN (for F in (OR (LISTP FILES) - (LIST FILES)) - collect (SETQ I (OPENSTREAM F 'INPUT)) - (SETQ CHAR (READ I)) - (CONS FAMILY (bind C repeatwhile (NEQ 'STOP (SETQ CHAR (READ I))) - collect [SETQ C (CHARACTER (fetch CHARCODE - of (fetch CHARACTER - of CHAR] - (printout T C %,) - C finally (CLOSEF I]) - -(\LOOKUPSPLINEFONT - [LAMBDA (FAMILY CHARSET) (* gbn "22-Oct-85 12:09") - - (* * if there is a font array in core for this charset of this font family, - this returns it, else nil) - - (LET ((ENTRY (SASSOC (LIST FAMILY CHARSET) - \SPLINEFONTSINCORE))) - (AND ENTRY (CDR ENTRY]) - -(\SETSPLINEFONT - [LAMBDA (FAMILY CHARSET ARRAY) (* gbn "22-Oct-85 11:42") - - (* * installs a font array in \splinefontsincore for this family and charset) - - (PUTASSOC (LIST FAMILY CHARSET) - ARRAY \SPLINEFONTSINCORE]) - -(ginit - [LAMBDA NIL (* edited%: " 6-Aug-84 12:00") - (if (MOUSECONFIRM - "do you really want to ginit. You destroy font definitions which must be reloaded?" - NIL (if (HASTTYWINDOWP) - then T - else PROMPTWINDOW)) - then (IRIS.GINIT) - (IRIS.CURSOFF) - (IRIS.CLEAR) - (makecolormap) - (IRIS.SETCURSOR 0 1 255) - (IRIS.COLOR IRIS.RED]) -) -(DECLARE%: EVAL@LOAD DONTCOPY - -(FILESLOAD (LOADCOMP) - IRISSTREAM) - - -(RPAQQ TIMESROMANDFILES (TIMESROMAND.LC1-SF;1 TIMESROMAND.LC2-SF;1 TIMESROMAND.NUM-SF;1 - TIMESROMAND.S1-SF;1 TIMESROMAND.S3-SF;1 TIMESROMAND.UC1-SF;1 - TIMESROMAND.UC2-SF;1)) - -(RPAQQ TRA - [(FAMILY TIMESROMAND) - (CHARACTER 97) - (FACE M R R) - (WIDTH 237 0) - (FIDUCIAL 385 385) - (VERSION 0 29-SEP-77 |16:35:46|) - (MADE-FROM NIL 121 130 62 40) - (SPLINES ((2 ((200 . 153) - (200 . 45)) - NIL - ((0 -108.0 0 0 0 0)) - NATURAL) - (4 ((200 . 45) - (202 . 28) - (214 . 23) - (223 . 27)) - NIL - ((-0.866666 -19.6 0 0 17.2 15.6) - (7.733334 -11.8 17.2 15.6 -26.0 -6.000002) - (11.93333 0.8000005 -8.8 9.599998 8.8 -9.599998)) - NATURAL) - (2 ((223 . 27) - (227 . 20)) - NIL - ((4.0 -7.0 0 0 0 0)) - NATURAL) - (7 ((227 . 20) - (216 . 9) - (197 . -1) - (170 . -6) - (144 . -2) - (126 . 7) - (117 . 23)) - NIL - ((-9.420512 -11.06538 0 0 -9.476924 0.3923078) - (-14.15898 -10.86923 -9.476924 0.3923078 -0.6153832 4.038461) - (-23.94359 -8.457692 -10.09231 4.430769 11.93846 7.453844) - (-28.06666 -0.2999992 1.846154 11.88461 6.861538 -9.853844) - (-22.78974 6.657692 8.707692 2.030769 2.615385 7.961536) - (-12.77436 12.66923 11.32308 9.992306 -11.32308 -9.992306)) - NATURAL) - (10 ((117 . 23) - (89 . 4) - (62 . -3) - (37 . 3) - (18 . 25) - (18 . 52) - (32 . 77) - (60 . 98) - (92 . 113) - (118 . 125)) - NIL - ((-28.15654 -21.56226 0 0 0.9392528 15.37358) - (-27.68691 -13.87547 0.9392528 15.37358 1.303736 -4.867924) - (-26.0958 -0.9358488 2.242989 10.50566 -0.1541991 10.09811) - (-23.9299 14.61887 2.08879 20.60377 23.31306 -17.52453) - (-10.18458 26.46038 25.40185 3.079245 -15.09804 -6.0) - (7.668246 26.53962 10.30381 -2.920755 7.079094 -0.4754715) - (21.51161 23.38113 17.3829 -3.396226 -13.21835 -4.098113) - (32.28533 17.93585 4.164558 -7.494339 -14.20569 4.867924) - (29.34705 12.87547 -10.04114 -2.626415 10.04114 2.626415)) - NATURAL) - (2 ((118 . 125) - (118 . 166)) - NIL - ((0 41.0 0 0 0 0)) - NATURAL) - (17 ((118 . 166) - (110 . 187) - (91 . 189) - (88 . 171) - (98 . 152) - (85 . 130) - (59 . 124) - (32 . 132) - (21 . 154) - (31 . 182) - (55 . 198) - (86 . 205) - (118 . 208) - (148 . 205) - (175 . 196) - (195 . 177) - (200 . 153)) - NIL - ((-4.255993 24.64079 0 0 -22.46404 -21.84477) - (-15.48801 13.71841 -22.46404 -21.84477 46.32022 -4.776135) - (-14.79195 -10.51443 23.85617 -26.62091 -0.8168106 34.94932) - (8.655816 -19.66068 23.03936 8.328413 -61.05298 -21.02116) - (1.168687 -21.84285 -38.01361 -12.69275 29.0287 37.13531) - (-22.33057 -15.96793 -8.984904 24.44257 4.938131 -13.52012) - (-28.8464 1.714581 -4.046773 10.92245 23.21877 4.945154) - (-21.2838 15.10961 19.172 15.86761 4.186775 -6.260496) - (-0.01840973 27.84697 23.35877 9.607112 -9.965858 -27.90316) - (18.35743 23.5025 13.39291 -18.29605 -6.323341 9.873148) - (28.58868 10.14302 7.069574 -8.422904 -6.740779 6.410579) - (32.28786 4.925408 0.3287937 -2.012324 -2.713542 -5.515475) - (31.25988 0.1553465 -2.384749 -7.527798 -0.4050512 3.651317) - (28.67261 -5.546795 -2.7898 -3.876482 -1.666252 -9.089788) - (25.04968 -13.96817 -4.456052 -12.96627 -16.92993 8.707838) - (12.12866 -22.58052 -21.38599 -4.258433 21.38599 4.258433)) - NATURAL)) - ((2 ((118 . 108) - (118 . 58)) - NIL - ((0 -50.0 0 0 0 0)) - NATURAL) - (9 ((118 . 58) - (118 . 49) - (111 . 38) - (97 . 39) - (90 . 49) - (88 . 66) - (93 . 83) - (104 . 99) - (118 . 108)) - NIL - ((1.256443 -7.739323 0 0 -7.53866 -7.564064) - (-2.512887 -11.52136 -7.53866 -7.564064 -4.3067 25.82032) - (-12.2049 -6.175257 -11.84536 18.25626 24.76546 -11.71723) - (-11.66752 6.222386 12.9201 6.539029 -10.75515 3.048599) - (-4.124999 14.28571 2.164949 9.587628 6.255152 -12.47717) - (1.167526 17.63475 8.420102 -2.889543 -2.265462 4.860088) - (8.454898 17.17526 6.154639 1.970545 -3.193299 -12.96318) - (13.01289 12.66421 2.96134 -10.99263 -2.96134 10.99263)) - NATURAL]) - -(RPAQQ TRB - [(FAMILY TIMESROMAND) - (CHARACTER 99) - (FACE M R R) - (WIDTH 211 0) - (FIDUCIAL 385 385) - (VERSION 0 29-SEP-77 |16:50:06|) - (MADE-FROM NIL 118 130 57 78) - (SPLINES ((2 ((181 . 46) - (189 . 37)) - NIL - ((8.0 -9.0 0 0 0 0)) - NATURAL) - (32 ((189 . 37) - (166 . 14) - (135 . -1) - (92 . -4) - (59 . 7) - (33 . 30) - (16 . 66) - (12 . 101) - (17 . 136) - (30 . 166) - (51 . 189) - (86 . 204) - (125 . 206) - (154 . 202) - (180 . 189) - (196 . 168) - (196 . 143) - (178 . 127) - (155 . 124) - (138 . 134) - (130 . 155) - (130 . 176) - (124 . 189) - (111 . 184) - (96 . 160) - (91 . 129) - (93 . 95) - (102 . 63) - (117 . 42) - (144 . 33) - (167 . 39) - (181 . 46)) - NIL - ((-21.8826 -24.50792 0 0 -6.704422 9.047542) - (-25.23481 -19.98415 -6.704422 9.047542 -14.47789 2.762293) - (-39.17817 -9.555464 -21.18231 11.80983 40.61599 3.903284) - (-40.05249 4.206011 19.43367 15.71312 -15.98606 -6.375422) - (-28.61185 16.73142 3.447612 9.337696 5.328262 9.5984) - (-22.50011 30.86831 8.775874 18.9361 6.673012 -26.01818) - (-10.38772 36.79532 15.44889 -7.082087 -8.020304 10.47433) - (1.051008 34.95039 7.428581 3.392247 1.408212 -9.879148) - (9.183696 33.40307 8.836792 -6.486902 -3.612545 -0.9577408) - (16.21421 26.4373 5.224247 -7.444641 13.04197 1.710107) - (27.95945 19.84771 18.26621 -5.734535 -12.55532 -11.88268) - (39.948 8.171835 5.710896 -17.61722 -22.82069 15.82064) - (34.24855 -1.535063 -17.1098 -1.796579 19.83808 -9.399882) - (27.05779 -8.031584 2.728286 -11.19646 -14.53163 3.778893) - (22.52026 -17.3386 -11.80335 -7.417568 -3.711554 0.2843065) - (8.861142 -24.61401 -15.5149 -7.133261 -6.622156 19.08388) - (-9.964836 -22.20533 -22.13706 11.95062 18.20018 1.380173) - (-23.0018 -9.564632 -3.936874 13.33079 11.82142 -0.6045686) - (-21.02796 3.463873 7.884551 12.72622 0.5141201 1.038099) - (-12.88635 16.70915 8.39867 13.76432 4.122093 -15.54783) - (-2.426633 22.69955 12.52076 -1.783509 -23.00249 -4.846774) - (-1.407115 18.49265 -10.48173 -6.630284 3.887866 -13.06508) - (-9.944906 5.329831 -6.59386 -19.69536 1.451023 -2.892914) - (-15.81326 -15.81199 -5.142837 -22.58827 20.30804 18.63673) - (-10.80207 -29.08189 15.16521 -3.951541 -10.6832 0.3459764) - (-0.978461 -32.86044 4.482012 -3.605564 4.424731 3.979362) - (5.715916 -34.47633 8.906742 0.373798 -7.015726 13.73657) - (11.1148 -27.23424 1.891017 14.11037 17.63817 -4.92565) - (21.8249 -15.5867 19.52919 9.184722 -27.53697 11.96602) - (27.5856 -0.4189663 -8.007784 21.15074 -3.490269 -24.93843) - (17.83268 8.262562 -11.49805 -3.787686 11.49805 3.787686)) - NATURAL]) - -(RPAQQ TRC - [(FAMILY TIMESROMAND) - (CHARACTER 100) - (FACE M R R) - (WIDTH 250 0) - (FIDUCIAL 385 385) - (VERSION 0 29-SEP-77 |16:56:16|) - (MADE-FROM NIL 103 130 57 78) - (SPLINES ((2 ((136 . 269) - (136 . 189)) - NIL - ((0 -80.0 0 0 0 0)) - NATURAL) - (15 ((136 . 189) - (114 . 204) - (86 . 211) - (57 . 203) - (40 . 190) - (25 . 168) - (16 . 140) - (12 . 110) - (13 . 82) - (20 . 51) - (32 . 28) - (52 . 8) - (82 . -2) - (111 . 7) - (136 . 25)) - NIL - ((-20.69145 16.12365 0 0 -7.851328 -6.741922) - (-24.61711 12.75269 -7.851328 -6.741922 3.256639 -14.29039) - (-30.84012 -1.134427 -4.594689 -21.03232 24.82477 21.9035) - (-23.02242 -11.21499 20.23008 0.8711902 -24.55573 -13.32363) - (-15.0702 -17.00562 -4.325648 -12.45244 13.39815 7.391023) - (-12.69677 -25.76255 9.072504 -5.061419 -5.036883 1.759538) - (-6.142708 -29.9442 4.035622 -3.30188 0.749383 9.57082) - (-1.732394 -28.46066 4.785005 6.268941 2.039351 -16.04282) - (4.072286 -30.21314 6.824355 -9.773884 -2.906779 24.60048) - (9.443252 -27.68678 3.917576 14.82659 3.587763 -16.35907) - (15.15471 -21.03973 7.505339 -1.532484 6.555731 10.83583) - (25.93791 -17.1543 14.06107 9.303344 -17.81069 15.01576) - (31.09364 -0.3430727 -3.749619 24.31911 -1.312975 -16.89888) - (26.68753 15.52659 -5.062595 7.420223 5.062595 -7.420223)) - NATURAL) - (2 ((136 . 25) - (136 . -3)) - NIL - ((0 -28.0 0 0 0 0)) - NATURAL) - (2 ((136 . -3) - (241 . 10)) - NIL - ((105.0 13.0 0 0 0 0)) - NATURAL) - (2 ((241 . 10) - (241 . 15)) - NIL - ((0 5.0 0 0 0 0)) - NATURAL) - (5 ((241 . 15) - (231 . 19) - (222 . 26) - (217 . 37) - (217 . 50)) - NIL - ((-10.07143 3.446428 0 0 0.4285715 3.321429) - (-9.857142 5.107143 0.4285715 3.321429 3.857143 1.392856) - (-7.5 9.125 4.285714 4.714285 2.142858 -2.892857) - (-2.142857 12.39286 6.428572 1.821428 -6.428572 -1.821428)) - NATURAL) - (2 ((217 . 50) - (217 . 300)) - NIL - ((0 250.0 0 0 0 0)) - NATURAL) - (2 ((217 . 300) - (117 . 300)) - NIL - ((-100.0 0 0 0 0 0)) - NATURAL) - (2 ((117 . 300) - (117 . 295)) - NIL - ((0 -5.0 0 0 0 0)) - NATURAL) - (4 ((117 . 295) - (128 . 291) - (134 . 283) - (136 . 269)) - NIL - ((12.06667 -3.333333 0 0 -6.4 -4.0) - (8.866666 -5.333333 -6.4 -4.0 2.0 -4.0) - (3.466666 -11.33333 -4.4 -8.0 4.4 8.0)) - NATURAL)) - ((2 ((136 . 159) - (136 . 79)) - NIL - ((0 -80.0 0 0 0 0)) - NATURAL) - (12 ((136 . 79) - (133 . 52) - (122 . 34) - (108 . 40) - (100 . 62) - (96 . 88) - (95 . 116) - (97 . 143) - (104 . 168) - (117 . 179) - (130 . 174) - (136 . 159)) - NIL - ((-1.169987 -27.97882 0 0 -10.98008 5.872907) - (-6.660026 -25.04236 -10.98008 5.872907 6.900384 24.63546) - (-14.18991 -6.851724 -4.079692 30.50837 13.37854 -14.41478) - (-11.58033 16.44926 9.298848 16.0936 -6.414546 -14.97637) - (-5.488757 25.05467 2.884301 1.117225 0.279644 2.320276) - (-2.464635 27.33204 3.163945 3.437501 -0.7040282 -6.304729) - (0.3472968 27.61717 2.459917 -2.867228 2.536468 4.898638) - (4.075448 27.19927 4.996385 2.03141 2.558155 -19.28982) - (10.35091 19.58576 7.55454 -17.25841 -6.769083 0.2606583) - (14.52091 2.457678 0.785456 -16.99775 -11.48182 6.247193) - (9.565454 -11.41648 -10.69636 -10.75056 10.69636 10.75056)) - NATURAL]) - -(RPAQQ TRFILES ({INDIGO}OLDSF>TIMESROMAND.LC1-SF;1 - {INDIGO}OLDSF>TIMESROMAND.LC2-SF;1 - {INDIGO}OLDSF>TIMESROMAND.NUM-SF;1 - {INDIGO}OLDSF>TIMESROMAND.S1-SF;1 - {INDIGO}OLDSF>TIMESROMAND.S3-SF;1 - {INDIGO}OLDSF>TIMESROMAND.UC1-SF;1 - {INDIGO}OLDSF>TIMESROMAND.UC2-SF;1)) -) - -(RPAQ? \SPLINEFONTSINCORE (LIST NIL)) -(DECLARE%: DOEVAL@COMPILE DONTCOPY - -(GLOBALVARS \SPLINEFONTSINCORE) -) -(DECLARE%: EVAL@COMPILE - -(RPAQQ \CHARSEGMENTS.IRIS 10) - - -(CONSTANTS (\CHARSEGMENTS.IRIS 10)) -) -(PUTPROPS SFFONT COPYRIGHT ("Venue" 1991)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL (1784 19991 (READ.SPLINE.FONT 1794 . 4813) (SF.DERIVS.TO.BEZIER 4815 . 7456) (SF.PRINT -7458 . 8733) (SFDRAW 8735 . 9574) (SFDRAW.CLOSED.CURVE 9576 . 17439) (TEST 17441 . 17819) ( -VIEW.FONT.FILES 17821 . 18759) (\LOOKUPSPLINEFONT 18761 . 19148) (\SETSPLINEFONT 19150 . 19442) (ginit - 19444 . 19989))))) -STOP diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.LC1-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.LC1-SF deleted file mode 100644 index 3746dd3c..00000000 --- a/obsolete/lispusers/splinefonts/TIMESROMAN.LC1-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY TIMESROMAND) (CHARACTER 141Q) (FACE M R R) (WIDTH 237 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 16:35:46) (MADE-FROM NIL 121 130 62 40) (SPLINES ((2 ((200 153) (200 45)) NIL ((0 -108. 0 0 0 0 )) NATURAL) (4 ((200 45) (202 28) (214 23) (223 27)) NIL ((-0.866666079 -19.599998 0 0 17.1999969 15.6 ) (7.73333359 -11.799999 17.1999969 15.6 -25.999996 -6.0000019 ) (11.933332 0.800000430 -8.79999925 9.59999848 8.79999925 -9.59999848 )) NATURAL) (2 ((223 27) (227 20)) NIL ((4. -7. 0 0 0 0 )) NATURAL) (7 ((227 20) (216 9) (197 -1) (170 -6) (144 -2) (126 7) (117 23)) NIL ((-9.42051126 -11.0653839 0 0 -9.476923 0.392307758 ) (-14.1589737 -10.86923 -9.476923 0.392307758 -0.615383148 4.03846073 ) (-23.943588 -8.4576912 -10.092306 4.43076897 11.938459 7.45384408 ) (-28.066665 -0.299999237 1.84615373 11.884613 6.86153699 -9.8538437 ) (-22.789741 6.65769196 8.7076912 2.03076935 2.61538505 7.9615364 ) (-12.7743587 12.669231 11.323076 9.99230577 -11.323076 -9.99230577 )) NATURAL) (10 ((117 23) (89 4) (62 -3) (37 3) (18 25) (18 52) (32 77) (60 98) (92 113) (118 125)) NIL ((-28.156539 -21.562263 0 0 0.939252735 15.373584 ) (-27.686912 -13.875471 0.939252735 15.373584 1.30373621 -4.86792374 ) (-26.095794 -0.935848833 2.24298906 10.505661 -0.154199123 10.09811 ) (-23.9299 14.6188678 2.08878994 20.603771 23.313056 -17.524524 ) (-10.1845836 26.460376 25.401847 3.07924461 -15.098037 -5.99999905 ) (7.6682453 26.539619 10.30381 -2.92075443 7.07909394 -0.475471497 ) (21.511604 23.38113 17.382904 -3.39622593 -13.218345 -4.09811306 ) (32.285331 17.935848 4.16455746 -7.494339 -14.205694 4.86792374 ) (29.347045 12.875471 -10.0411377 -2.62641525 10.0411377 2.62641525 )) NATURAL) (2 ((118 125) (118 166)) NIL ((0 41. 0 0 0 0 )) NATURAL) (17 ((118 166) (110 187) (91 189) (88 171) (98 152) (85 130) (59 124) (32 132) (21 154) (31 182) (55 198) (86 205) (118 208) (148 205) (175 196) (195 177) (200 153)) NIL ((-4.25599289 24.640792 0 0 -22.464042 -21.844772 ) (-15.488014 13.718408 -22.464042 -21.844772 46.320213 -4.77613449 ) (-14.79195 -10.5144329 23.85617 -26.620906 -0.816810609 34.949317 ) (8.6558151 -19.660678 23.03936 8.328413 -61.05297 -21.02116 ) (1.16868734 -21.842845 -38.01361 -12.692747 29.028705 37.135314 ) (-22.330566 -15.967931 -8.98490335 24.442573 4.93813038 -13.52012 ) (-28.846405 1.71458101 -4.04677296 10.9224529 23.218769 4.94515419 ) (-21.283794 15.109611 19.171997 15.867607 4.1867752 -6.26049615 ) (-0.0184097290 27.846969 23.358772 9.60711099 -9.96585847 -27.90316 ) (18.357429 23.502498 13.3929138 -18.296051 -6.3233404 9.87314797 ) (28.588676 10.1430206 7.0695734 -8.42290307 -6.74077893 6.41057873 ) (32.287857 4.9254074 0.328793704 -2.01232386 -2.71354198 -5.5154743 ) (31.25988 0.155346542 -2.38474846 -7.52779866 -0.405051231 3.65131664 ) (28.672607 -5.54679394 -2.78979969 -3.876482 -1.66625213 -9.08978845 ) (25.049678 -13.96817 -4.45605183 -12.96627 -16.929931 8.70783807 ) (12.128662 -22.58052 -21.385986 -4.25843239 21.385986 4.25843239 )) NATURAL)) ((2 ((118 108) (118 58)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (9 ((118 58) (118 49) (111 38) (97 39) (90 49) (88 66) (93 83) (104 99) (118 108)) NIL ((1.25644326 -7.73932267 0 0 -7.53866006 -7.564064 ) (-2.51288652 -11.5213546 -7.53866006 -7.564064 -4.30669976 25.82032 ) (-12.2048969 -6.17525674 -11.8453598 18.256256 24.76546 -11.7172279 ) (-11.667524 6.2223854 12.920101 6.53902817 -10.7551517 3.04859924 ) (-4.12499905 14.285713 2.16494894 9.5876274 6.25515175 -12.477169 ) (1.16752624 17.634754 8.42010118 -2.88954306 -2.26546192 4.8600874 ) (8.4548969 17.175254 6.15463925 1.97054457 -3.19329929 -12.9631767 ) (13.012886 12.664211 2.96133995 -10.9926338 -2.96133995 10.9926338 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 142Q) (FACE M R R) (WIDTH 252 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 16:44:21) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((112 300) (112 183)) NIL ((0 -117. 0 0 0 0 )) NATURAL) (15 ((112 183) (138 201) (165 207) (195 200) (219 179) (232 150) (238 103) (232 67) (216 33) (186 8) (156 -2) (126 -3) (101 2) (84 11) (67 26)) NIL ((26.012008 20.539005 0 0 -0.0720686913 -15.234035 ) (25.975975 12.921987 -0.0720686913 -15.234035 6.36034299 4.17017746 ) (29.084079 -0.226958573 6.28827477 -11.063858 -13.3693046 -7.44667435 ) (28.687698 -15.014154 -7.08103085 -18.510532 -6.8831148 19.616527 ) (18.165111 -23.716423 -13.964145 1.10599708 10.901762 -35.019447 ) (9.6518459 -40.120147 -3.06238365 -33.913452 -12.723934 60.46128 ) (0.227496445 -43.802963 -15.7863178 26.547828 9.9939747 -32.82569 ) (-10.561834 -33.667976 -5.79234314 -6.2778654 -15.2519607 16.841495 ) (-23.980155 -31.525096 -21.044303 10.563631 27.013866 7.45970345 ) (-31.517528 -17.231613 5.96956349 18.023334 -8.80351258 -10.680305 ) (-29.949722 -4.5484333 -2.83395004 7.343029 8.20018579 -0.738483429 ) (-28.683578 2.42535353 5.36623669 6.6045456 6.0027647 -4.36575794 ) (-20.315956 6.84702016 11.369001 2.23878765 -14.211252 6.20151425 ) (-16.0525818 12.186565 -2.84225082 8.4403019 2.84225082 -8.4403019 )) NATURAL) (2 ((67 26) (36 -3)) NIL ((-31. -29. 0 0 0 0 )) NATURAL) (2 ((36 -3) (31 -3)) NIL ((-5. 0 0 0 0 0 )) NATURAL) (2 ((31 -3) (31 269)) NIL ((0 272. 0 0 0 0 )) NATURAL) (4 ((31 269) (29 283) (23 291) (12 295)) NIL ((-1.26666665 15.333332 0 0 -4.39999962 -8. ) (-3.4666667 11.333332 -4.39999962 -8. -2. 4. ) (-8.8666668 5.333333 -6.3999996 -4. 6.3999996 4. )) NATURAL) (2 ((12 295) (12 300)) NIL ((0 5. 0 0 0 0 )) NATURAL) (2 ((12 300) (112 300)) NIL ((100. 0 0 0 0 0 )) NATURAL)) ((2 ((112 44) (112 151)) NIL ((0 107. 0 0 0 0 )) NATURAL) (13 ((112 151) (119 172) (133 174) (144 161) (150 140) (152 115) (152 86) (150 56) (144 30) (134 16) (123 13) (114 24) (112 44)) NIL ((4.9868555 25.152385 0 0 12.078863 -24.914325 ) (11.026287 12.6952228 12.078863 -24.914325 -18.394321 10.57164 ) (13.907989 -6.9332838 -6.3154583 -14.3426857 1.4984293 6.62775994 ) (8.34174539 -17.962089 -4.817029 -7.71492577 0.400608063 4.91731739 ) (3.72502089 -23.218357 -4.41642094 -2.79760837 2.89913463 -2.29703045 ) (0.758167506 -27.164478 -1.51728606 -5.09463883 0.00285267830 4.2708044 ) (-0.757692457 -30.123714 -1.51443338 -0.823834062 -2.91054487 3.21380949 ) (-3.7273984 -29.340644 -4.42497826 2.38997555 -0.360672951 12.8739547 ) (-8.33271218 -20.51369 -4.7856512 15.263931 4.3532362 -6.70962716 ) (-10.9417457 -8.6045761 -0.432414532 8.5543041 0.947724820 7.9645443 ) (-10.900297 3.93200302 0.515310288 16.518848 9.85586167 -7.14856339 ) (-5.457057 16.876571 10.3711719 9.37028504 -10.3711719 -9.37028504 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 143Q) (FACE M R R) (WIDTH 211 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 16:50:06) (MADE-FROM NIL 118 130 57 78) (SPLINES ((2 ((181 46) (189 37)) NIL ((8. -9. 0 0 0 0 )) NATURAL) (32 ((189 37) (166 14) (135 -1) (92 -4) (59 7) (33 30) (16 66) (12 101) (17 136) (30 166) (51 189) (86 204) (125 206) (154 202) (180 189) (196 168) (196 143) (178 127) (155 124) (138 134) (130 155) (130 176) (124 189) (111 184) (96 160) (91 129) (93 95) (102 63) (117 42) (144 33) (167 39) (181 46)) NIL ((-21.882595 -24.507923 0 0 -6.704422 9.04754067 ) (-25.234806 -19.984149 -6.704422 9.04754067 -14.47789 2.76229286 ) (-39.178169 -9.5554638 -21.182312 11.809833 40.615982 3.90328407 ) (-40.05249 4.20601082 19.433673 15.713117 -15.986061 -6.37542153 ) (-28.611846 16.731418 3.4476118 9.33769609 5.32826138 9.5984001 ) (-22.500103 30.868312 8.77587319 18.936096 6.67301179 -26.01818 ) (-10.3877239 36.795318 15.4488849 -7.0820856 -8.02030374 10.4743309 ) (1.05100774 34.950393 7.42858029 3.39224672 1.40821170 -9.87914659 ) (9.18369485 33.403068 8.836792 -6.48690034 -3.61254501 -0.957740784 ) (16.214214 26.437301 5.22424698 -7.4446411 13.041965 1.71010685 ) (27.959445 19.847713 18.266212 -5.73453427 -12.5553169 -11.8826828 ) (39.947998 8.17183496 5.71089459 -17.617218 -22.820686 15.820638 ) (34.24855 -1.53506326 -17.109794 -1.79657936 19.838077 -9.39988137 ) (27.057792 -8.0315838 2.72828531 -11.1964607 -14.531629 3.77889252 ) (22.520263 -17.3386 -11.8033447 -7.4175682 -3.71155357 0.284306526 ) (8.8611412 -24.614013 -15.514898 -7.13326169 -6.62215615 19.083877 ) (-9.9648361 -22.205333 -22.137054 11.9506168 18.20018 1.38017273 ) (-23.0018 -9.5646324 -3.93687344 13.330789 11.821422 -0.604568482 ) (-21.027961 3.4638729 7.8845501 12.726221 0.514120102 1.03809929 ) (-12.8863506 16.709144 8.3986702 13.76432 4.1220932 -15.547828 ) (-2.42663336 22.699546 12.520763 -1.78350925 -23.002487 -4.8467741 ) (-1.40711474 18.492652 -10.4817257 -6.63028336 3.88786602 -13.0650749 ) (-9.9449062 5.32983113 -6.59385968 -19.695358 1.4510231 -2.89291382 ) (-15.813255 -15.811985 -5.14283657 -22.588272 20.30804 18.63673 ) (-10.8020706 -29.08189 15.1652069 -3.95154047 -10.683195 0.345976353 ) (-0.978460909 -32.860443 4.4820118 -3.60556412 4.4247303 3.979362 ) (5.71591568 -34.476326 8.9067421 0.373797953 -7.01572514 13.736572 ) (11.1147956 -27.234241 1.89101648 14.11037 17.638172 -4.92564965 ) (21.824897 -15.586696 19.52919 9.184721 -27.536972 11.96602 ) (27.585601 -0.418966293 -8.0077839 21.150741 -3.4902687 -24.938427 ) (17.832683 8.2625618 -11.4980526 -3.78768539 11.4980526 3.78768539 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 144Q) (FACE M R R) (WIDTH 250 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 16:56:16) (MADE-FROM NIL 103 130 57 78) (SPLINES ((2 ((136 269) (136 189)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (15 ((136 189) (114 204) (86 211) (57 203) (40 190) (25 168) (16 140) (12 110) (13 82) (20 51) (32 28) (52 8) (82 -2) (111 7) (136 25)) NIL ((-20.691444 16.123653 0 0 -7.8513279 -6.74192143 ) (-24.617107 12.752691 -7.8513279 -6.74192143 3.25663948 -14.2903919 ) (-30.840114 -1.13442683 -4.59468842 -21.032314 24.824771 21.903503 ) (-23.022419 -11.2149887 20.230083 0.871190191 -24.555728 -13.323631 ) (-15.0701999 -17.005615 -4.32564736 -12.452442 13.398151 7.39102364 ) (-12.6967716 -25.762546 9.07250405 -5.06141854 -5.0368824 1.75953817 ) (-6.14270783 -29.944194 4.03562165 -3.30188036 0.749382973 9.57081986 ) (-1.73239398 -28.460662 4.7850046 6.26894093 2.03935051 -16.0428238 ) (4.07228565 -30.213134 6.82435513 -9.7738838 -2.90677929 24.600475 ) (9.44325067 -27.686782 3.91757584 14.826591 3.58776283 -16.359073 ) (15.1547088 -21.039726 7.50533867 -1.53248405 6.5557308 10.8358268 ) (25.937912 -17.1542969 14.061069 9.3033428 -17.810688 15.015764 ) (31.093635 -0.343072712 -3.749619 24.319107 -1.31297540 -16.8988838 ) (26.68753 15.526592 -5.0625944 7.42022229 5.0625944 -7.42022229 )) NATURAL) (2 ((136 25) (136 -3)) NIL ((0 -28. 0 0 0 0 )) NATURAL) (2 ((136 -3) (241 10)) NIL ((105. 13. 0 0 0 0 )) NATURAL) (2 ((241 10) (241 15)) NIL ((0 5. 0 0 0 0 )) NATURAL) (5 ((241 15) (231 19) (222 26) (217 37) (217 50)) NIL ((-10.071428 3.4464283 0 0 0.428571463 3.32142878 ) (-9.8571415 5.10714245 0.428571463 3.32142878 3.85714245 1.39285612 ) (-7.5 9.125 4.28571415 4.7142849 2.14285755 -2.8928566 ) (-2.14285707 12.392856 6.4285717 1.8214283 -6.4285717 -1.8214283 )) NATURAL) (2 ((217 50) (217 300)) NIL ((0 250. 0 0 0 0 )) NATURAL) (2 ((217 300) (117 300)) NIL ((-100. 0 0 0 0 0 )) NATURAL) (2 ((117 300) (117 295)) NIL ((0 -5. 0 0 0 0 )) NATURAL) (4 ((117 295) (128 291) (134 283) (136 269)) NIL ((12.0666656 -3.33333302 0 0 -6.3999996 -4. ) (8.8666649 -5.333333 -6.3999996 -4. 2. -4. ) (3.46666622 -11.333332 -4.39999962 -8. 4.39999962 8. )) NATURAL)) ((2 ((136 159) (136 79)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (12 ((136 79) (133 52) (122 34) (108 40) (100 62) (96 88) (95 116) (97 143) (104 168) (117 179) (130 174) (136 159)) NIL ((-1.1699872 -27.978817 0 0 -10.9800758 5.87290669 ) (-6.6600256 -25.042362 -10.9800758 5.87290669 6.90038396 24.635463 ) (-14.189909 -6.85172368 -4.07969189 30.508373 13.378538 -14.4147758 ) (-11.5803318 16.44926 9.2988472 16.093597 -6.414546 -14.9763717 ) (-5.48875714 25.054672 2.88430118 1.11722469 0.279644012 2.32027578 ) (-2.46463442 27.332035 3.1639452 3.43750048 -0.704028130 -6.30472756 ) (0.347296834 27.617172 2.45991707 -2.86722755 2.53646755 4.89863777 ) (4.07544804 27.199264 4.99638462 2.03141022 2.55815506 -19.289821 ) (10.35091 19.585762 7.55453969 -17.258411 -6.76908303 0.260658264 ) (14.520908 2.45767784 0.785455943 -16.997753 -11.481819 6.24719239 ) (9.56545449 -11.416479 -10.696363 -10.7505607 10.696363 10.7505607 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 145Q) (FACE M R R) (WIDTH 211 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 17:02:38) (MADE-FROM NIL 118 130 57 78) (SPLINES ((19 ((200 104) (197 137) (186 166) (170 186) (148 200) (119 206) (86 205) (51 189) (30 166) (17 136) (12 101) (16 66) (32 30) (59 7) (92 -5) (123 -5) (153 7) (175 25) (195 50)) NIL ((-1.13248205 33.50447 0 0 -11.2051067 -3.02686691 ) (-6.73503495 31.991043 -11.2051067 -3.02686691 8.02553369 -8.86566545 ) (-13.9273739 24.531341 -3.1795721 -11.892532 -2.89703178 8.48953248 ) (-18.555461 16.883575 -6.0766039 -3.4029994 -2.43740368 -7.09246636 ) (-25.850769 9.93434335 -8.51400758 -10.495466 6.6466446 7.880332 ) (-31.041454 3.37904358 -1.86736274 -2.61513424 -6.14917756 -18.428859 ) (-35.983406 -8.45052148 -8.01654054 -21.043994 29.950065 17.835117 ) (-29.024913 -20.576957 21.933525 -3.20887518 -17.651088 -4.9116268 ) (-15.916933 -26.241645 4.28243447 -8.12050248 4.65429688 1.81138706 ) (-9.30734826 -33.45645 8.93673135 -6.3091154 -0.966098786 9.66608239 ) (-0.853666306 -34.932525 7.97063256 3.35696745 5.21010018 -10.475719 ) (9.72201539 -36.813415 13.1807327 -7.11875249 -1.8743 26.236793 ) (21.965599 -30.813774 11.3064327 19.118042 -3.71290112 -10.4714679 ) (31.41558 -16.931465 7.5935316 8.646574 -13.274093 3.64907837 ) (32.372062 -6.46035195 -5.68056298 12.295652 8.8092842 1.87515449 ) (31.096145 6.7728777 3.12872219 14.1708069 -15.963047 -11.1496887 ) (26.243343 15.368839 -12.8343258 3.02111721 13.0429058 6.72360325 ) (19.930469 21.751758 0.208581745 9.74472047 -0.208581745 -9.74472047 )) NATURAL) (2 ((195 50) (185 59)) NIL ((-10. 9. 0 0 0 0 )) NATURAL) (7 ((185 59) (165 43) (143 36) (114 46) (99 67) (94 87) (93 104)) NIL ((-20.189743 -17.4038429 0 0 1.13846111 8.42307664 ) (-19.62051 -13.192306 1.13846111 8.42307664 -17.692302 11.884613 ) (-27.328205 1.17307806 -16.553844 20.307689 39.63076 -7.9615383 ) (-24.066661 17.5 23.076919 12.346151 -14.830766 -16.0384559 ) (-8.40512658 21.826919 8.24615289 -3.692307 -4.30769062 0.115384102 ) (-2.31282043 18.192306 3.93846178 -3.57692289 -3.93846178 3.57692289 )) NATURAL) (2 ((93 104) (200 104)) NIL ((107. 0 0 0 0 0 )) NATURAL)) ((9 ((93 122) (92 141) (93 158) (97 178) (111 188) (125 178) (129 158) (130 141) (129 122)) NIL ((-1.5 19.855667 0 0 3. -5.13401985 ) (0 17.288658 3. -5.13401985 -3. 13.670101 ) (1.5 18.989688 0 8.5360813 15. -19.546386 ) (9. 17.7525749 15. -11.010307 -15. -13.484535 ) (16.5 -9.53674316E-7 0 -24.494842 -15. 13.484533 ) (8.9999981 -17.7525749 -15. -11.010309 15. 19.54639 ) (1.49999976 -18.989688 1.27768117E-7 8.5360813 -3. -13.670101 ) (0 -17.288658 -3. -5.13401985 3. 5.13401985 )) NATURAL) (2 ((129 122) (93 122)) NIL ((-36. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 146Q) (FACE M R R) (WIDTH 206 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 17:13:04) (MADE-FROM NIL 141 130 57 78) (SPLINES ((2 ((123 36) (123 182)) NIL ((0 146. 0 0 0 0 )) NATURAL) (2 ((123 182) (153 182)) NIL ((30. 0 0 0 0 0 )) NATURAL) (2 ((153 182) (153 200)) NIL ((0 18. 0 0 0 0 )) NATURAL) (2 ((153 200) (123 200)) NIL ((-30. 0 0 0 0 0 )) NATURAL) (2 ((123 200) (123 240)) NIL ((0 40. 0 0 0 0 )) NATURAL) (17 ((123 240) (121 259) (120 275) (128 285) (134 278) (134 266) (148 248) (171 244) (191 257) (191 283) (174 298) (150 303) (125 303) (94 297) (69 286) (48 266) (41 240)) NIL ((-1.63036418 19.686523 0 0 -2.21781492 -4.11915779 ) (-2.73927164 17.626945 -2.21781492 -4.11915779 17.089073 2.59579229 ) (3.58745146 14.805685 14.871259 -1.52336526 -18.138488 -24.264011 ) (9.3894653 1.15031027 -3.26723003 -25.78738 -10.53511 28.460277 ) (0.854681612 -10.4069309 -13.802341 2.67289829 36.27893 -17.577106 ) (5.1918087 -16.5225868 22.476593 -14.904209 -14.580635 35.848144 ) (20.378082 -13.5027198 7.89595795 20.943939 -7.9563837 -5.81549454 ) (24.295848 4.53347206 -0.0604261532 15.128444 -25.593822 5.4138298 ) (11.4385109 22.368831 -25.65425 20.542274 8.3316803 -39.83982 ) (-10.0499019 22.991195 -17.32257 -19.297546 10.267128 9.9454651 ) (-22.238906 8.66637994 -7.05544186 -9.3520813 10.5997829 6.05795956 ) (-23.994457 2.34327888 3.54434252 -3.29412127 -16.666267 -4.17730904 ) (-28.783252 -3.03949785 -13.121927 -7.47143078 26.0653 4.65127945 ) (-28.872528 -8.18528939 12.9433727 -2.82015133 -15.594938 -8.42780686 ) (-23.726623 -15.219345 -2.65156555 -11.247959 24.314453 5.05994892 ) (-14.220962 -23.937328 21.662887 -6.1880102 -21.662887 6.1880102 )) NATURAL) (2 ((41 240) (41 200)) NIL ((0 -40. 0 0 0 0 )) NATURAL) (2 ((41 200) (11 200)) NIL ((-30. 0 0 0 0 0 )) NATURAL) (2 ((11 200) (11 182)) NIL ((0 -18. 0 0 0 0 )) NATURAL) (2 ((11 182) (41 182)) NIL ((30. 0 0 0 0 0 )) NATURAL) (2 ((41 182) (41 36)) NIL ((0 -146. 0 0 0 0 )) NATURAL) (4 ((41 36) (38 19) (30 11) (18 8)) NIL ((-1.93333339 -19.066665 0 0 -6.3999996 12.3999996 ) (-5.1333332 -12.8666649 -6.3999996 12.3999996 2. -8. ) (-10.5333328 -4.46666622 -4.39999962 4.39999962 4.39999962 -4.39999962 )) NATURAL) (2 ((18 8) (18 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((18 0) (146 0)) NIL ((128. 0 0 0 0 0 )) NATURAL) (2 ((146 0) (146 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((146 8) (134 11) (126 19) (123 36)) NIL ((-12.7333316 2.26666641 0 0 4.39999962 4.39999962 ) (-10.5333328 4.46666622 4.39999962 4.39999962 2. 8. ) (-5.1333332 12.8666668 6.3999996 12.3999996 -6.3999996 -12.3999996 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 147Q) (FACE M R R) (WIDTH 243 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 17:37:45) (MADE-FROM NIL 114 130 44 38) (SPLINES ((2 ((228 196) (228 173)) NIL ((0 -23. 0 0 0 0 )) NATURAL) (2 ((228 173) (198 173)) NIL ((-30. 0 0 0 0 0 )) NATURAL) (29 ((198 173) (209 151) (211 124) (201 98) (178 80) (151 70) (121 68) (95 64) (89 55) (101 47) (129 44) (161 43) (187 38) (209 28) (222 17) (229 3) (230 -24) (218 -47) (192 -64) (156 -74) (119 -76) (91 -75) (66 -72) (41 -66) (20 -53) (15 -37) (28 -25) (47 -19) (63 -14)) NIL ((12.78347 -20.712417 0 0 -10.7008228 -7.7254791 ) (7.43305874 -24.575157 -10.7008228 -7.7254791 -0.495885849 8.62739755 ) (-3.51570749 -27.986938 -11.1967086 0.901919008 -5.31562805 9.21588326 ) (-17.370227 -22.477077 -16.512336 10.1178035 15.758396 -3.49094486 ) (-26.003368 -14.1047439 -0.753939868 6.6268587 -3.71796274 4.74789715 ) (-28.61629 -5.1039362 -4.47190285 11.3747558 5.11345577 -15.500644 ) (-30.531463 -1.47950363 0.641553402 -4.12588978 25.264133 -2.74530792 ) (-17.257843 -6.97804738 25.905689 -6.8711977 -10.169996 8.48187829 ) (3.56284761 -9.60830499 15.7356929 1.61068225 3.41583443 4.81778527 ) (21.006458 -5.58872986 19.151527 6.42846776 -15.493345 -3.75302172 ) (32.411308 -1.03677320 3.65818119 2.67544603 -13.442436 -7.8056984 ) (29.348274 -2.26417684 -9.78425599 -5.13025284 9.2631035 -1.02417946 ) (24.195571 -7.90651894 -0.521150828 -6.1544323 -11.609985 5.90241528 ) (17.869426 -11.109743 -12.1311378 -0.252016604 7.17684079 1.41451549 ) (9.32670976 -10.6545028 -4.95429707 1.16249895 0.902627946 -23.560474 ) (4.82372666 -21.272243 -4.05166912 -22.397975 -10.787355 32.8274 ) (-4.62162113 -27.256519 -14.839025 10.429424 0.246803283 -5.7491474 ) (-19.3372459 -19.701667 -14.592222 4.68027687 3.80014229 2.1691885 ) (-32.029396 -13.936798 -10.7920799 6.84946538 8.55262567 3.07239437 ) (-38.545158 -5.5511341 -2.23945331 9.92185975 15.989345 -8.45877076 ) (-32.789939 0.141339540 13.749893 1.46308779 -12.5100116 0.762699366 ) (-25.295055 1.9857769 1.23988032 2.22578716 -1.94929528 -0.592023611 ) (-25.029823 3.91555214 -0.709414959 1.63376355 2.30719423 7.60539437 ) (-24.585639 9.35201264 1.59777927 9.2391586 16.720512 -5.8295555 ) (-14.627601 15.676393 18.318294 3.40960312 2.81072998 -8.2871742 ) (5.0960598 14.942409 21.129024 -4.87757206 -15.963432 -3.02174187 ) (18.243366 8.5539665 5.1655922 -7.8993139 -10.956989 8.3741417 ) (17.930465 4.84172344 -5.7913971 0.474828482 5.7913971 -0.474828482 )) NATURAL) (8 ((63 -14) (45 -8) (30 3) (22 20) (25 40) (40 55) (59 64) (81 71)) NIL ((-18.455513 5.01511479 0 0 2.73308134 5.90930939 ) (-17.08897 7.96976948 2.73308134 5.90930939 4.33459187 0.453452110 ) (-12.1885948 14.105804 7.06767369 6.3627615 3.92854786 -1.72311878 ) (-3.15664673 19.607006 10.9962215 4.6396427 3.95121765 -11.560976 ) (9.81518365 18.466159 14.947439 -6.9213333 -13.733423 -0.0329771042 ) (17.895908 11.528339 1.21401572 -6.9543104 2.98248005 5.69288826 ) (20.601165 7.42047406 4.196496 -1.26142215 -4.196496 1.26142215 )) NATURAL) (13 ((81 71) (49 84) (30 100) (17 122) (16 147) (23 169) (38 186) (57 197) (84 203) (112 205) (133 204) (160 199) (178 196)) NIL ((-35.25244 12.5588417 0 0 19.514675 2.64694261 ) (-25.495105 13.8823127 19.514675 2.64694261 -19.573375 4.76528645 ) (-15.76712 18.911899 -0.0587015748 7.41222954 16.778831 -3.70809364 ) (-7.43640328 24.470081 16.7201309 3.7041359 -11.541971 -7.93291188 ) (3.51274204 24.207763 5.17815876 -4.22877598 5.38906956 -0.560255051 ) (11.385435 19.69886 10.567228 -4.78903103 -10.014303 -1.82606792 ) (16.9455108 13.9967937 0.552924156 -6.61509896 10.668148 1.86452961 ) (22.832511 8.3139591 11.221073 -4.75056935 -8.6582985 0.367947578 ) (29.724433 3.74736357 2.5627737 -4.38262177 -18.034942 2.6636815 ) (23.269737 0.696582556 -15.4721698 -1.71894026 32.798072 -5.02267456 ) (24.196609 -3.53369522 17.325908 -6.7416153 -35.157379 11.427019 ) (23.943824 -4.56180096 -17.831474 4.68540383 17.831474 -4.68540383 )) NATURAL) (2 ((178 196) (228 196)) NIL ((50. 0 0 0 0 0 )) NATURAL)) ((11 ((122 -17) (160 -21) (170 -36) (153 -54) (124 -60) (99 -58) (82 -51) (73 -36) (80 -21) (99 -16) (122 -17)) NIL ((33.954147 -1.97819113 34.128494 1.78905892 -78.110366 -17.498027 ) (29.027458 -8.9381466 -43.981872 -15.708971 17.780868 10.755794 ) (-6.06398297 -19.269218 -26.201004 -4.95317555 12.9869098 22.474849 ) (-25.77153 -12.984966 -13.214094 17.521675 20.271484 -10.655218 ) (-28.849884 -0.790901423 7.05739117 6.86645699 1.92713833 -3.85396195 ) (-20.828922 4.14857388 8.9845295 3.01249504 -3.9800415 8.0710678 ) (-13.834413 11.1966037 5.00448799 11.0835628 13.9930248 -10.430311 ) (-1.83341241 17.06501 18.997512 0.653250337 -3.99206352 -14.349813 ) (15.1680698 10.543352 15.005449 -13.6965637 -22.024765 7.82957268 ) (19.161136 0.761575103 -7.01931763 -5.86699105 44.091133 7.0315218 )) PSEUDOCYCLIC)) ((17 ((113 84) (123 90) (128 103) (131 119) (131 137) (131 155) (128 171) (123 184) (113 190) (103 184) (98 171) (95 155) (95 137) (95 119) (98 103) (103 90) (113 84)) NIL ((11.253885 0.0487168580 0.0133232101 14.7384567 -7.56328488 -8.50767137 ) (7.48556615 10.5333366 -7.54996205 6.23078538 7.73648549 -3.89238644 ) (3.8038473 14.81793 0.186523854 2.33839893 -5.3826561 0.0772185326 ) (1.29904294 17.194938 -5.19613266 2.41561746 7.7941389 -2.41648722 ) (-1.98682137E-5 18.402309 2.59800672 -8.69973097E-4 -7.7939005 -2.41126728 ) (-1.29896378 17.195808 -5.19589424 -2.41213751 5.3814659 0.0615592003 ) (-3.80412483 14.814449 0.185572236 -2.35057831 -7.73196507 -3.83496952 ) (-7.4845352 10.5463867 -7.5463934 -6.18554783 7.5463934 -8.72167588 ) (-11.25773 -3.18512320E-7 2.55536235E-7 -14.907224 7.54639149 8.72167588 ) (-7.4845352 -10.5463867 7.54639245 -6.18554879 -7.7319641 3.83497095 ) (-3.80412483 -14.814449 -0.185571968 -2.35057783 5.3814659 -0.0615596771 ) (-1.29896354 -17.195808 5.19589424 -2.41213751 -7.7939005 2.41126728 ) (-1.97092667E-5 -18.402309 -2.59800672 -8.69973213E-4 7.79413796 2.41648722 ) (1.29904318 -17.194938 5.1961317 2.41561746 -5.38265515 -0.0772185326 ) (3.8038473 -14.81793 -0.186523586 2.33839893 7.73648549 3.89238644 ) (7.48556615 -10.5333366 7.54996205 6.23078538 -7.56328488 8.50767137 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 150Q) (FACE M R R) (WIDTH 259 0) (FIDUCIAL 385 385) (VERSION 0 29-SEP-77 17:58:05) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((112 300) (112 183)) NIL ((0 -117. 0 0 0 0 )) NATURAL) (8 ((112 183) (130 196) (152 207) (176 212) (198 208) (217 196) (231 169) (235 142)) NIL ((17.098247 13.2576427 0 0 5.41051197 -1.54586053 ) (19.803501 12.484712 5.41051197 -1.54586053 -3.05255985 -4.27069664 ) (23.687732 8.80350305 2.35795212 -5.81655789 -5.2002735 -5.37134838 ) (23.445549 0.301270485 -2.84232187 -11.187906 -0.146341800 7.75609589 ) (20.530056 -7.0085888 -2.98866367 -3.43181038 -0.214358806 -19.653034 ) (17.434211 -20.266918 -3.20302248 -23.084846 -10.9962196 28.856056 ) (8.7330799 -28.923736 -14.199243 5.77121258 14.199243 -5.77121258 )) NATURAL) (2 ((235 142) (235 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((235 42) (235 26) (239 13) (247 8)) NIL ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 ) (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 ) (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 )) NATURAL) (2 ((247 8) (247 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((247 0) (135 0)) NIL ((-112. 0 0 0 0 0 )) NATURAL) (2 ((135 0) (135 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((135 8) (143 13) (147 26) (147 42)) NIL ((8.79999925 3.0666666 0 0 -4.80000019 11.599998 ) (6.3999996 8.8666668 -4.80000019 11.599998 9.53674316E-7 -9.9999981 ) (1.59999966 15.466665 -4.79999924 1.5999999 4.79999924 -1.5999999 )) NATURAL) (2 ((147 42) (147 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (6 ((147 142) (146 159) (139 170) (124 168) (115 157) (113 142)) NIL ((-0.0478469506 17.827751 0 0 -5.71291828 -4.9665079 ) (-2.90430641 15.3444957 -5.71291828 -4.9665079 -7.43540669 -11.167459 ) (-12.3349266 4.79425717 -13.1483249 -16.133968 23.454544 7.63636208 ) (-13.755979 -7.5215311 10.306219 -8.49760629 -2.38277435 4.62200833 ) (-4.6411476 -13.7081337 7.92344475 -3.87559795 -7.92344475 3.87559795 )) NATURAL) (2 ((113 142) (113 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((113 42) (113 26) (117 13) (125 8)) NIL ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 ) (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 ) (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 )) NATURAL) (2 ((125 8) (125 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((125 0) (17 0)) NIL ((-108. 0 0 0 0 0 )) NATURAL) (2 ((17 0) (17 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((17 8) (27 13) (31 26) (31 42)) NIL ((11.333332 3.0666666 0 0 -8. 11.599998 ) (7.333333 8.8666668 -8. 11.599998 4. -9.9999981 ) (1.33333325 15.466665 -4. 1.5999999 4. -1.5999999 )) NATURAL) (2 ((31 42) (31 269)) NIL ((0 227. 0 0 0 0 )) NATURAL) (4 ((31 269) (29 283) (23 291) (12 292)) NIL ((-1.26666665 15.133333 0 0 -4.39999962 -6.8000002 ) (-3.4666667 11.7333316 -4.39999962 -6.8000002 -2. -1.99999904 ) (-8.8666668 3.93333292 -6.3999996 -8.79999925 6.3999996 8.79999925 )) NATURAL) (2 ((12 292) (12 300)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((12 300) (112 300)) NIL ((100. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 151Q) (FACE M R R) (WIDTH 146 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:05:21) (MADE-FROM NIL 177 130 57 78) (SPLINES ((2 ((115 205) (13 205)) NIL ((-102. 0 0 0 0 0 )) NATURAL) (2 ((13 205) (13 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((13 197) (24 196) (30 188) (32 174)) NIL ((12.0666656 0.466666520 0 0 -6.3999996 -8.79999925 ) (8.8666649 -3.9333334 -6.3999996 -8.79999925 2. 2. ) (3.46666622 -11.7333335 -4.39999962 -6.79999924 4.39999962 6.79999924 )) NATURAL) (2 ((32 174) (32 34)) NIL ((0 -140. 0 0 0 0 )) NATURAL) (5 ((32 34) (31 25) (28 16) (22 11) (14 8)) NIL ((-0.642857075 -8.75 0 0 -2.14285707 -1.5 ) (-1.71428561 -9.5 -2.14285707 -1.5 -1.28571415 7.5 ) (-4.5 -7.24999905 -3.42857122 6. 1.28571415 -4.5 ) (-7.28571416 -3.49999952 -2.14285707 1.49999976 2.14285707 -1.49999976 )) NATURAL) (2 ((14 8) (14 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((14 0) (133 0)) NIL ((119. 0 0 0 0 0 )) NATURAL) (2 ((133 0) (133 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (5 ((133 8) (125 11) (119 16) (116 25) (115 34)) NIL ((-8.3571415 2.74999952 0 0 2.14285707 1.50000024 ) (-7.28571416 3.5 2.14285707 1.50000024 1.28571415 4.4999981 ) (-4.49999905 7.25 3.42857122 5.99999905 -1.28571415 -7.4999981 ) (-1.71428561 9.4999981 2.14285707 -1.49999976 -2.14285707 1.49999976 )) NATURAL) (2 ((115 34) (115 205)) NIL ((0 171. 0 0 0 0 )) NATURAL)) ((17 ((73 305) (91 302) (105 294) (113 282) (116 271) (113 260) (105 248) (91 240) (73 237) (55 240) (41 248) (33 260) (30 271) (33 282) (41 294) (55 302) (73 305)) NIL ((18.854923 -0.116663769 -0.497396290 -6.39998913 -3.63736725 1.89995003 ) (16.538845 -5.56667805 -4.13476372 -4.5000391 -2.82878303 -1.09981155 ) (10.9896888 -10.6166229 -6.96354676 -5.59985066 2.95249748 8.49929238 ) (5.5023918 -11.966827 -4.01104927 2.89944172 -2.98120499 -2.89735794 ) (7.40051269E-4 -10.5160637 -6.99225426 0.00208338676 2.97232246 -2.90985823 ) (-5.50535298 -11.96891 -4.0199318 -2.90777492 -2.90808678 8.53679086 ) (-10.979326 -10.6082897 -6.92801858 5.62901592 2.66002369 -1.23730755 ) (-16.577331 -5.59792614 -4.26799488 4.39170838 4.26799488 2.41243648 ) (-18.71133 3.18512320E-7 0 6.80414487 4.26799488 -2.41243648 ) (-16.577331 5.5979271 4.26799488 4.39170838 2.66002273 1.23730755 ) (-10.979326 10.6082897 6.9280176 5.62901592 -2.90808678 -8.53679086 ) (-5.50535202 11.96891 4.01993084 -2.90777492 2.97232437 2.90985775 ) (7.40210526E-4 10.5160637 6.9922552 0.00208325917 -2.98120689 2.89735842 ) (5.50239277 11.966827 4.01104832 2.89944172 2.95249843 -8.49929048 ) (10.9896888 10.6166229 6.96354676 -5.5998497 -2.82878303 1.09980964 ) (16.538845 5.56667805 4.13476372 -4.50004006 -3.63736725 -1.89994907 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 152Q) (FACE M R R) (WIDTH 162 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:08:40) (MADE-FROM NIL 146 130 57 78) (SPLINES ((2 ((146 205) (44 205)) NIL ((-102. 0 0 0 0 0 )) NATURAL) (2 ((44 205) (44 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((44 197) (55 196) (61 188) (63 174)) NIL ((12.0666656 0.466666520 0 0 -6.3999996 -8.79999925 ) (8.8666649 -3.9333334 -6.3999996 -8.79999925 2. 2. ) (3.46666622 -11.7333335 -4.39999962 -6.79999924 4.39999962 6.79999924 )) NATURAL) (2 ((63 174) (63 6)) NIL ((0 -168. 0 0 0 0 )) NATURAL) (16 ((63 6) (66 -15) (68 -40) (66 -55) (58 -54) (56 -33) (40 -18) (19 -20) (10 -35) (13 -56) (36 -71) (74 -76) (111 -68) (136 -46) (146 -18) (146 6)) NIL ((3.14361906 -19.411846 0 0 -0.861714364 -9.52890206 ) (2.71276188 -24.1763 -0.861714364 -9.52890206 -1.69142818 23.644516 ) (1.00533318 -21.882942 -2.55314255 14.1156139 -10.3725719 -1.04916954 ) (-6.73409558 -8.291914 -12.925714 13.066444 31.181716 16.552154 ) (-4.06895066 13.0506077 18.256004 29.618598 -42.354309 -41.159439 ) (-6.9900999 22.089481 -24.098304 -11.5408439 18.235511 -7.9143753 ) (-21.970645 6.5914507 -5.86279106 -19.455219 23.412258 6.81695367 ) (-16.127304 -9.45529176 17.549469 -12.638265 -9.88456727 4.64655018 ) (-3.52012062 -19.770282 7.66490174 -7.99171544 16.126018 16.596843 ) (12.207792 -19.463573 23.79092 8.60513116 -6.61951447 0.966056824 ) (32.688949 -10.3754139 17.171405 9.57118798 -19.647953 3.53892136 ) (40.036384 0.965236307 -2.47654915 13.110109 -10.78866 2.87825394 ) (32.165504 15.5144729 -13.265209 15.988363 -3.19739914 -9.05192758 ) (17.301593 26.976871 -16.462608 6.9364357 5.57826233 -14.670543 ) (3.62811518 26.578033 -10.884346 -7.7341089 10.884346 7.7341089 )) NATURAL) (2 ((146 6) (146 205)) NIL ((0 199. 0 0 0 0 )) NATURAL)) ((17 ((104 305) (122 302) (136 294) (144 282) (147 271) (144 260) (136 248) (122 240) (104 237) (86 240) (72 248) (64 260) (61 271) (64 282) (72 294) (86 302) (104 305)) NIL ((18.854923 -0.116663769 -0.497396290 -6.39998913 -3.63736725 1.89995003 ) (16.538845 -5.56667805 -4.13476372 -4.5000391 -2.82878303 -1.09981155 ) (10.9896888 -10.6166229 -6.96354676 -5.59985066 2.95249748 8.49929238 ) (5.5023918 -11.966827 -4.01104927 2.89944172 -2.98120499 -2.89735794 ) (7.40051269E-4 -10.5160637 -6.99225426 0.00208338676 2.97232246 -2.90985823 ) (-5.50535298 -11.96891 -4.0199318 -2.90777492 -2.90808678 8.53679086 ) (-10.979326 -10.6082897 -6.92801858 5.62901592 2.66002369 -1.23730755 ) (-16.577331 -5.59792614 -4.26799488 4.39170838 4.26799488 2.41243648 ) (-18.71133 3.18512320E-7 0 6.80414487 4.26799488 -2.41243648 ) (-16.577331 5.5979271 4.26799488 4.39170838 2.66002273 1.23730755 ) (-10.979326 10.6082897 6.9280176 5.62901592 -2.90808678 -8.53679086 ) (-5.50535202 11.96891 4.01993084 -2.90777492 2.97232437 2.90985775 ) (7.40210526E-4 10.5160637 6.9922552 0.00208325917 -2.98120689 2.89735842 ) (5.50239277 11.966827 4.01104832 2.89944172 2.95249843 -8.49929048 ) (10.9896888 10.6166229 6.96354676 -5.5998497 -2.82878303 1.09980964 ) (16.538845 5.56667805 4.13476372 -4.50004006 -3.63736725 -1.89994907 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 153Q) (FACE M R R) (WIDTH 259 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:19:29) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((114 300) (113 117)) NIL ((-1. -183. 0 0 0 0 )) NATURAL) (2 ((113 117) (142 155)) NIL ((29. 38. 0 0 0 0 )) NATURAL) (5 ((142 155) (150 170) (147 185) (138 193) (129 195)) NIL ((10.5178566 14.607141 0 0 -15.107141 2.35714245 ) (2.9642849 15.785713 -15.107141 2.35714245 9.5357132 -11.785711 ) (-7.375 12.249998 -5.5714283 -9.4285698 6.9642849 2.78571319 ) (-9.4642849 4.2142849 1.39285707 -6.6428566 -1.39285707 6.6428566 )) NATURAL) (3 ((129 195) (129 205) (129 205)) NIL ((0 12.5 0 0 0 -15. ) (0 5. 0 -15. 0 15. )) NATURAL) (2 ((129 205) (229 205)) NIL ((100. 0 0 0 0 0 )) NATURAL) (2 ((229 205) (229 195)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((229 195) (209 189) (192 178) (177 164) (165 150)) NIL ((-20.714283 -4.875 0 0 4.28571415 -6.75 ) (-18.571426 -8.25 4.28571415 -6.75 -3.42857122 3.75000048 ) (-15.999998 -13.125 0.857142807 -2.99999952 3.42857122 3.74999905 ) (-13.4285698 -14.249998 4.28571415 0.749999881 -4.28571415 -0.749999881 )) NATURAL) (2 ((165 150) (233 23)) NIL ((68. -127. 0 0 0 0 )) NATURAL) (3 ((233 23) (242 10) (247 8)) NIL ((10. -15.75 0 0 -6. 16.5 ) (7. -7.5 -6. 16.5 6. -16.5 )) NATURAL) (2 ((247 8) (247 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((247 0) (135 0)) NIL ((-112. 0 0 0 0 0 )) NATURAL) (2 ((135 0) (135 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((135 8) (143 11) (146 18) (141 30)) NIL ((8.79999925 2.26666641 0 0 -4.80000019 4.39999962 ) (6.3999996 4.46666622 -4.80000019 4.39999962 -5.99999905 2. ) (-1.40000009 9.8666668 -10.799999 6.3999996 10.799999 -6.3999996 )) NATURAL) (2 ((141 30) (113 90)) NIL ((-28. 60. 0 0 0 0 )) NATURAL) (2 ((113 90) (113 39)) NIL ((0 -51. 0 0 0 0 )) NATURAL) (4 ((113 39) (115 24) (120 13) (125 8)) NIL ((1.20000004 -15.666666 0 0 4.79999924 4. ) (3.5999999 -13.666666 4.79999924 4. -5.99999905 4. ) (5.3999996 -7.66666604 -1.19999981 8. 1.19999981 -8. )) NATURAL) (2 ((125 8) (125 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((125 0) (13 0)) NIL ((-112. 0 0 0 0 0 )) NATURAL) (2 ((13 0) (13 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((13 8) (23 13) (31 26) (31 42)) NIL ((10. 3.0666666 0 0 0 11.599998 ) (10. 8.8666668 0 11.599998 -12. -9.9999981 ) (4. 15.466665 -12. 1.5999999 12. -1.5999999 )) NATURAL) (2 ((31 42) (31 269)) NIL ((0 227. 0 0 0 0 )) NATURAL) (5 ((31 269) (30 276) (29 283) (23 290) (12 292)) NIL ((-1.26785707 7.0892849 0 0 1.60714268 -0.535714150 ) (-0.464285731 6.8214283 1.60714268 -0.535714150 -8.0357132 2.67857075 ) (-2.875 7.625 -6.42857075 2.1428566 0.535714150 -10.1785698 ) (-9.0357132 4.67857075 -5.8928566 -8.0357132 5.8928566 8.0357132 )) NATURAL) (2 ((12 292) (12 300)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((12 300) (114 300)) NIL ((102. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 154Q) (FACE M R R) (WIDTH 145 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:25:22) (MADE-FROM NIL 167 130 57 78) (SPLINES ((2 ((14 0) (14 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((14 8) (24 13) (32 26) (32 42)) NIL ((10. 3.0666666 0 0 0 11.599998 ) (10. 8.8666668 0 11.599998 -12. -9.9999981 ) (4. 15.466665 -12. 1.5999999 12. -1.5999999 )) NATURAL) (2 ((32 42) (32 269)) NIL ((0 227. 0 0 0 0 )) NATURAL) (5 ((32 269) (31 276) (29 283) (22 290) (9 292)) NIL ((-0.982142807 7.0892849 0 0 -0.107142925 -0.535714150 ) (-1.03571415 6.8214283 -0.107142925 -0.535714150 -5.4642849 2.67857075 ) (-3.875 7.625 -5.5714283 2.1428566 -2.03571415 -10.1785698 ) (-10.4642849 4.67857075 -7.60714245 -8.0357132 7.60714245 8.0357132 )) NATURAL) (2 ((9 292) (9 300)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((9 300) (114 300)) NIL ((105. 0 0 0 0 0 )) NATURAL) (2 ((114 300) (114 42)) NIL ((0 -258. 0 0 0 0 )) NATURAL) (4 ((114 42) (114 26) (122 13) (132 8)) NIL ((-2. -16.266666 0 0 12. 1.60000038 ) (4. -15.466665 12. 1.60000038 -12. 9.9999981 ) (10. -8.8666649 0 11.599998 0 -11.599998 )) NATURAL) (2 ((132 8) (132 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((132 0) (14 0)) NIL ((-118. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 155Q) (FACE M R R) (WIDTH 378 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:35:30) (MADE-FROM NIL 88 130 86 90) (SPLINES ((2 ((112 179) (112 205)) NIL ((0 26. 0 0 0 0 )) NATURAL) (2 ((112 205) (14 205)) NIL ((-98. 0 0 0 0 0 )) NATURAL) (3 ((14 205) (14 205) (14 197)) NIL ((0 2. 0 0 0 -12. ) (0 -4. 0 -12. 0 12. )) NATURAL) (4 ((14 197) (24 192) (30 179) (31 163)) NIL ((10.7333316 -3.0666666 0 0 -4.39999962 -11.599998 ) (8.5333328 -8.8666668 -4.39999962 -11.599998 -2. 9.9999981 ) (3.1333332 -15.466665 -6.3999996 -1.5999999 6.3999996 1.5999999 )) NATURAL) (2 ((31 163) (31 42)) NIL ((0 -121. 0 0 0 0 )) NATURAL) (4 ((31 42) (31 26) (27 13) (17 8)) NIL ((0.666666627 -16.266666 0 0 -4. 1.60000038 ) (-1.33333325 -15.466665 -4. 1.60000038 -4. 9.9999981 ) (-7.333333 -8.8666649 -8. 11.599998 8. -11.599998 )) NATURAL) (2 ((17 8) (17 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((17 0) (125 0)) NIL ((108. 0 0 0 0 0 )) NATURAL) (2 ((125 0) (125 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((125 8) (117 13) (113 26) (113 42)) NIL ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 ) (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 ) (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 )) NATURAL) (2 ((113 42) (113 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (6 ((113 142) (115 157) (124 168) (139 170) (146 159) (147 142)) NIL ((0.679425836 15.645931 0 0 7.92344475 -3.87559795 ) (4.64114857 13.7081337 7.92344475 -3.87559795 2.38277435 -4.62201023 ) (13.755979 7.52153016 10.306219 -8.49760819 -23.454544 -7.63636017 ) (12.3349266 -4.79425907 -13.1483249 -16.133968 7.43540669 11.167461 ) (2.90430593 -15.344497 -5.71291828 -4.96650696 5.71291828 4.96650696 )) NATURAL) (2 ((147 142) (147 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((147 42) (147 26) (143 13) (135 8)) NIL ((0.799999953 -16.266666 0 0 -4.80000019 1.60000038 ) (-1.5999999 -15.466665 -4.80000019 1.60000038 9.53674316E-7 9.9999981 ) (-6.3999996 -8.8666649 -4.79999924 11.599998 4.79999924 -11.599998 )) NATURAL) (2 ((135 8) (135 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((135 0) (241 0)) NIL ((106. 0 0 0 0 0 )) NATURAL) (2 ((241 0) (241 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((241 8) (233 13) (229 26) (229 42)) NIL ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 ) (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 ) (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 )) NATURAL) (2 ((229 42) (229 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (6 ((229 142) (231 157) (240 168) (255 170) (262 159) (263 142)) NIL ((0.679425836 15.645931 0 0 7.92344475 -3.87559795 ) (4.64114857 13.7081337 7.92344475 -3.87559795 2.38277435 -4.62201023 ) (13.755979 7.52153016 10.306219 -8.49760819 -23.454544 -7.63636017 ) (12.3349266 -4.79425907 -13.1483249 -16.133968 7.43540669 11.167461 ) (2.90430593 -15.344497 -5.71291828 -4.96650696 5.71291828 4.96650696 )) NATURAL) (2 ((263 142) (263 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((263 42) (263 26) (259 13) (251 8)) NIL ((0.799999953 -16.266666 0 0 -4.80000019 1.60000038 ) (-1.5999999 -15.466665 -4.80000019 1.60000038 9.53674316E-7 9.9999981 ) (-6.3999996 -8.8666649 -4.79999924 11.599998 4.79999924 -11.599998 )) NATURAL) (2 ((251 8) (251 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((251 0) (363 0)) NIL ((112. 0 0 0 0 0 )) NATURAL) (2 ((363 0) (363 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((363 8) (355 13) (351 26) (351 42)) NIL ((-8.79999925 3.0666666 0 0 4.80000019 11.599998 ) (-6.3999996 8.8666668 4.80000019 11.599998 -9.53674316E-7 -9.9999981 ) (-1.59999966 15.466665 4.79999924 1.5999999 -4.79999924 -1.5999999 )) NATURAL) (2 ((351 42) (351 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (9 ((351 142) (349 162) (343 179) (329 197) (308 208) (283 209) (261 202) (242 190) (225 175)) NIL ((-1.39175248 20.968242 0 0 -3.64948463 -5.8094616 ) (-3.21649456 18.0635109 -3.64948463 -5.8094616 -5.75257683 11.0473098 ) (-9.7422676 17.777706 -9.40206147 5.23784924 2.65979385 -14.379783 ) (-17.81443 15.82566 -6.7422676 -9.14193536 1.11340236 -1.52816772 ) (-24. 5.91964245 -5.62886524 -10.670103 10.8865966 2.49245453 ) (-24.185565 -3.50423479 5.25773144 -8.17764855 -2.6597929 3.55835629 ) (-20.257728 -9.90270616 2.59793854 -4.61929226 -0.247423649 1.27411556 ) (-17.783504 -13.884941 2.35051489 -3.3451767 -2.35051489 3.3451767 )) NATURAL) (6 ((225 175) (205 200) (179 209) (153 206) (129 194) (112 179)) NIL ((-18.397129 28.583728 0 0 -9.61722375 -21.502391 ) (-23.205741 17.832534 -9.61722375 -21.502391 12.086122 11.5119629 ) (-26.779903 2.08612347 2.46889925 -9.9904289 -2.72727251 -0.545455933 ) (-25.67464 -8.17703248 -0.258373320 -10.5358848 10.8229656 8.6698551 ) (-20.52153 -14.3779888 10.564592 -1.86602878 -10.564592 1.86602878 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.LC2-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.LC2-SF deleted file mode 100644 index 1f75fd04..00000000 --- a/obsolete/lispusers/splinefonts/TIMESROMAN.LC2-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY TIMESROMAND) (CHARACTER 156Q) (FACE M R R) (WIDTH 259 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 10:57:27) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((112 205) (112 183)) NIL ((0 -22. 0 0 0 0 )) NATURAL) (8 ((112 183) (130 196) (152 207) (176 212) (198 208) (217 196) (231 169) (235 142)) NIL ((17.098247 13.2576427 0 0 5.41051197 -1.54586053 ) (19.803501 12.484712 5.41051197 -1.54586053 -3.05255985 -4.27069664 ) (23.687732 8.80350305 2.35795212 -5.81655789 -5.2002735 -5.37134838 ) (23.445549 0.301270485 -2.84232187 -11.187906 -0.146341800 7.75609589 ) (20.530056 -7.0085888 -2.98866367 -3.43181038 -0.214358806 -19.653034 ) (17.434211 -20.266918 -3.20302248 -23.084846 -10.9962196 28.856056 ) (8.7330799 -28.923736 -14.199243 5.77121258 14.199243 -5.77121258 )) NATURAL) (2 ((235 142) (235 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((235 42) (235 26) (239 13) (247 8)) NIL ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 ) (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 ) (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 )) NATURAL) (2 ((247 8) (247 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((247 0) (135 0)) NIL ((-112. 0 0 0 0 0 )) NATURAL) (2 ((135 0) (135 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((135 8) (143 13) (147 26) (147 42)) NIL ((8.79999925 3.0666666 0 0 -4.80000019 11.599998 ) (6.3999996 8.8666668 -4.80000019 11.599998 9.53674316E-7 -9.9999981 ) (1.59999966 15.466665 -4.79999924 1.5999999 4.79999924 -1.5999999 )) NATURAL) (2 ((147 42) (147 142)) NIL ((0 100. 0 0 0 0 )) NATURAL) (6 ((147 142) (146 159) (139 170) (124 168) (115 157) (113 142)) NIL ((-0.0478469506 17.827751 0 0 -5.71291828 -4.9665079 ) (-2.90430641 15.3444957 -5.71291828 -4.9665079 -7.43540669 -11.167459 ) (-12.3349266 4.79425717 -13.1483249 -16.133968 23.454544 7.63636208 ) (-13.755979 -7.5215311 10.306219 -8.49760629 -2.38277435 4.62200833 ) (-4.6411476 -13.7081337 7.92344475 -3.87559795 -7.92344475 3.87559795 )) NATURAL) (2 ((113 142) (113 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (4 ((113 42) (113 26) (117 13) (125 8)) NIL ((-0.799999953 -16.266666 0 0 4.80000019 1.60000038 ) (1.5999999 -15.466665 4.80000019 1.60000038 -9.53674316E-7 9.9999981 ) (6.3999996 -8.8666649 4.79999924 11.599998 -4.79999924 -11.599998 )) NATURAL) (2 ((125 8) (125 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((125 0) (17 0)) NIL ((-108. 0 0 0 0 0 )) NATURAL) (2 ((17 0) (17 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((17 8) (27 13) (31 26) (31 42)) NIL ((11.333332 3.0666666 0 0 -8. 11.599998 ) (7.333333 8.8666668 -8. 11.599998 4. -9.9999981 ) (1.33333325 15.466665 -4. 1.5999999 4. -1.5999999 )) NATURAL) (2 ((31 42) (31 174)) NIL ((0 132. 0 0 0 0 )) NATURAL) (4 ((31 174) (29 188) (23 196) (12 197)) NIL ((-1.26666665 15.133333 0 0 -4.39999962 -6.8000002 ) (-3.4666667 11.7333316 -4.39999962 -6.8000002 -2. -1.99999904 ) (-8.8666668 3.93333292 -6.3999996 -8.79999925 6.3999996 8.79999925 )) NATURAL) (2 ((12 197) (12 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((12 205) (112 205)) NIL ((100. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 157Q) (FACE M R R) (WIDTH 235 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 11:02:40) (MADE-FROM NIL 109 130 57 78) (SPLINES ((21 ((118 187) (130 178) (136 158) (138 141) (139 122) (140 98) (139 74) (138 55) (136 38) (130 18) (118 9) (106 18) (100 38) (98 55) (97 74) (96 98) (97 122) (98 141) (100 158) (106 178) (118 187)) NIL ((13.420864 0.182411194 -0.271320581 -20.803161 -7.71122647 7.3150177 ) (9.29393006 -16.963241 -7.98254777 -13.4881439 4.184062 22.243881 ) (3.4034133 -19.329444 -3.79848528 8.7557373 2.97497558 -12.2905426 ) (1.09241581 -16.718975 -0.823509694 -3.5348053 1.91603374 -3.08171177 ) (1.22692299 -21.794639 1.09252405 -6.61651707 -4.63911057 6.61738969 ) (-1.08202453E-4 -25.102458 -3.54658651 8.72911885E-4 4.64040852 6.6121521 ) (-1.22649026 -21.795509 1.09382224 6.61302567 -1.92252469 -3.06600189 ) (-1.09393048 -16.715484 -0.828702450 3.54702377 -2.95030975 -12.348144 ) (-3.39778805 -19.342533 -3.7790122 -8.80112077 -4.27623368 22.45858 ) (-9.3149166 -16.9143638 -8.05524636 13.657459 8.05524636 6.5138092 ) (-13.3425407 3.20374965E-7 0 20.171268 8.05524636 -6.5138073 ) (-9.3149166 16.9143638 8.05524636 13.657461 -4.27623368 -22.45858 ) (-3.39778757 19.342533 3.77901268 -8.80112077 -2.95031023 12.3481426 ) (-1.09393024 16.715484 0.828702331 3.5470233 -1.92252445 3.06600237 ) (-1.22649026 21.795509 -1.09382224 6.61302567 4.64040852 -6.6121521 ) (-1.08162406E-4 25.102458 3.54658651 8.72911885E-4 -4.63911057 -6.61738969 ) (1.22692299 21.794639 -1.09252405 -6.61651707 1.91603374 3.08171272 ) (1.09241581 16.7189789 0.823509694 -3.53480434 2.97497558 12.2905388 ) (3.4034133 19.329444 3.79848528 8.7557354 4.18406296 -22.243877 ) (9.29393006 16.963237 7.9825487 -13.488142 -7.71122838 -7.3150158 )) PSEUDOCYCLIC)) ((25 ((118 205) (148 202) (173 194) (195 179) (213 155) (222 131) (225 98) (222 65) (213 41) (195 17) (173 2) (148 -6) (118 -9) (88 -6) (63 2) (41 17) (23 41) (14 65) (11 98) (14 131) (23 155) (41 179) (63 194) (88 202) (118 205)) NIL ((31.161361 -1.97820449 0 0 -6.9681711 -6.1307726 ) (27.677272 -5.04359055 -6.9681711 -6.1307726 4.8408575 0.653862953 ) (23.129531 -10.847431 -2.12731314 -5.47690964 -0.395261765 -8.48467637 ) (20.804588 -20.56668 -2.5225749 -13.961586 -9.2598076 21.284843 ) (13.652109 -23.885841 -11.7823829 7.32325936 7.434494 -22.654708 ) (5.58697129 -27.889938 -4.34788895 -15.331449 -2.47816563 15.333984 ) (-1.59256160E-7 -35.55439 -6.82605458 0.00253645284 2.47816467 15.318765 ) (-5.58697224 -27.892475 -4.3478899 15.321302 -7.43449307 -22.609054 ) (-13.652109 -23.875698 -11.7823829 -7.28775216 9.2598076 21.117458 ) (-20.804588 -20.604721 -2.52257538 13.829706 0.395262241 -7.86078168 ) (-23.129531 -10.705406 -2.12731314 5.96892452 -4.8408575 -1.67433166 ) (-27.677272 -5.5736475 -6.9681711 4.29459286 6.9681711 2.55811024 ) (-31.161361 1.59256160E-7 0 6.8527031 6.9681711 -2.55811024 ) (-27.677272 5.57364846 6.9681711 4.29459286 -4.84085846 1.67433071 ) (-23.129531 10.705406 2.12731266 5.96892357 0.395262718 7.8607826 ) (-20.804588 20.604721 2.52257538 13.829706 9.2598076 -21.117458 ) (-13.652109 23.875698 11.7823829 -7.28775216 -7.43449307 22.609054 ) (-5.58697224 27.892475 4.3478899 15.321304 2.47816467 -15.318767 ) (1.59256160E-7 35.55439 6.82605458 0.00253645284 -2.47816467 -15.333984 ) (5.58697224 27.889938 4.3478899 -15.331449 7.43449307 22.654708 ) (13.652109 23.885841 11.7823829 7.32325936 -9.2598076 -21.284847 ) (20.804588 20.56668 2.52257538 -13.9615879 -0.395262241 8.48467828 ) (23.129531 10.847431 2.12731314 -5.47690964 4.8408575 -0.653862000 ) (27.677272 5.04359055 6.9681711 -6.13077164 -6.9681711 6.13077164 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 160Q) (FACE M R R) (WIDTH 252 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 11:10:37) (MADE-FROM NIL 119 130 57 78) (SPLINES ((5 ((138 -62) (129 -60) (121 -55) (117 -45) (115 -28)) NIL ((-9.0178566 1.42857146 0 0 0.107142925 3.42857122 ) (-8.9642849 3.14285708 0.107142925 3.42857122 5.4642849 0.857142926 ) (-6.12499905 7. 5.5714283 4.28571415 -3.96428537 5.14285565 ) (-2.53571415 13.857143 1.60714292 9.4285698 -1.60714292 -9.4285698 )) NATURAL) (2 ((115 -28) (115 18)) NIL ((0 46. 0 0 0 0 )) NATURAL) (15 ((115 18) (141 2) (171 -5) (198 5) (220 25) (233 53) (239 89) (239 121) (233 152) (219 180) (202 199) (179 209) (155 208) (134 198) (115 180)) NIL ((24.77045 -17.354595 0 0 7.37729645 8.12758447 ) (28.459098 -13.2908039 7.37729645 8.12758447 -12.886484 13.3620777 ) (29.39315 1.51781845 -5.5091877 21.489662 2.16864204 -13.575897 ) (24.968284 16.219532 -3.34054565 7.913764 -7.7880821 -1.05849075 ) (17.733696 23.604049 -11.1286277 6.85527325 4.9836874 5.8098688 ) (9.0969143 33.364257 -6.14494038 12.665142 -0.146670341 -22.180988 ) (2.87863922 34.938903 -6.2916107 -9.51584817 1.60299492 10.9141025 ) (-2.61147404 30.880107 -4.6886158 1.39825439 -6.26530839 -3.47542334 ) (-10.4327449 30.540649 -10.953924 -2.07716894 11.458244 -9.0124092 ) (-15.657547 23.957275 0.504320979 -11.0895786 -9.56767846 3.52506352 ) (-19.937065 14.6302318 -9.0633583 -7.5645151 8.8124714 -5.0878458 ) (-24.594184 4.5217924 -0.250885904 -12.6523609 4.31778717 4.8263235 ) (-22.686176 -5.7174053 4.06690216 -7.8260374 -2.0836277 -2.21745205 ) (-19.66109 -14.65217 1.98327422 -10.043489 -1.98327422 10.043489 )) NATURAL) (2 ((115 180) (115 208)) NIL ((0 28. 0 0 0 0 )) NATURAL) (2 ((115 208) (12 195)) NIL ((-103. -13. 0 0 0 0 )) NATURAL) (2 ((12 195) (12 187)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (5 ((12 187) (22 182) (28 176) (32 166) (33 152)) NIL ((10.982141 -4.9464283 0 0 -5.8928566 -0.321428776 ) (8.0357132 -5.10714245 -5.8928566 -0.321428776 5.4642849 -4.39285565 ) (4.87499905 -7.625 -0.428571522 -4.7142849 -3.9642849 -0.107143402 ) (2.46428537 -12.392856 -4.3928566 -4.8214283 4.3928566 4.8214283 )) NATURAL) (3 ((33 152) (33 152) (33 -28)) NIL ((0 45. 0 0 0 -270. ) (0 -90. 0 -270. 0 270. )) NATURAL) (5 ((33 -28) (32 -42) (29 -54) (22 -60) (13 -62)) NIL ((-0.714285612 -14.1785698 0 0 -1.71428585 1.07142877 ) (-1.57142853 -13.642856 -1.71428585 1.07142877 -3.42857075 6.64285565 ) (-5. -9.2499981 -5.1428566 7.7142849 3.42857075 -3.6428566 ) (-8.4285698 -3.35714245 -1.71428561 4.0714283 1.71428561 -4.0714283 )) NATURAL) (2 ((13 -62) (13 -70)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((13 -70) (138 -70)) NIL ((125. 0 0 0 0 0 )) NATURAL) (2 ((138 -70) (138 -62)) NIL ((0 8. 0 0 0 0 )) NATURAL)) ((3 ((115 58) (115 58) (115 138)) NIL ((0 -20. 0 0 0 120. ) (0 40. 0 120. 0 -120. )) NATURAL) (12 ((115 138) (117 155) (124 168) (137 169) (148 150) (152 121) (153 86) (150 60) (144 38) (129 29) (117 43) (115 58)) NIL ((1.09614515 17.554847 0 0 5.42312908 -3.32910729 ) (3.80770969 15.8902969 5.42312908 -3.32910729 2.88435459 -7.35446358 ) (10.6730156 8.8839569 8.30748368 -10.6835708 -10.960546 -15.253032 ) (13.500225 -9.4261303 -2.65306425 -25.936603 -7.04216004 20.366596 ) (7.3260803 -25.179435 -9.69522477 -5.5700054 9.12919045 -6.21336556 ) (2.19545078 -33.856124 -0.566033244 -11.7833709 -5.4746065 28.486862 ) (-1.10788536 -31.39606 -6.04063988 16.703491 6.7692318 -17.7340889 ) (-3.76390886 -23.559616 0.728592634 -1.03060031 -15.602321 12.4495067 ) (-10.836477 -18.365459 -14.873729 11.418907 19.640056 21.93605 ) (-15.890178 4.02147007 4.76632786 33.354957 9.04208947 -40.193695 ) (-6.6028061 17.279579 13.808418 -6.8387394 -13.808418 6.8387394 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 161Q) (FACE M R R) (WIDTH 253 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 11:20:18) (MADE-FROM NIL 73 130 57 78) (SPLINES ((5 ((244 -62) (235 -60) (227 -55) (223 -45) (221 -28)) NIL ((-9.0178566 1.42857146 0 0 0.107142925 3.42857122 ) (-8.9642849 3.14285708 0.107142925 3.42857122 5.4642849 0.857142926 ) (-6.12499905 7. 5.5714283 4.28571415 -3.96428537 5.14285565 ) (-2.53571415 13.857143 1.60714292 9.4285698 -1.60714292 -9.4285698 )) NATURAL) (2 ((221 -28) (221 213)) NIL ((0 241. 0 0 0 0 )) NATURAL) (2 ((221 213) (214 213)) NIL ((-7. 0 0 0 0 0 )) NATURAL) (2 ((214 213) (184 184)) NIL ((-30. -29. 0 0 0 0 )) NATURAL) (16 ((184 184) (167 199) (140 211) (104 214) (65 204) (43 189) (27 168) (16 142) (11 101) (14 71) (24 40) (41 17) (61 4) (86 -1) (114 8) (139 30)) NIL ((-14.8281898 15.390228 0 0 -13.030853 -2.34137916 ) (-21.343616 14.219539 -13.030853 -2.34137916 5.15427208 -6.29310418 ) (-31.797332 8.73160745 -7.8765812 -8.63448335 -1.58623886 -8.48620225 ) (-40.467033 -4.14597798 -9.46282006 -17.120685 37.19068 16.237926 ) (-31.33451 -13.147699 27.727863 -0.882758380 -27.176502 -8.46551896 ) (-17.1949 -18.2632179 0.551357627 -9.34827806 5.5153446 11.624151 ) (-13.8858719 -21.799419 6.06670285 2.27587318 -0.884872437 -32.031082 ) (-8.2616043 -35.539085 5.1818304 -29.75521 4.02414227 56.500183 ) (-1.06770372 -37.044204 9.20597268 26.744976 -3.21169567 -37.969665 ) (6.5324211 -29.284065 5.994277 -11.224693 2.82264042 23.378486 ) (13.9380188 -28.819515 8.8169174 12.153795 -8.07886506 -1.54428863 ) (18.715499 -17.437862 0.738050580 10.6095066 5.4928274 -5.20133877 ) (22.199966 -9.42902566 6.23087884 5.40816784 -1.89244747 10.349649 ) (27.484622 1.15396976 4.33843136 15.757818 -9.92303849 -0.197273254 ) (26.861534 16.813148 -5.58460713 15.5605449 5.58460713 -15.5605449 )) NATURAL) (2 ((139 30) (139 -28)) NIL ((0 -58. 0 0 0 0 )) NATURAL) (5 ((139 -28) (138 -42) (135 -54) (128 -60) (119 -62)) NIL ((-0.714285612 -14.1785698 0 0 -1.71428585 1.07142877 ) (-1.57142853 -13.642856 -1.71428585 1.07142877 -3.42857075 6.64285565 ) (-5. -9.2499981 -5.1428566 7.7142849 3.42857075 -3.6428566 ) (-8.4285698 -3.35714245 -1.71428561 4.0714283 1.71428561 -4.0714283 )) NATURAL) (2 ((119 -62) (119 -70)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((119 -70) (244 -70)) NIL ((125. 0 0 0 0 0 )) NATURAL) (2 ((244 -70) (244 -62)) NIL ((0 8. 0 0 0 0 )) NATURAL)) ((14 ((137 120) (137 84) (133 49) (120 35) (109 38) (101 56) (97 87) (96 120) (98 156) (104 185) (118 195) (130 184) (136 154) (137 120)) NIL ((0.397950232 -35.027526 0 0 -2.38770151 -5.83479405 ) (-0.795900465 -37.94493 -2.38770151 -5.83479405 -12.061491 35.173965 ) (-9.21434785 -26.192737 -14.4491939 29.339176 20.63367 -14.861099 ) (-13.346704 -4.28410912 6.1844778 14.4780769 -4.47319508 0.270425796 ) (-9.3988247 10.3291797 1.71128201 14.7485027 3.25911093 1.77940941 ) (-6.0579872 25.967388 4.97039318 16.527912 -2.56325197 -19.388069 ) (-2.36922026 32.801261 2.40714121 -2.86015797 0.993899346 9.77287675 ) (0.534870506 34.827545 3.40104055 6.91271878 -1.41234493 -13.703434 ) (3.22973871 34.888542 1.98869562 -6.7907152 10.655479 -14.9591388 ) (10.546175 20.618259 12.644176 -21.749855 -17.209579 1.5399971 ) (14.5855598 -0.361596405 -4.56540394 -20.209857 -1.81715488 -3.20084763 ) (9.111578 -22.171875 -6.38255883 -23.410705 0.478199005 23.263381 ) (2.96811962 -33.950889 -5.9043598 -0.147323548 5.9043598 0.147323548 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 162Q) (FACE M R R) (WIDTH 200 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 11:25:39) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((112 205) (112 176)) NIL ((0 -29. 0 0 0 0 )) NATURAL) (10 ((112 176) (136 200) (161 210) (183 200) (188 180) (174 159) (147 157) (132 168) (117 158) (113 142)) NIL ((23.768428 26.483066 0 0 1.38941908 -14.8984089 ) (24.463138 19.033863 1.38941908 -14.8984089 -0.947096229 -9.50795175 ) (25.379009 -0.618523598 0.442322791 -24.40636 -21.601032 16.930221 ) (15.0208149 -16.559772 -21.15871 -7.47613717 3.35123825 1.78705024 ) (-4.46227646 -23.142383 -17.807472 -5.6890869 -3.80392075 29.921569 ) (-24.17171 -13.870685 -21.611393 24.232482 47.86444 -1.47332763 ) (-21.850879 9.6251316 26.253051 22.759155 -37.653862 -60.028259 ) (-14.4247627 2.37015486 -11.400814 -37.269104 30.751018 37.58638 ) (-10.4500675 -16.105758 19.350204 0.317277312 -19.350204 -0.317277312 )) NATURAL) (2 ((113 142) (113 42)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (5 ((113 42) (114 31) (117 19) (124 12) (133 8)) NIL ((0.714285612 -10.4285698 0 0 1.71428585 -3.42857122 ) (1.57142853 -12.1428566 1.71428585 -3.42857122 3.42857075 11.1428547 ) (5. -9.9999981 5.1428566 7.7142849 -3.42857075 -5.1428566 ) (8.4285698 -4.85714245 1.71428561 2.5714283 -1.71428561 -2.5714283 )) NATURAL) (2 ((133 8) (133 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((133 0) (12 0)) NIL ((-121. 0 0 0 0 0 )) NATURAL) (2 ((12 0) (12 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((12 8) (22 10) (29 17) (31 31)) NIL ((10.466665 1.13333320 0 0 -2.80000019 5.1999998 ) (9.06666566 3.73333359 -2.80000019 5.1999998 -3.99999905 3.99999905 ) (4.2666664 10.933332 -6.79999924 9.19999887 6.79999924 -9.19999887 )) NATURAL) (2 ((31 31) (31 174)) NIL ((0 143. 0 0 0 0 )) NATURAL) (4 ((31 174) (29 188) (23 195) (12 197)) NIL ((-1.26666665 15.5333328 0 0 -4.39999962 -9.19999887 ) (-3.4666667 10.933332 -4.39999962 -9.19999887 -2. 3.99999905 ) (-8.8666668 3.7333331 -6.3999996 -5.1999998 6.3999996 5.1999998 )) NATURAL) (2 ((12 197) (12 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((12 205) (112 205)) NIL ((100. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 163Q) (FACE M R R) (WIDTH 178 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 14:38:38) (MADE-FROM NIL 130 130 0 0) (SPLINES ((3 ((135 148) (135 148) (150 148)) NIL ((-3.75 0 0 0 22.5 0 ) (7.5 0 22.5 0 -22.5 0 )) NATURAL) (2 ((150 148) (150 206)) NIL ((0 58. 0 0 0 0 )) NATURAL) (2 ((150 206) (139 206)) NIL ((-11. 0 0 0 0 0 )) NATURAL) (2 ((139 206) (133 198)) NIL ((-6. -8. 0 0 0 0 )) NATURAL) (16 ((133 198) (116 204) (91 208) (62 206) (39 196) (24 178) (15 151) (19 126) (34 101) (55 84) (76 66) (91 43) (82 22) (59 24) (45 37) (32 62)) NIL ((-15.2221908 6.23116494 0 0 -10.666851 -1.38699484 ) (-20.555614 5.53766823 -10.666851 -1.38699484 5.3342552 -5.06502533 ) (-28.555339 1.61816025 -5.33259583 -6.45202065 13.329832 -2.35289955 ) (-27.223018 -6.01031018 7.99723626 -8.8049202 1.34641075 2.47662639 ) (-18.5525779 -13.576917 9.343647 -6.3282938 -6.71547127 -7.5536108 ) (-12.5666656 -23.682014 2.62817573 -13.881904 13.51547 21.737819 ) (-3.18075228 -26.69501 16.143646 7.855916 -5.3464241 -13.397676 ) (10.289682 -25.537933 10.797222 -5.54176045 -4.12976265 19.852882 ) (19.022022 -21.153247 6.66745949 14.3111248 -8.13452149 -18.013862 ) (21.622219 -15.849058 -1.46706223 -3.70274019 0.667852164 -1.79742288 ) (20.489082 -20.450508 -0.799210072 -5.50016308 -30.53688 1.20355701 ) (4.42143154 -25.348892 -31.336093 -4.29660607 13.47969 38.983184 ) (-20.174816 -10.1539 -17.856403 34.686584 36.618103 -31.13634 ) (-19.72216 8.96451188 18.761703 3.55024195 -21.952129 13.5621948 ) (-11.936523 19.295852 -3.19042635 17.112438 3.19042635 -17.112438 )) NATURAL) (2 ((32 62) (19 62)) NIL ((-13. 0 0 0 0 0 )) NATURAL) (3 ((19 62) (19 62) (19 -1)) NIL ((0 15.75 0 0 0 -94.5 ) (0 -31.5 0 -94.5 0 94.5 )) NATURAL) (2 ((19 -1) (29 -1)) NIL ((10. 0 0 0 0 0 )) NATURAL) (2 ((29 -1) (33 7)) NIL ((4. 8. 0 0 0 0 )) NATURAL) (15 ((33 7) (50 3) (76 -3) (106 -4) (138 7) (162 34) (166 68) (153 99) (127 124) (98 147) (85 166) (93 185) (114 184) (126 172) (135 148)) NIL ((14.8183899 -3.26369524 0 0 13.089653 -4.4178276 ) (21.363216 -5.47260952 13.089653 -4.4178276 -11.4482708 10.0891399 ) (28.728733 -4.84586716 1.64138222 5.67131233 2.70343399 6.06126595 ) (31.721836 3.8560791 4.3448162 11.732578 -11.365465 7.66579056 ) (30.383918 19.42155 -7.02064896 19.398368 -17.241565 -12.72442 ) (14.742483 32.45771 -24.262214 6.67394734 8.3317375 -10.768106 ) (-5.35386276 33.747596 -15.930477 -4.09416008 1.91460991 -4.20314217 ) (-20.327034 27.551868 -14.015867 -8.29730226 8.0098133 9.5806732 ) (-30.337993 24.044906 -6.00605298 1.2833724 26.04613 -10.119556 ) (-23.32098 20.268497 20.040081 -8.83618547 1.80563736 18.897556 ) (-2.37807894 20.881092 21.845718 10.0613708 -3.26868057 -41.470665 ) (17.833297 10.2071285 18.577037 -31.409294 -36.73091 26.985103 ) (18.0448799 -7.7096119 -18.153877 -4.42418766 18.192344 -12.4697628 ) (8.987175 -18.368682 0.0384698063 -16.893951 -0.0384698063 16.893951 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 164Q) (FACE M R R) (WIDTH 173 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 14:42:46) (MADE-FROM NIL 141 130 57 78) (SPLINES ((3 ((121 205) (121 205) (155 205)) NIL ((-8.5 0 0 0 51. 0 ) (17. 0 51. 0 -51. 0 )) NATURAL) (2 ((155 205) (155 181)) NIL ((0 -24. 0 0 0 0 )) NATURAL) (3 ((155 181) (121 181) (121 181)) NIL ((-42.5 0 0 0 51. 0 ) (-17. 0 51. 0 -51. 0 )) NATURAL) (2 ((121 181) (121 51)) NIL ((0 -130. 0 0 0 0 )) NATURAL) (5 ((121 51) (122 36) (130 28) (145 30) (153 38)) NIL ((-0.250000000 -16.267856 0 0 7.5 7.60714245 ) (3.5 -12.4642849 7.5 7.60714245 4.4999981 3.96428585 ) (13.25 -2.87499952 11.999998 11.571428 -25.499996 -5.46428585 ) (12.499998 5.96428585 -13.499998 6.10714245 13.499998 -6.10714245 )) NATURAL) (2 ((153 38) (162 25)) NIL ((9. -13. 0 0 0 0 )) NATURAL) (7 ((162 25) (147 10) (123 -2) (89 -5) (63 3) (44 24) (39 51)) NIL ((-13.442306 -15.310255 0 0 -9.34615327 1.86153841 ) (-18.115383 -14.379486 -9.34615327 1.86153841 -7.2692299 8.6923065 ) (-31.096153 -8.17179299 -16.615383 10.553846 32.423072 -0.630771637 ) (-31.499996 2.06666708 15.807689 9.9230747 -14.4230728 5.8307724 ) (-22.903842 14.905126 1.38461566 15.753847 19.269226 -10.692308 ) (-11.884613 25.31282 20.653842 5.06153775 -20.653842 -5.06153775 )) NATURAL) (2 ((39 51) (39 181)) NIL ((0 130. 0 0 0 0 )) NATURAL) (2 ((39 181) (20 181)) NIL ((-19. 0 0 0 0 0 )) NATURAL) (2 ((20 181) (20 196)) NIL ((0 15. 0 0 0 0 )) NATURAL) (5 ((20 196) (49 209) (71 227) (89 246) (106 272)) NIL ((30.607139 11.607141 0 0 -9.6428566 8.3571415 ) (25.785713 15.785713 -9.6428566 8.3571415 6.2142849 -11.785711 ) (19.249996 18.25 -3.42857122 -3.42857075 2.78571415 14.785711 ) (17.214283 22.214283 -0.642857075 11.357141 0.642857075 -11.357141 )) NATURAL) (2 ((106 272) (121 272)) NIL ((15. 0 0 0 0 0 )) NATURAL) (2 ((121 272) (121 205)) NIL ((0 -67. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 165Q) (FACE M R R) (WIDTH 249 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 14:49:10) (MADE-FROM NIL 94 130 57 78) (SPLINES ((3 ((124 205) (124 205) (222 205)) NIL ((-24.5 0 0 0 147. 0 ) (49. 0 147. 0 -147. 0 )) NATURAL) (2 ((222 205) (222 35)) NIL ((0 -170. 0 0 0 0 )) NATURAL) (5 ((222 35) (222 27) (226 16) (232 11) (238 8)) NIL ((-0.928571344 -6.80357075 0 0 5.5714283 -7.17857075 ) (1.85714292 -10.3928566 5.5714283 -7.17857075 -3.85714245 17.892852 ) (5.5 -8.6249981 1.71428561 10.7142849 -2.1428566 -10.3928547 ) (6.1428566 -3.10714245 -0.428571403 0.321428537 0.428571403 -0.321428537 )) NATURAL) (2 ((238 8) (238 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((238 0) (141 0)) NIL ((-97. 0 0 0 0 0 )) NATURAL) (2 ((141 0) (141 22)) NIL ((0 22. 0 0 0 0 )) NATURAL) (8 ((141 22) (129 10) (110 -3) (84 -8) (60 -3) (46 7) (35 25) (30 47)) NIL ((-10.615938 -11.333904 0 0 -8.30436326 -3.99656487 ) (-14.7681198 -13.3321876 -8.30436326 -3.99656487 -0.478183746 13.982824 ) (-23.311576 -10.337339 -8.782547 9.98625947 10.2171039 2.06526756 ) (-26.985569 0.681553364 1.43455767 12.051527 13.609756 -10.2439 ) (-18.746131 7.61112977 15.044315 1.80762577 -16.656131 8.91033937 ) (-12.029886 13.873926 -1.61181712 10.717966 11.0147686 -7.3974571 ) (-8.1343174 20.893161 9.4029522 3.32050848 -9.4029522 -3.32050848 )) NATURAL) (2 ((30 47) (30 167)) NIL ((0 120. 0 0 0 0 )) NATURAL) (5 ((30 167) (28 180) (25 189) (20 194) (13 197)) NIL ((-1.83928561 13.821428 0 0 -0.964285732 -4.92857075 ) (-2.3214283 11.357141 -0.964285732 -4.92857075 -1.17857122 0.642856598 ) (-3.875 6.74999905 -2.14285707 -4.28571415 -0.321428299 2.35714245 ) (-6.17857075 3.64285708 -2.46428537 -1.92857146 2.46428537 1.92857146 )) NATURAL) (2 ((13 197) (13 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((13 205) (109 205)) NIL ((96. 0 0 0 0 0 )) NATURAL) (2 ((109 205) (109 47)) NIL ((0 -158. 0 0 0 0 )) NATURAL) (7 ((109 47) (110 38) (116 30) (126 29) (135 37) (140 51) (141 67)) NIL ((-0.0487179756 -8.91025544 0 0 6.29230786 -0.538461209 ) (3.09743595 -9.1794853 6.29230786 -0.538461209 -1.46153927 8.6923046 ) (8.6589737 -5.37179375 4.83076859 8.15384484 -6.44615269 1.76923179 ) (10.266666 3.6666665 -1.61538458 9.9230766 -2.75384569 -3.76923084 ) (7.27435876 11.7051277 -4.36923027 6.15384579 -0.538461685 -4.69230747 ) (2.63589716 15.512819 -4.90769196 1.46153831 4.90769196 -1.46153831 )) NATURAL) (2 ((141 67) (141 167)) NIL ((0 100. 0 0 0 0 )) NATURAL) (5 ((141 167) (139 180) (136 189) (131 194) (124 197)) NIL ((-1.83928561 13.821428 0 0 -0.964285732 -4.92857075 ) (-2.3214283 11.357141 -0.964285732 -4.92857075 -1.17857122 0.642856598 ) (-3.875 6.74999905 -2.14285707 -4.28571415 -0.321428299 2.35714245 ) (-6.17857075 3.64285708 -2.46428537 -1.92857146 2.46428537 1.92857146 )) NATURAL) (2 ((124 197) (124 205)) NIL ((0 8. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 166Q) (FACE M R R) (WIDTH 215 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 14:54:35) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((138 205) (138 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((138 197) (147 192) (154 182) (157 168)) NIL ((9.2666664 -3.9333334 0 0 -1.60000014 -6.3999996 ) (8.46666528 -7.1333332 -1.60000014 -6.3999996 -3.99999905 2. ) (4.86666584 -12.5333328 -5.59999943 -4.39999962 5.59999943 4.39999962 )) NATURAL) (3 ((157 168) (154 154) (139 96)) NIL ((0 -3. 0 0 -18. -66. ) (-9. -36. -18. -66. 18. 66. )) NATURAL) (5 ((139 96) (118 163) (112 182) (115 192) (121 197)) NIL ((-24.428569 79.303558 0 0 20.571426 -73.821426 ) (-14.1428547 42.392852 20.571426 -73.821426 -12.857141 81.10713 ) (3.18512320E-7 9.125 7.7142849 7.2857132 -5.1428566 -16.607139 ) (5.1428566 8.1071415 2.5714283 -9.3214264 -2.5714283 9.3214264 )) NATURAL) (2 ((121 197) (121 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((121 205) (11 205)) NIL ((-110. 0 0 0 0 0 )) NATURAL) (3 ((11 205) (11 205) (11 197)) NIL ((0 2. 0 0 0 -12. ) (0 -4. 0 -12. 0 12. )) NATURAL) (4 ((11 197) (19 192) (26 182) (32 167)) NIL ((8.19999887 -4. 0 0 -1.20000004 -6. ) (7.59999943 -7. -1.20000004 -6. 2.38418579E-7 0 ) (6.3999996 -13. -1.19999981 -6. 1.19999981 6. )) NATURAL) (3 ((32 167) (32 167) (93 0)) NIL ((-15.25 41.75 0 0 91.5 -250.5 ) (30.5 -83.5 91.5 -250.5 -91.5 250.5 )) NATURAL) (2 ((93 0) (138 0)) NIL ((45. 0 0 0 0 0 )) NATURAL) (2 ((138 0) (181 155)) NIL ((43. 155. 0 0 0 0 )) NATURAL) (4 ((181 155) (187 176) (195 189) (202 197)) NIL ((5.3999996 22.799999 0 0 3.5999999 -10.799999 ) (7.1999998 17.399997 3.5999999 -10.799999 -5.99999905 6. ) (7.79999924 9.59999848 -2.39999962 -4.79999924 2.39999962 4.79999924 )) NATURAL) (2 ((202 197) (202 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((202 205) (138 205)) NIL ((-64. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 167Q) (FACE M R R) (WIDTH 335 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:00:50) (MADE-FROM NIL 88 130 57 78) (SPLINES ((2 ((93 0) (137 0)) NIL ((44. 0 0 0 0 0 )) NATURAL) (2 ((137 0) (170 113)) NIL ((33. 113. 0 0 0 0 )) NATURAL) (2 ((170 113) (213 2)) NIL ((43. -111. 0 0 0 0 )) NATURAL) (2 ((213 2) (255 2)) NIL ((42. 0 0 0 0 0 )) NATURAL) (6 ((255 2) (296 153) (299 167) (304 181) (310 190) (321 197)) NIL ((51.330139 187.7942 0 0 -61.980857 -220.7655 ) (20.33971 77.411468 -61.980857 -220.7655 81.904296 281.8276 ) (-0.688994527 -2.44018984 19.923442 61.062194 -25.63636 -84.54544 ) (6.4162674 16.349277 -5.71291828 -23.483249 14.641145 26.35406 ) (8.02392388 6.0430622 8.92822839 2.87081289 -8.92822839 -2.87081289 )) NATURAL) (2 ((321 197) (321 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((321 205) (249 205)) NIL ((-72. 0 0 0 0 0 )) NATURAL) (2 ((249 205) (249 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (5 ((249 197) (258 195) (266 187) (268 174) (267 166)) NIL ((8.8928566 -0.839285613 0 0 0.642857075 -6.96428586 ) (9.2142849 -4.3214283 0.642857075 -6.96428586 -9.2142849 -1.17857074 ) (5.24999905 -11.875 -8.5714283 -8.1428566 6.21428586 17.678569 ) (-0.214285850 -11.1785698 -2.35714245 9.5357132 2.35714245 -9.5357132 )) NATURAL) (2 ((267 166) (252 109)) NIL ((-15. -57. 0 0 0 0 )) NATURAL) (2 ((252 109) (230 176)) NIL ((-22. 67. 0 0 0 0 )) NATURAL) (4 ((230 176) (228 186) (231 196) (238 197)) NIL ((-3.0666666 9.3999996 0 0 6.3999996 3.5999999 ) (0.133333504 11.1999988 6.3999996 3.5999999 -2. -17.999996 ) (5.53333283 5.79999924 4.39999962 -14.399999 -4.39999962 14.399999 )) NATURAL) (2 ((238 197) (238 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((238 205) (132 205)) NIL ((-106. 0 0 0 0 0 )) NATURAL) (2 ((132 205) (132 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((132 197) (140 194) (144 182) (153 150)) NIL ((9.3999996 -1.93333316 0 0 -8.3999996 -6.40000058 ) (5.1999998 -5.1333332 -8.3999996 -6.40000058 17.999996 -21.999996 ) (5.80000019 -22.533332 9.59999848 -28.399997 -9.59999848 28.399997 )) NATURAL) (2 ((153 150) (139 96)) NIL ((-14. -54. 0 0 0 0 )) NATURAL) (5 ((139 96) (118 163) (112 182) (115 192) (121 197)) NIL ((-24.428569 79.303558 0 0 20.571426 -73.821426 ) (-14.1428547 42.392852 20.571426 -73.821426 -12.857141 81.10713 ) (3.18512320E-7 9.125 7.7142849 7.2857132 -5.1428566 -16.607139 ) (5.1428566 8.1071415 2.5714283 -9.3214264 -2.5714283 9.3214264 )) NATURAL) (2 ((121 197) (121 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((121 205) (11 205)) NIL ((-110. 0 0 0 0 0 )) NATURAL) (3 ((11 205) (11 205) (11 197)) NIL ((0 2. 0 0 0 -12. ) (0 -4. 0 -12. 0 12. )) NATURAL) (4 ((11 197) (19 192) (26 182) (32 167)) NIL ((8.19999887 -4. 0 0 -1.20000004 -6. ) (7.59999943 -7. -1.20000004 -6. 2.38418579E-7 0 ) (6.3999996 -13. -1.19999981 -6. 1.19999981 6. )) NATURAL) (3 ((32 167) (32 167) (93 0)) NIL ((-15.25 41.75 0 0 91.5 -250.5 ) (30.5 -83.5 91.5 -250.5 -91.5 250.5 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 170Q) (FACE M R R) (WIDTH 257 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:07:03) (MADE-FROM NIL 88 130 57 78) (SPLINES ((6 ((11 197) (23 187) (35 170) (51 147) (71 119) (90 90)) NIL ((12.2057399 -8.46411325 0 0 -1.23444962 -9.21531106 ) (11.588516 -13.0717697 -1.23444962 -9.21531106 6.17224789 4.07655525 ) (13.440191 -20.248802 4.9377985 -5.1387558 0.545454979 -1.09090805 ) (18.650714 -25.933013 5.48325348 -6.22966386 -8.35406686 6.2870798 ) (19.956935 -29.019138 -2.87081337 0.0574161485 2.87081337 -0.0574161485 )) NATURAL) (3 ((90 90) (90 90) (48 31)) NIL ((10.5 14.75 0 0 -63. -88.5 ) (-21. -29.5 -63. -88.5 63. 88.5 )) NATURAL) (4 ((48 31) (39 23) (29 14) (16 8)) NIL ((-8.93333245 -7.5333328 0 0 -0.400000095 -2.79999971 ) (-9.1333332 -8.93333245 -0.400000095 -2.79999971 -3.99999952 7.99999905 ) (-11.5333328 -7.73333264 -4.39999962 5.1999998 4.39999962 -5.1999998 )) NATURAL) (2 ((16 8) (16 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((16 0) (98 0)) NIL ((82. 0 0 0 0 0 )) NATURAL) (2 ((98 0) (98 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (5 ((98 8) (90 15) (87 25) (93 43) (106 67)) NIL ((-8.8214283 6.66071416 0 0 4.9285717 2.03571463 ) (-6.35714245 7.67857075 4.9285717 2.03571463 5.3571415 7.8214264 ) (1.25000047 13.625 10.285713 9.8571415 -2.35714245 -3.3214283 ) (10.357141 21.821426 7.92857075 6.5357132 -7.92857075 -6.5357132 )) NATURAL) (2 ((106 67) (128 37)) NIL ((22. -30. 0 0 0 0 )) NATURAL) (4 ((128 37) (136 26) (133 14) (121 8)) NIL ((10.333332 -10.333332 0 0 -14. -4. ) (3.33333302 -12.333332 -14. -4. 4. 14. ) (-8.66666604 -9.33333207 -10. 10. 10. -10. )) NATURAL) (2 ((121 8) (121 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((121 0) (244 0)) NIL ((123. 0 0 0 0 0 )) NATURAL) (2 ((244 0) (244 8)) NIL ((0 8. 0 0 0 0 )) NATURAL) (4 ((244 8) (230 23) (209 50) (159 122)) NIL ((-14.066665 14.799999 0 0 0.399999619 1.20000076 ) (-13.8666668 15.399999 0.399999619 1.20000076 -43.999992 65.999984 ) (-35.466667 49.599998 -43.599998 67.199997 43.599998 -67.199997 )) NATURAL) (5 ((159 122) (184 156) (201 178) (214 190) (229 197)) NIL ((26.821426 36.589279 0 0 -10.9285698 -15.535713 ) (21.357139 28.821426 -10.9285698 -15.535713 6.64285565 5.6785717 ) (13.75 16.124996 -4.28571415 -9.8571415 8.3571415 4.82142735 ) (13.642856 8.6785698 4.0714283 -5.03571415 -4.0714283 5.03571415 )) NATURAL) (2 ((229 197) (229 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((229 205) (145 205)) NIL ((-84. 0 0 0 0 0 )) NATURAL) (2 ((145 205) (145 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((145 197) (155 194) (163 184) (160 172)) NIL ((9.79999925 -1.26666665 0 0 1.19999981 -10.3999996 ) (10.3999996 -6.46666623 1.19999981 -10.3999996 -17.999996 9.9999981 ) (2.59999943 -11.8666649 -16.799999 -0.399999976 16.799999 0.399999976 )) NATURAL) (3 ((160 172) (144 144) (144 144)) NIL ((-20. -35. 0 0 24. 42. ) (-8. -14. 24. 42. -24. -42. )) NATURAL) (5 ((144 144) (126 170) (118 182) (119 192) (127 197)) NIL ((-20.160713 29.696426 0 0 12.9642849 -22.178569 ) (-13.6785698 18.607139 12.9642849 -22.178569 -4.8214283 26.892852 ) (-3.12499952 9.875 8.1428566 4.7142849 0.321428299 -13.3928547 ) (5.1785717 7.8928566 8.4642849 -8.6785698 -8.4642849 8.6785698 )) NATURAL) (2 ((127 197) (127 205)) NIL ((0 8. 0 0 0 0 )) NATURAL) (2 ((127 205) (11 205)) NIL ((-116. 0 0 0 0 0 )) NATURAL) (3 ((11 205) (11 205) (11 197)) NIL ((0 2. 0 0 0 -12. ) (0 -4. 0 -12. 0 12. )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 171Q) (FACE M R R) (WIDTH 242 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:27:56) (MADE-FROM NIL 106 130 52 37) (SPLINES ((2 ((10 205) (130 205)) NIL ((120. 0 0 0 0 0 )) NATURAL) (2 ((130 205) (130 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (5 ((130 197) (123 192) (120 180) (130 153) (148 97)) NIL ((-7.28571416 -3.67857122 0 0 1.71428585 -7.92857075 ) (-6.42857075 -7.6428566 1.71428585 -7.92857075 15.4285698 -2.35714435 ) (3. -16.75 17.142856 -10.285715 -9.4285698 -30.642849 ) (15.4285698 -42.357139 7.71428586 -40.928566 -7.71428586 40.928566 )) NATURAL) (2 ((148 97) (168 159)) NIL ((20. 62. 0 0 0 0 )) NATURAL) (5 ((168 159) (169 171) (166 183) (159 192) (147 197)) NIL ((1.875 11.857141 0 0 -5.25 0.857142807 ) (-0.750000001 12.285713 -5.25 0.857142807 2.25 -4.2857132 ) (-4.875 10.999998 -3. -3.42857122 -3.74999905 -1.71428537 ) (-9.75 6.7142849 -6.74999905 -5.1428566 6.74999905 5.1428566 )) NATURAL) (3 ((147 197) (147 205) (147 205)) NIL ((0 10. 0 0 0 -12. ) (0 4. 0 -12. 0 12. )) NATURAL) (2 ((147 205) (230 205)) NIL ((83. 0 0 0 0 0 )) NATURAL) (2 ((230 205) (230 197)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (6 ((230 197) (216 187) (203 163) (182 108) (155 34) (129 -33)) NIL ((-14.722486 -8.07655335 0 0 4.33492756 -11.54067 ) (-12.555023 -13.846889 4.33492756 -11.54067 -15.674638 -26.296646 ) (-16.057415 -38.53588 -11.339712 -37.837318 4.36363602 14.727272 ) (-25.215309 -69.009567 -6.97607613 -23.110046 10.2200946 39.387558 ) (-27.081337 -72.425827 3.24401903 16.277511 -3.24401903 -16.277511 )) NATURAL) (18 ((129 -33) (106 -65) (71 -78) (36 -70) (18 -52) (19 -28) (35 -12) (60 -11) (77 -29) (74 -50) (84 -54) (97 -42) (105 -12) (98 18) (71 88) (44 151) (27 185) (10 197)) NIL ((-20.030921 -35.737548 0 0 -17.814453 22.425304 ) (-28.938152 -24.524894 -17.814453 22.425304 17.072273 1.87346649 ) (-38.216468 -1.16285705 -0.742179275 24.29877 21.525348 -17.919166 ) (-28.195968 14.176328 20.783172 6.37960148 -1.17368698 3.80321789 ) (-7.99964047 22.457538 19.609485 10.182819 -4.83061028 -21.293701 ) (9.19454 21.993507 14.778875 -11.1108818 -3.5038681 -2.62841225 ) (22.221481 9.5684204 11.275007 -13.739294 -17.153915 -10.192644 ) (24.919528 -9.26719476 -5.87891007 -23.931938 -29.88045 19.39899 ) (4.1003933 -23.499637 -35.75936 -4.53294659 64.67572 28.596672 ) (0.678891659 -13.734245 28.916358 24.063728 -30.822425 -13.785705 ) (14.184036 3.43663216 -1.90606785 10.2780227 -1.38602018 20.546138 ) (11.584959 23.987724 -3.29208803 30.824161 -11.6334896 -56.398834 ) (2.47612381 26.612464 -14.925579 -25.574676 -12.0800056 97.049225 ) (-18.489456 49.5624 -27.005584 71.474548 29.953506 -91.79808 ) (-30.518287 75.137909 2.94792461 -20.323539 12.2659607 -11.8568496 ) (-21.437381 48.88594 15.213886 -32.180389 -19.017356 7.22549058 ) (-15.7321758 20.318298 -3.80347204 -24.954898 3.80347204 24.954898 )) NATURAL) (2 ((10 197) (10 205)) NIL ((0 8. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 172Q) (FACE M R R) (WIDTH 216 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:28:40) (MADE-FROM NIL 106 130 70 46) (SPLINES ((3 ((34 205) (34 205) (204 205)) NIL ((-42.5 0 0 0 255. 0 ) (85. 0 255. 0 -255. 0 )) NATURAL) (2 ((204 205) (204 195)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((204 195) (114 17)) NIL ((-90. -178. 0 0 0 0 )) NATURAL) (5 ((114 17) (138 19) (161 30) (173 45) (180 60)) NIL ((23.571426 -0.125000000 0 0 2.5714283 12.75 ) (24.857139 6.25 2.5714283 12.75 -18.857139 -9.75 ) (17.999996 14.125 -16.285713 2.99999952 12.857141 -3.74999905 ) (8.1428566 15.249998 -3.42857122 -0.749999881 3.42857122 0.749999881 )) NATURAL) (2 ((180 60) (198 60)) NIL ((18. 0 0 0 0 0 )) NATURAL) (2 ((198 60) (191 0)) NIL ((-7. -60. 0 0 0 0 )) NATURAL) (2 ((191 0) (9 0)) NIL ((-182. 0 0 0 0 0 )) NATURAL) (3 ((9 0) (107 189) (107 189)) NIL ((122.5 236.25 0 0 -147. -283.5 ) (49. 94.5 -147. -283.5 147. 283.5 )) NATURAL) (5 ((107 189) (88 188) (72 183) (59 171) (50 154)) NIL ((-19.660713 -0.339285672 0 0 3.96428537 -3.96428585 ) (-17.678569 -2.3214283 3.96428537 -3.96428585 -1.8214283 -4.17857075 ) (-14.624998 -8.375 2.14285707 -8.1428566 3.32142782 2.6785717 ) (-10.821428 -15.178571 5.4642849 -5.4642849 -5.4642849 5.4642849 )) NATURAL) (2 ((50 154) (30 154)) NIL ((-20. 0 0 0 0 0 )) NATURAL) (3 ((30 154) (34 205) (34 205)) NIL ((5. 63.75 0 0 -6. -76.5 ) (2. 25.5 -6. -76.5 6. 76.5 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.NUM-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.NUM-SF deleted file mode 100644 index c1ab00ca..00000000 --- a/obsolete/lispusers/splinefonts/TIMESROMAN.NUM-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY TIMESROMAND) (CHARACTER 61Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:40:26) (MADE-FROM NIL 118 130 43 65) (SPLINES ((2 ((49 0) (212 0)) NIL ((163. 0 0 0 0 0 )) NATURAL) (2 ((212 0) (212 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((212 10) (198 11) (185 15) (175 27) (173 52)) NIL ((-14.196428 0.535714269 0 0 1.17857146 2.78571415 ) (-13.607141 1.92857146 1.17857146 2.78571415 0.107142686 4.0714283 ) (-12.375 6.75 1.28571415 6.85714245 10.3928566 10.9285698 ) (-5.8928566 19.071426 11.6785717 17.785713 -11.6785717 -17.785713 )) NATURAL) (2 ((173 52) (173 294)) NIL ((0 242. 0 0 0 0 )) NATURAL) (2 ((173 294) (153 294)) NIL ((-20. 0 0 0 0 0 )) NATURAL) (2 ((153 294) (39 255)) NIL ((-114. -39. 0 0 0 0 )) NATURAL) (2 ((39 255) (39 245)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (6 ((39 245) (51 248) (65 250) (79 245) (84 233) (84 212)) NIL ((11.61244 2.85645914 0 0 2.32535887 0.861243725 ) (12.7751178 3.28708124 2.32535887 0.861243725 0.373205185 -10.306217 ) (15.2870807 -1.00478506 2.69856405 -9.4449749 -15.818178 4.36363602 ) (10.076553 -8.26794244 -13.119615 -5.08133888 8.89951898 -7.14832497 ) (1.40669846 -16.9234428 -4.22009564 -12.2296638 4.22009564 12.2296638 )) NATURAL) (2 ((84 212) (84 52)) NIL ((0 -160. 0 0 0 0 )) NATURAL) (5 ((84 52) (82 27) (72 15) (59 11) (49 10)) NIL ((-0.125000000 -27.964283 0 0 -11.25 17.785713 ) (-5.75 -19.071426 -11.25 17.785713 8.25 -10.9285698 ) (-12.875 -6.74999905 -2.99999952 6.85714245 8.2499981 -4.0714283 ) (-11.749998 -1.92857122 5.24999905 2.78571415 -5.24999905 -2.78571415 )) NATURAL) (2 ((49 10) (49 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 62Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:41:31) (MADE-FROM NIL 137 130 43 65) (SPLINES ((3 ((18 0) (18 0) (208 0)) NIL ((-47.5 0 0 0 285. 0 ) (95. 0 285. 0 -285. 0 )) NATURAL) (2 ((208 0) (235 85)) NIL ((27. 85. 0 0 0 0 )) NATURAL) (2 ((235 85) (223 88)) NIL ((-12. 3. 0 0 0 0 )) NATURAL) (4 ((223 88) (217 79) (207 74) (191 72)) NIL ((-5.333333 -9.8666649 0 0 -4. 5.1999998 ) (-7.333333 -7.2666664 -4. 5.1999998 -4. -2. ) (-13.333332 -3.0666666 -8. 3.1999998 8. -3.1999998 )) NATURAL) (2 ((191 72) (99 72)) NIL ((-92. 0 0 0 0 0 )) NATURAL) (13 ((99 72) (133 104) (159 131) (187 161) (207 195) (212 236) (195 269) (167 288) (134 296) (95 293) (64 278) (41 254) (26 224)) NIL ((36.390373 33.521003 0 0 -14.3422489 -9.1260376 ) (29.219245 28.957984 -14.3422489 -9.1260376 23.71125 15.630188 ) (26.732624 27.64704 9.3690014 6.5041504 -20.502761 -5.39471627 ) (25.850242 31.453834 -11.13376 1.10943412 -1.70019531 11.948675 ) (13.866386 38.537605 -12.8339557 13.058109 -14.696451 -24.399986 ) (-6.3157959 39.39572 -27.530406 -11.3418769 18.485996 -4.34872246 ) (-24.603202 25.879486 -9.0444107 -15.690599 6.75246525 5.7948761 ) (-30.27138 13.0863247 -2.29194546 -9.89572335 -9.49585725 -0.830780030 ) (-37.311256 2.77521038 -11.7878036 -10.726503 25.230964 -2.47175407 ) (-36.483573 -9.18717 13.443161 -13.198257 -7.4280052 4.71779442 ) (-26.754417 -20.026531 6.0151558 -8.48046304 4.4810543 1.60057926 ) (-18.498733 -27.706703 10.49621 -6.87988377 -10.49621 6.87988377 )) NATURAL) (2 ((26 224) (36 219)) NIL ((10. -5. 0 0 0 0 )) NATURAL) (11 ((36 219) (51 235) (73 245) (104 242) (124 216) (125 178) (114 142) (94 105) (70 68) (43 35) (18 10)) NIL ((13.8977489 17.051868 0 0 6.61349774 -6.3112297 ) (17.204498 13.896255 6.61349774 -6.3112297 8.93251039 -4.44385147 ) (28.284252 5.36310005 15.546009 -10.755081 -30.343544 -17.91336 ) (28.658485 -14.348661 -14.7975349 -28.668441 -7.5583267 16.0972938 ) (10.081787 -34.968452 -22.355861 -12.5711479 12.5768566 19.524185 ) (-5.98564625 -37.777504 -9.77900506 6.95303727 -0.749107361 -10.194042 ) (-16.139202 -35.921493 -10.528112 -3.24100542 8.4195709 3.25198889 ) (-22.45753 -37.536499 -2.10854101 0.0109835881 -2.92918157 3.18608713 ) (-26.030662 -35.932472 -5.03772259 3.19707108 9.29715158 8.0036602 ) (-26.419807 -28.733573 4.25942993 11.200731 -4.25942993 -11.200731 )) NATURAL) (2 ((18 10) (18 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 63Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:42:55) (MADE-FROM NIL 136 130 43 65) (SPLINES ((11 ((31 236) (47 258) (70 280) (99 294) (137 299) (174 293) (200 275) (212 244) (204 214) (181 192) (151 178)) NIL ((14.3884849 21.553886 0 0 9.66908837 2.67667627 ) (19.22303 22.892223 9.66908837 2.67667627 -6.34544755 -13.3833809 ) (25.719394 18.877208 3.32364082 -10.706705 9.7127056 2.85685539 ) (33.899383 9.59893037 13.036346 -7.8498497 -14.5053768 -4.04404068 ) (39.683044 -0.272939324 -1.46903157 -11.89389 -11.6911888 1.31930732 ) (32.368415 -11.507177 -13.160221 -10.574583 1.27013778 -7.2331829 ) (19.843265 -25.698352 -11.890083 -17.8077659 -11.389358 21.613414 ) (2.25850487 -32.699409 -23.279441 3.80565167 8.2872944 4.77950764 ) (-16.8772888 -26.504001 -14.992147 8.5851593 8.24018479 1.26855087 ) (-27.749343 -17.284568 -6.75196267 9.85371018 6.75196267 -9.85371018 )) NATURAL) (22 ((151 178) (181 171) (209 154) (229 119) (228 72) (208 38) (174 12) (127 -2) (78 -4) (40 4) (18 19) (18 44) (44 54) (77 43) (105 24) (136 20) (154 41) (157 76) (145 105) (126 126) (100 141) (75 149)) NIL ((30.282508 -5.32254124 0 0 -1.69506907 -10.0647506 ) (29.434974 -10.3549156 -1.69506907 -10.0647506 -3.52465439 -9.67624665 ) (25.977577 -25.257789 -5.2197237 -19.740997 -20.206306 0.769748688 ) (10.654701 -44.613914 -25.426033 -18.971248 6.34989167 42.597244 ) (-11.5963859 -42.286537 -19.076141 23.625999 6.80674554 -21.158752 ) (-27.269153 -29.239913 -12.2693958 2.4672451 -3.57687187 12.037767 ) (-41.326988 -20.753784 -15.846267 14.505012 13.50074 -2.99231338 ) (-50.42288 -7.74493027 -2.34552717 11.512699 15.573904 -0.0685119629 ) (-44.981452 3.7335124 13.228378 11.444187 2.20362282 -8.73363687 ) (-30.651268 10.8108806 15.432001 2.71054888 5.61161614 17.003063 ) (-12.4134578 22.02296 21.043617 19.713615 11.349899 -41.278625 ) (14.3051128 21.097263 32.393516 -21.56501 -27.011226 -1.88856125 ) (33.193016 -1.41202593 5.38228989 -23.453571 -17.304973 12.83287 ) (29.922817 -18.449161 -11.9226837 -10.6207008 24.231128 28.557079 ) (30.115699 -14.7913208 12.3084449 17.936378 -31.619537 10.938793 ) (26.614376 8.61445428 -19.311092 28.875171 6.2470169 -12.3122406 ) (10.42679 31.333507 -13.064075 16.562931 -5.368515 -27.689838 ) (-5.3215437 34.051513 -18.43259 -11.126909 15.227033 3.07161903 ) (-16.140617 24.460414 -3.20555592 -8.0552902 -7.53962804 3.40336895 ) (-23.115985 18.106807 -10.7451839 -4.65192127 14.931478 -4.6850977 ) (-26.395431 11.112339 4.1862955 -9.33701898 -4.1862955 9.33701898 )) NATURAL) (2 ((75 149) (75 158)) NIL ((0 9. 0 0 0 0 )) NATURAL) (9 ((75 158) (106 169) (126 188) (132 214) (125 241) (107 256) (79 257) (56 244) (41 229)) NIL ((33.150589 9.29224969 0 0 -12.9035339 10.2465019 ) (26.698818 14.4155 -12.9035339 10.2465019 -1.48232650 -3.23251152 ) (13.0541229 23.045745 -14.38586 7.0139904 0.832839966 -3.31645727 ) (-0.915316582 28.401508 -13.55302 3.69753313 4.15096092 -19.501655 ) (-12.392856 22.348213 -9.40205956 -15.8041229 -5.4366741 3.32308579 ) (-24.513252 8.20563127 -14.838733 -12.481037 23.595726 -5.79068375 ) (-27.554122 -7.17074776 8.75699426 -18.27172 1.05375671 19.839649 ) (-18.270248 -15.522642 9.81075097 1.56793022 -9.81075097 -1.56793022 )) NATURAL) (2 ((41 229) (31 236)) NIL ((-10. 7. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 64Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:43:50) (MADE-FROM NIL 106 130 43 65) (SPLINES ((3 ((117 0) (117 0) (210 0)) NIL ((-23.25 0 0 0 139.5 0 ) (46.5 0 139.5 0 -139.5 0 )) NATURAL) (2 ((210 0) (210 57)) NIL ((0 57. 0 0 0 0 )) NATURAL) (2 ((210 57) (232 57)) NIL ((22. 0 0 0 0 0 )) NATURAL) (2 ((232 57) (232 105)) NIL ((0 48. 0 0 0 0 )) NATURAL) (2 ((232 105) (210 105)) NIL ((-22. 0 0 0 0 0 )) NATURAL) (2 ((210 105) (210 294)) NIL ((0 189. 0 0 0 0 )) NATURAL) (2 ((210 294) (166 294)) NIL ((-44. 0 0 0 0 0 )) NATURAL) (2 ((166 294) (13 98)) NIL ((-153. -196. 0 0 0 0 )) NATURAL) (2 ((13 98) (13 57)) NIL ((0 -41. 0 0 0 0 )) NATURAL) (2 ((13 57) (117 57)) NIL ((104. 0 0 0 0 0 )) NATURAL) (2 ((117 57) (117 0)) NIL ((0 -57. 0 0 0 0 )) NATURAL)) ((2 ((117 105) (57 105)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((57 105) (117 182)) NIL ((60. 77. 0 0 0 0 )) NATURAL) (2 ((117 182) (117 105)) NIL ((0 -77. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 65Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:44:39) (MADE-FROM NIL 140 130 43 65) (SPLINES ((2 ((229 294) (81 294)) NIL ((-148. 0 0 0 0 0 )) NATURAL) (2 ((81 294) (27 138)) NIL ((-54. -156. 0 0 0 0 )) NATURAL) (22 ((27 138) (57 136) (92 131) (134 114) (159 75) (149 35) (115 22) (83 37) (55 51) (25 47) (15 23) (40 1) (88 -4) (144 5) (188 29) (218 63) (228 107) (214 149) (190 176) (158 193) (119 203) (78 207)) NIL ((29.342811 -1.66680526 0 0 3.9431281 -1.99916839 ) (31.314373 -2.66638946 3.9431281 -1.99916839 10.2843589 -8.004158 ) (40.39968 -8.66763688 14.227487 -10.003326 -33.080566 -19.984199 ) (38.086883 -28.663059 -18.85308 -29.987525 -21.962081 27.940948 ) (8.25275994 -44.680107 -40.815162 -2.04657411 12.9289207 34.22039 ) (-26.097942 -29.616481 -27.886241 32.17382 36.24639 3.1774292 ) (-35.860984 4.14605809 8.3601551 35.351249 -1.91453647 -40.930099 ) (-28.458099 19.032257 6.44561864 -5.57885075 -16.588245 -13.457002 ) (-30.306606 6.724905 -10.1426296 -19.035854 32.267524 -7.24187089 ) (-24.315467 -15.931886 22.1249 -26.277725 19.518119 30.424495 ) (7.5684929 -26.99736 41.64302 4.14677334 -20.340023 17.543861 ) (39.041503 -14.078657 21.302997 21.690635 -10.158018 -10.599956 ) (55.265487 2.31199884 11.144979 11.090679 -29.027896 6.85596848 ) (51.896514 16.830661 -17.882919 17.946647 6.2696266 -10.823919 ) (37.148414 29.365348 -11.6132927 7.1227274 -8.0506096 6.43971539 ) (21.509811 39.70793 -19.663902 13.5624428 -10.0671806 -14.934944 ) (-3.18767786 45.8029 -29.731082 -1.37250161 24.319316 -18.699932 ) (-20.759101 35.080429 -5.41176605 -20.072437 -3.210083 11.734699 ) (-27.775909 20.875343 -8.62184907 -8.33773805 0.521009445 1.7611351 ) (-36.137252 13.4181747 -8.1008396 -6.57660294 7.12604905 -0.779245377 ) (-40.675064 6.4519491 -0.974789858 -7.3558483 0.974789858 7.3558483 )) NATURAL) (2 ((78 207) (81 219)) NIL ((3. 12. 0 0 0 0 )) NATURAL) (2 ((81 219) (194 219)) NIL ((113. 0 0 0 0 0 )) NATURAL) (2 ((194 219) (229 294)) NIL ((35. 75. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 66Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:45:32) (MADE-FROM NIL 98 130 43 65) (SPLINES ((3 ((229 298) (229 298) (229 288)) NIL ((0 2.5 0 0 0 -15. ) (0 -5. 0 -15. 0 15. )) NATURAL) (7 ((229 288) (195 281) (165 267) (141 248) (124 227) (112 203) (106 181)) NIL ((-34.75769 -5.46282006 0 0 4.54615307 -9.22307588 ) (-32.48461 -10.074358 4.54615307 -9.22307588 1.26923179 4.1153841 ) (-27.303844 -17.239742 5.81538487 -5.10769177 2.37692165 4.76153755 ) (-20.299999 -19.966663 8.1923065 -0.346153617 -4.77692127 -5.16153813 ) (-14.4961528 -22.893589 3.41538477 -5.50769234 4.73076725 9.88461495 ) (-8.71538354 -23.458972 8.1461525 4.3769226 -8.1461525 -4.3769226 )) NATURAL) (24 ((106 181) (133 186) (161 186) (193 177) (222 151) (236 111) (234 68) (218 34) (189 9) (147 -4) (110 -3) (74 8) (44 29) (24 60) (13 100) (14 144) (24 187) (40 218) (60 243) (85 264) (120 281) (152 291) (191 297) (229 298)) NIL ((27.017456 5.9552679 0 0 -0.104736805 -5.7316103 ) (26.965084 3.08946276 -0.104736805 -5.7316103 6.52368355 -1.3419466 ) (30.122192 -3.31312084 6.4189472 -7.0735569 -7.99000168 -12.900602 ) (32.546135 -16.8369789 -1.57105517 -19.974159 -16.563671 4.94436646 ) (22.693244 -34.33895 -18.134727 -15.0297928 2.24469948 11.123121 ) (5.68086815 -43.807182 -15.890028 -3.90667152 1.58487129 16.563148 ) (-9.41672326 -39.43228 -14.3051567 12.6564789 3.41581917 -5.37572384 ) (-22.013973 -29.463665 -10.8893375 7.28075505 -9.24814797 4.9397459 ) (-37.527381 -19.713039 -20.137485 12.2205009 33.576767 3.61674309 ) (-40.87648 -5.6841688 13.439281 15.837244 -17.058918 -7.4067192 ) (-35.966659 6.44971657 -3.61963892 8.4305248 10.6589126 2.01012611 ) (-34.256843 15.885305 7.0392742 10.4406509 4.42326546 -0.633787155 ) (-25.005939 26.009063 11.4625396 9.80686379 -4.35197258 0.525022507 ) (-15.719387 36.078437 7.1105671 10.331886 6.98462487 -7.46629525 ) (-5.11650753 42.677177 14.0951919 2.86559057 -5.58652687 -0.659839154 ) (6.18542004 45.212844 8.50866509 2.20575142 -2.63851929 -19.894344 ) (13.374826 37.47142 5.8701458 -17.688594 -1.85939884 14.2372398 ) (18.315273 26.901447 4.01074696 -3.45135403 -1.92388344 -1.05462932 ) (21.364078 22.922779 2.08686352 -4.50598336 15.554931 1.98127079 ) (31.228408 19.407428 17.641796 -2.52471256 -30.295848 -6.87045193 ) (33.722274 13.4474907 -12.6540527 -9.3951645 27.628467 7.50054169 ) (34.88246 7.802598 14.9744148 -1.89462209 -20.218017 -5.1317215 ) (39.747863 3.34211445 -5.24360276 -7.0263443 5.24360276 7.0263443 )) NATURAL)) ((12 ((97 136) (105 160) (127 165) (146 144) (150 106) (151 61) (143 27) (121 14) (102 32) (96 66) (94 100) (97 136)) NIL ((4.31370259 27.50521 0 0 22.117782 -21.031272 ) (15.3725929 16.989574 22.117782 -21.031272 -26.588913 -8.84362794 ) (24.195919 -8.46351434 -4.47113037 -29.8749 -17.76213 14.40579 ) (10.843723 -31.135517 -22.233261 -15.46911 25.637439 5.22045326 ) (1.42918324 -43.9944 3.40418053 -10.248657 -12.787641 24.712398 ) (-1.56045842 -41.886856 -9.383461 14.463741 -10.486866 3.9299469 ) (-16.187351 -25.458145 -19.870327 18.393688 24.735099 19.567806 ) (-23.690128 2.71944952 4.86477566 37.961494 13.5464439 -22.201179 ) (-12.0521297 29.580352 18.41122 15.760313 -18.920879 -20.763061 ) (-3.10134888 34.959129 -0.509659410 -5.0027504 8.1370735 9.25343705 ) (0.457528412 34.583099 7.6274147 4.2506876 -7.6274147 -4.2506876 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 67Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:46:19) (MADE-FROM NIL 110 130 43 65) (SPLINES ((3 ((45 294) (45 294) (230 294)) NIL ((-46.25 0 0 0 277.5 0 ) (92.5 0 277.5 0 -277.5 0 )) NATURAL) (2 ((230 294) (119 0)) NIL ((-111. -294. 0 0 0 0 )) NATURAL) (2 ((119 0) (83 0)) NIL ((-36. 0 0 0 0 0 )) NATURAL) (2 ((83 0) (150 208)) NIL ((67. 208. 0 0 0 0 )) NATURAL) (2 ((150 208) (70 208)) NIL ((-80. 0 0 0 0 0 )) NATURAL) (4 ((70 208) (55 207) (41 202) (34 194)) NIL ((-14.799999 -0.133333355 0 0 -1.19999981 -5.1999998 ) (-15.399999 -2.73333311 -1.19999981 -5.1999998 11.999998 2. ) (-10.599998 -6.9333334 10.799999 -3.1999998 -10.799999 3.1999998 )) NATURAL) (2 ((34 194) (24 197)) NIL ((-10. 3. 0 0 0 0 )) NATURAL) (2 ((24 197) (45 294)) NIL ((21. 97. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 70Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:47:01) (MADE-FROM NIL 110 130 43 65) (SPLINES ((11 ((143 187) (124 200) (109 218) (99 241) (100 264) (114 279) (135 278) (147 262) (152 235) (150 209) (143 187)) NIL ((-19.869873 11.9956379 0 0 5.21924973 6.02616978 ) (-17.26025 15.008722 5.21924973 6.02616978 -2.09624863 -0.130851745 ) (-13.0891247 20.969467 3.1230011 5.89531803 9.16574479 -5.50276184 ) (-5.38325024 24.113403 12.2887459 0.392555833 1.43326759 -7.85809708 ) (7.62212754 20.576908 13.722013 -7.46554185 -2.89880943 -11.064842 ) (19.894733 7.5789461 10.823204 -18.530384 -25.838031 4.1174755 ) (17.798923 -8.8927021 -15.014829 -14.412908 10.250944 0.594938278 ) (7.9095659 -23.00814 -4.76388455 -13.81797 -3.16574574 17.502761 ) (1.56280875 -28.074729 -7.92963029 3.68479157 2.41203785 1.39401054 ) (-5.16080189 -23.692932 -5.51759243 5.0788021 5.51759243 -5.0788021 )) NATURAL)) ((11 ((106 126) (98 109) (94 84) (93 54) (103 24) (129 12) (148 26) (153 57) (143 89) (126 112) (106 126)) NIL ((-8.9797363 -15.152502 0 0 5.8784256 -11.0849876 ) (-6.04052354 -20.694995 5.8784256 -11.0849876 -5.39213085 7.4249382 ) (-2.85816383 -28.067512 0.486294031 -3.66004896 9.6901016 -0.614766598 ) (2.47318268 -32.034942 10.176397 -4.27481556 14.6317119 25.034126 ) (19.965435 -23.792697 24.808109 20.759311 -38.216949 8.4782562 ) (25.665069 1.20574236 -13.40884 29.237567 0.236091614 -10.9471588 ) (12.374275 24.96973 -13.172748 18.290409 -4.72740555 -18.689624 ) (-3.16217756 33.915329 -17.900154 -0.399217188 12.6735286 -10.2943229 ) (-14.7255668 28.368946 -5.22662449 -10.6935405 2.03328085 -0.133073806 ) (-18.93555 17.608871 -3.19334364 -10.826614 3.19334364 10.826614 )) NATURAL)) ((16 ((161 178) (191 188) (216 206) (225 234) (214 267) (191 285) (159 295) (117 297) (83 292) (53 279) (31 254) (23 224) (32 192) (51 168) (70 150) (92 135)) NIL ((30.5219 8.40951158 0 0 -3.13142109 9.5429306 ) (28.956192 13.1809768 -3.13142109 9.5429306 -14.342893 0.285345077 ) (18.65332 22.866577 -17.474315 9.82827569 -5.496994 1.31568908 ) (-1.56949138 33.352699 -22.971309 11.1439647 12.330877 -35.548103 ) (-18.375362 26.72261 -10.640432 -24.40414 4.17348099 20.876743 ) (-26.929054 12.756843 -6.46695138 -3.5273943 -11.0248088 -5.95888233 ) (-38.908409 6.25000668 -17.49176 -9.4862766 33.925758 2.95878696 ) (-39.437286 -1.75687647 16.433998 -6.52748967 -16.67823 0.123727798 ) (-31.34241 -8.22250176 -0.244234919 -6.40376187 8.7871742 -9.4536953 ) (-27.193054 -19.353111 8.54294015 -15.857458 5.52952576 13.691059 ) (-15.885351 -28.365039 14.0724659 -2.16639852 5.09471703 -3.31054735 ) (0.734474182 -32.186714 19.167182 -5.47694588 -7.90839387 17.551128 ) (15.94746 -28.888095 11.258789 12.074182 -15.461132 -6.89396477 ) (19.475681 -20.260894 -4.20234394 5.18021775 9.7529297 -1.97527265 ) (20.149803 -16.068313 5.55058575 3.20494509 -5.55058575 -3.20494509 )) NATURAL) (18 ((92 135) (66 126) (40 113) (22 90) (18 58) (31 30) (53 11) (81 0) (112 -4) (151 -3) (187 6) (214 24) (231 50) (236 85) (223 121) (200 147) (180 164) (161 178)) NIL ((-25.61761 -8.46248437 0 0 -2.29432678 -3.22508955 ) (-26.764774 -10.075029 -2.29432678 -3.22508955 11.4716339 -7.87455178 ) (-23.323284 -17.237396 9.1773071 -11.0996418 4.40778733 -1.27669716 ) (-11.942083 -28.975387 13.585094 -12.3763389 6.8972168 18.981342 ) (5.0916214 -31.861053 20.482311 6.60500336 -13.996664 3.35132027 ) (18.575599 -23.58039 6.48564625 9.9563236 1.08945465 -2.38662529 ) (25.605972 -14.817379 7.5751009 7.56969834 -8.36115075 0.195180893 ) (29.000499 -7.15008927 -0.786051036 7.7648792 14.355152 -4.39409924 ) (35.39202 -1.58225989 13.569101 3.37077951 -19.059459 5.3812208 ) (39.431388 4.47912979 -5.4903612 8.7520008 -4.11729336 0.869216920 ) (31.882385 13.665739 -9.60765458 9.6212177 -0.471364975 -2.85809517 ) (22.039047 21.85791 -10.0790195 6.76312256 0.00275802612 4.56316757 ) (11.9614086 30.902614 -10.0762615 11.32629 -11.539667 -9.39457894 ) (-3.88468742 37.531616 -21.615928 1.93171096 10.15591 -14.984844 ) (-20.42266 31.970905 -11.460018 -13.0531349 18.916019 3.33397102 ) (-22.424667 20.584754 7.45600415 -9.7191639 -7.82000447 7.64895535 ) (-18.8786659 14.690069 -0.364001214 -2.07020855 0.364001214 2.07020855 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 71Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:48:02) (MADE-FROM NIL 122 130 43 65) (SPLINES ((7 ((140 116) (133 90) (113 55) (89 31) (63 17) (36 8) (13 5)) NIL ((-3.77564097 -22.973075 0 0 -19.346153 -18.161537 ) (-13.448717 -32.05384 -19.346153 -18.161537 18.730766 36.807685 ) (-23.429485 -31.811534 -0.615384579 18.646152 -1.57692289 -9.06923104 ) (-24.833332 -17.6999969 -2.19230747 9.57692147 -0.423077107 -6.53076649 ) (-27.237178 -11.38846 -2.61538458 3.0461545 9.2692299 5.19230557 ) (-25.217945 -5.74615288 6.65384579 8.23846055 -6.65384579 -8.23846055 )) NATURAL) (2 ((13 5) (13 -5)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (24 ((13 -5) (42 -6) (85 0) (129 13) (167 33) (198 61) (221 96) (235 133) (238 179) (231 223) (212 258) (180 283) (148 293) (114 296) (77 291) (48 276) (29 258) (13 224) (11 183) (21 149) (43 121) (74 108) (109 106) (140 116)) NIL ((25.408454 -2.4763155 0 0 21.549259 8.8578949 ) (36.183082 1.95263242 21.549259 8.8578949 -23.746303 -2.28948021 ) (45.85919 9.66578675 -2.19704437 6.56841469 -4.56403923 0.300027847 ) (41.380126 16.384216 -6.7610836 6.86844254 0.00246334076 1.08936882 ) (34.620277 23.797344 -6.75862027 7.95781136 -1.44581127 1.34249305 ) (27.138748 32.426399 -8.20443154 9.3003044 -0.219215393 -12.459333 ) (18.82471 35.497039 -8.4236469 -3.15902996 -3.67733002 18.494842 ) (8.5623989 41.585426 -12.1009769 15.335813 2.92853546 -19.520042 ) (-2.07431078 47.161224 -9.17244149 -4.18422985 -2.03680992 -6.41466618 ) (-12.2651577 39.76966 -11.209251 -10.598896 -6.7812996 3.17871285 ) (-26.865058 30.76012 -17.990551 -7.42018319 23.162006 -12.30018 ) (-33.274604 17.189842 5.17145634 -19.720363 -7.86673165 16.022014 ) (-32.036514 5.48048878 -2.6952753 -3.69834662 -3.69507694 -3.78789759 ) (-36.579322 -0.111806541 -6.39035226 -7.4862442 16.647037 -6.87042809 ) (-34.646156 -11.033264 10.256685 -14.356672 3.10692024 19.269603 ) (-22.836017 -15.755134 13.363605 4.91293335 -17.0747108 -28.207992 ) (-18.009765 -24.946197 -3.71110535 -23.295059 23.191921 15.562372 ) (-10.12491 -40.460067 19.480815 -7.732687 -9.6929836 19.958496 ) (4.50941372 -38.213508 9.78783227 12.225809 3.5800209 -11.39636 ) (16.087253 -31.685878 13.367853 0.829447270 -4.6271019 19.626949 ) (27.141559 -21.042957 8.74075128 20.456398 -3.07161903 -13.1114368 ) (34.346496 -7.14227963 5.66913224 7.34496117 -13.086414 8.81879617 ) (33.472427 4.61208058 -7.41728306 16.163757 7.41728306 -16.163757 )) NATURAL)) ((14 ((119 277) (102 266) (96 243) (94 215) (94 186) (99 153) (110 133) (128 128) (143 144) (147 175) (146 209) (143 240) (135 267) (119 277)) NIL ((-18.843631 -1.24039459 -2.892457 -23.967063 19.73917 13.343559 ) (-11.8665027 -18.535678 16.846714 -10.6235046 -15.3411178 5.08459187 ) (-2.69034862 -26.616886 1.50559568 -5.53891278 -0.374693632 8.31806947 ) (-1.37209987 -27.996765 1.13090205 2.77915716 4.83989334 -14.35687 ) (2.17874861 -32.396041 5.97079563 -11.5777149 -0.984880448 31.109413 ) (7.6571045 -28.419052 4.98591519 19.5317 5.0996275 -8.08078385 ) (15.1928329 -12.927742 10.0855426 11.450916 -13.413631 13.2137069 ) (18.5715599 5.13002777 -3.32808876 24.664623 -11.4450988 -8.7740402 ) (9.5209198 25.407627 -14.773187 15.890583 11.1940345 -14.1175327 ) (0.344750881 34.23944 -3.5791521 1.77304864 2.66895056 -6.755826 ) (-1.89992594 32.634574 -0.910201312 -4.9827776 -3.86983919 5.14084149 ) (-4.74504757 30.22222 -4.78004074 0.158064514 -5.18959046 -19.80754 ) (-12.119884 20.476512 -9.9696312 -19.649478 6.62820054 -3.91065979 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 60Q) (FACE M R R) (WIDTH 248 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:49:21) (MADE-FROM NIL 112 130 43 65) (SPLINES ((29 ((125 302) (162 297) (194 281) (218 251) (229 228) (236 199) (240 165) (240 147) (240 129) (236 95) (229 66) (218 43) (194 13) (162 -3) (125 -8) (88 -3) (56 13) (32 43) (21 66) (14 95) (10 129) (10 147) (10 165) (14 199) (21 228) (32 251) (56 281) (88 297) (125 302)) NIL ((38.123054 -0.494537652 -0.435223341 -9.4098396 -5.4326887 1.19674492 ) (34.971489 -9.30600549 -5.86791229 -8.2130947 -0.225214004 -15.524675 ) (28.99097 -25.28144 -6.0931263 -23.73777 -11.6664486 42.901954 ) (17.064617 -27.568229 -17.7595749 19.164184 16.891006 -30.08316 ) (7.75054837 -23.445625 -0.868566871 -10.9189758 -1.89759016 -0.569307328 ) (5.93318558 -34.649253 -2.76615715 -11.488283 -3.30064392 38.360389 ) (1.51670646 -26.95734 -6.06680108 26.872112 9.1001644 -26.87228 ) (-1.25567112E-5 -13.5213699 3.03336334 -1.70698214E-4 -9.10001374 -26.871257 ) (-1.51665687 -26.957172 -6.06665135 -26.871429 3.29989529 38.35733 ) (-5.9333601 -34.649932 -2.76675606 11.4859066 1.90043187 -0.558097840 ) (-7.7499008 -23.443077 -0.866324187 10.9278087 -16.9016189 -30.12495 ) (-17.067035 -27.577743 -17.767944 -19.197143 11.706064 43.057907 ) (-28.981948 -25.245929 -6.0618801 23.860767 0.0773506165 -16.1067009 ) (-35.005149 -9.4385147 -5.9845295 7.7540655 5.9845295 3.36890125 ) (-37.99742 1.60187482E-7 0 11.1229667 5.9845295 -3.36890125 ) (-35.005149 9.4385166 5.9845295 7.7540655 0.0773506165 16.1067009 ) (-28.981948 25.245933 6.0618801 23.860767 11.706064 -43.057907 ) (-17.0670318 27.577743 17.767944 -19.197143 -16.9016189 30.12495 ) (-7.74989987 23.443077 0.866324187 10.9278087 1.90043092 0.558095932 ) (-5.9333601 34.649932 2.7667551 11.4859047 3.29989624 -38.357338 ) (-1.5166564 26.957172 6.06665135 -26.871433 -9.10001374 26.871261 ) (-1.23977661E-5 13.5213699 -3.03336334 -1.69676088E-4 9.1001644 26.87228 ) (1.51670670 26.95734 6.06680108 26.872112 -3.30064344 -38.360389 ) (5.93318558 34.649253 2.76615763 -11.488283 -1.89759087 0.569309235 ) (7.75054837 23.445625 0.868566752 -10.9189739 16.891006 30.083156 ) (17.064617 27.568233 17.7595749 19.164184 -11.6664467 -42.901954 ) (28.99097 25.281436 6.09312726 -23.73777 -0.225214958 15.524673 ) (34.971489 9.30600549 5.86791229 -8.2130966 -5.4326887 -1.19674301 )) PSEUDOCYCLIC)) ((25 ((125 10) (140 16) (149 39) (152 63) (153 89) (154 119) (155 147) (154 175) (153 205) (152 231) (149 255) (140 278) (125 284) (110 278) (101 255) (98 231) (97 205) (96 175) (95 147) (96 119) (97 89) (98 63) (101 39) (110 16) (125 10)) NIL ((16.35659 -0.115979194 -0.491682887 5.6023569 -6.66450596 19.888801 ) (12.5326557 15.43078 -7.15618897 25.491161 0.272627830 -31.058166 ) (5.51278019 25.392856 -6.88356114 -5.567008 5.57399655 8.3438816 ) (1.41621828 23.997787 -1.30956387 2.77687406 1.43138146 3.68263578 ) (0.822345257 28.615982 0.121817797 6.45950986 0.700474859 -11.0744228 ) (1.29440045 29.538276 0.822292686 -4.61491394 -4.23328018 4.61506176 ) (5.23924827E-5 27.230896 -3.41098833 1.48722116E-4 4.2326498 4.61417103 ) (-1.2946105 29.538127 0.821662307 4.6143198 -0.697323084 -11.0717468 ) (-0.821609855 28.616573 0.124339193 -6.45742798 -1.44335818 3.67282152 ) (-1.41894984 23.995555 -1.31901908 -2.78460646 -5.5292425 8.38046075 ) (-5.50259018 25.401184 -6.84826184 5.5958557 -0.439672470 -31.194671 ) (-12.570688 15.399702 -7.2879343 -25.598815 7.28793336 20.398223 ) (-16.214653 -9.53674316E-7 -2.55536235E-7 -5.20059109 7.28793526 -20.39822 ) (-12.570688 -15.3997039 7.28793526 -25.598812 -0.439674378 31.194664 ) (-5.50259018 -25.40118 6.84826089 5.59585476 -5.5292406 -8.38046075 ) (-1.41894984 -23.995559 1.31901955 -2.78460646 -1.44335866 -3.67282152 ) (-0.821609736 -28.616577 -0.124339282 -6.45742798 -0.697323084 11.0717468 ) (-1.2946105 -29.538127 -0.821662427 4.6143198 4.23265076 -4.61417008 ) (5.25317154E-5 -27.230896 3.4109888 1.48977647E-4 -4.23328114 -4.61506367 ) (1.29440045 -29.538276 -0.822292805 -4.6149149 0.700474978 11.0744247 ) (0.822345257 -28.615982 -0.121817782 6.45950986 1.43138146 -3.6826353 ) (1.41621852 -23.997787 1.30956387 2.77687454 5.57399655 -8.3438835 ) (5.51278115 -25.392856 6.88356114 -5.56700897 0.272626877 31.05817 ) (12.5326557 -15.430778 7.156188 25.491161 -6.66450406 -19.888805 )) PSEUDOCYCLIC)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.S1-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.S1-SF deleted file mode 100644 index 46103ff2..00000000 --- a/obsolete/lispusers/splinefonts/TIMESROMAN.S1-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY TIMESROMAND) (CHARACTER 41Q) (FACE M R R) (WIDTH 159 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 13:54:31) (MADE-FROM NIL 117 130 35 72) (SPLINES ((9 ((80 299) (58 296) (41 286) (34 268) (37 240) (44 209) (52 176) (61 139) (66 97)) NIL ((-22.794181 -1.52006626 0 0 4.7650957 -8.87960244 ) (-20.411632 -5.95986748 4.7650957 -8.87960244 6.17451955 2.39801216 ) (-12.559276 -13.6404628 10.939615 -6.48159028 0.536821366 -6.7124443 ) (-1.35125184 -23.478275 11.4764366 -13.194034 -8.3217964 12.451765 ) (5.9642849 -30.446426 3.15463877 -0.742267847 -3.24963093 -1.09462428 ) (7.4941082 -31.736007 -0.0949926228 -1.83689213 3.32032347 -2.07326984 ) (9.05927659 -34.609535 3.2253313 -3.91016197 -10.0316639 -2.61229706 ) (7.2687769 -39.825843 -6.80633259 -6.52245904 6.80633259 6.52245904 )) NATURAL) (2 ((66 97) (94 97)) NIL ((28. 0 0 0 0 0 )) NATURAL) (9 ((94 97) (99 139) (108 176) (116 209) (123 240) (126 268) (119 286) (102 296) (80 299)) NIL ((3.86561108 43.087074 0 0 6.80633259 -6.52245904 ) (7.2687769 39.825843 6.80633259 -6.52245904 -10.0316639 2.61229706 ) (9.05927659 34.609535 -3.2253313 -3.91016197 3.32032394 2.07326984 ) (7.4941082 31.736007 0.0949927271 -1.83689213 -3.24963188 1.09462356 ) (5.96428585 30.446426 -3.15463924 -0.742268563 -8.3217964 -12.451763 ) (-1.35125184 23.478275 -11.4764366 -13.1940326 0.536821366 6.71244145 ) (-12.559278 13.6404628 -10.939615 -6.48159123 6.1745205 -2.3980093 ) (-20.411632 5.95986653 -4.76509476 -8.8796005 4.76509476 8.8796005 )) NATURAL)) ((17 ((80 -6) (99 -3) (114 4) (122 13) (125 27) (122 41) (114 50) (99 57) (80 60) (61 57) (46 50) (38 41) (35 27) (38 13) (46 4) (61 -3) (80 -6)) NIL ((19.639171 1.98203754 0 0 -3.83505154 6.10777474 ) (17.721649 5.0359249 -3.83505154 6.10777474 -4.82474232 -6.53887368 ) (11.474226 7.87426186 -8.65979386 -0.431099415 5.1340208 8.04772187 ) (5.38144303 11.4670238 -3.52577257 7.6166229 -3.71134043 -7.65201569 ) (-8.00937414E-8 15.2576389 -7.237113 -0.0353937074 3.71133947 -7.43965436 ) (-5.38144303 11.5024166 -3.52577353 -7.47504807 -5.13401795 7.41063786 ) (-11.474226 7.73268796 -8.65979196 -0.0644102097 4.8247404 -4.20289994 ) (-17.721649 5.5668268 -3.83505154 -4.26731014 3.83505106 -2.59903431 ) (-19.639171 0 -1.27768117E-7 -6.86634446 3.835052 2.59903335 ) (-17.721649 -5.56682778 3.835052 -4.2673111 4.82473946 4.20290089 ) (-11.474226 -7.73268796 8.65979196 -0.0644097030 -5.1340189 -7.4106388 ) (-5.38144303 -11.5024166 3.52577305 -7.475049 3.71133995 7.4396553 ) (1.59256160E-7 -15.2576389 7.237113 -0.0353935584 -3.71133995 7.65201569 ) (5.38144303 -11.4670238 3.52577305 7.6166229 5.1340208 -8.04772187 ) (11.474226 -7.87426186 8.65979386 -0.431099653 -4.82474232 6.53887368 ) (17.721649 -5.0359249 3.83505154 6.10777474 -3.83505154 -6.10777474 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 43Q) (FACE M R R) (WIDTH 378 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 13:59:09) (MADE-FROM NIL 88 130 95 75) (SPLINES ((2 ((73 221) (59 187)) NIL ((-14. -34. 0 0 0 0 )) NATURAL) (2 ((59 187) (109 187)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((109 187) (77 107)) NIL ((-32. -80. 0 0 0 0 )) NATURAL) (2 ((77 107) (27 107)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((27 107) (13 73)) NIL ((-14. -34. 0 0 0 0 )) NATURAL) (2 ((13 73) (63 73)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((63 73) (34 0)) NIL ((-29. -73. 0 0 0 0 )) NATURAL) (2 ((34 0) (94 0)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((94 0) (123 73)) NIL ((29. 73. 0 0 0 0 )) NATURAL) (2 ((123 73) (193 73)) NIL ((70. 0 0 0 0 0 )) NATURAL) (2 ((193 73) (164 0)) NIL ((-29. -73. 0 0 0 0 )) NATURAL) (2 ((164 0) (224 0)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((224 0) (253 73)) NIL ((29. 73. 0 0 0 0 )) NATURAL) (2 ((253 73) (303 73)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((303 73) (317 107)) NIL ((14. 34. 0 0 0 0 )) NATURAL) (2 ((317 107) (267 107)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((267 107) (299 187)) NIL ((32. 80. 0 0 0 0 )) NATURAL) (2 ((299 187) (349 187)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((349 187) (363 221)) NIL ((14. 34. 0 0 0 0 )) NATURAL) (2 ((363 221) (313 221)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((313 221) (343 294)) NIL ((30. 73. 0 0 0 0 )) NATURAL) (2 ((343 294) (283 294)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((283 294) (253 221)) NIL ((-30. -73. 0 0 0 0 )) NATURAL) (2 ((253 221) (183 221)) NIL ((-70. 0 0 0 0 0 )) NATURAL) (2 ((183 221) (213 294)) NIL ((30. 73. 0 0 0 0 )) NATURAL) (2 ((213 294) (153 294)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((153 294) (123 221)) NIL ((-30. -73. 0 0 0 0 )) NATURAL) (2 ((123 221) (73 221)) NIL ((-50. 0 0 0 0 0 )) NATURAL)) ((2 ((137 107) (169 187)) NIL ((32. 80. 0 0 0 0 )) NATURAL) (2 ((169 187) (239 187)) NIL ((70. 0 0 0 0 0 )) NATURAL) (2 ((239 187) (207 107)) NIL ((-32. -80. 0 0 0 0 )) NATURAL) (2 ((207 107) (137 107)) NIL ((-70. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 44Q) (FACE M R R) (WIDTH 295 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:21:22) (MADE-FROM NIL 111 130 82 78) (SPLINES ((3 ((256 294) (256 294) (256 204)) NIL ((0 22.5 0 0 0 -135. ) (0 -45. 0 -135. 0 135. )) NATURAL) (2 ((256 204) (246 204)) NIL ((-10. 0 0 0 0 0 )) NATURAL) (5 ((246 204) (223 240) (201 260) (173 274) (161 276)) NIL ((-23.982139 40.071426 0 0 5.8928566 -24.428569 ) (-21.035713 27.857139 5.8928566 -24.428569 -23.464283 26.142852 ) (-26.875 16.499996 -17.571426 1.71428418 45.964279 -20.142848 ) (-21.464283 8.1428547 28.392856 -18.428566 -28.392856 18.428566 )) NATURAL) (2 ((161 276) (161 191)) NIL ((0 -85. 0 0 0 0 )) NATURAL) (10 ((161 191) (179 183) (215 165) (253 139) (277 101) (276 56) (259 26) (219 1) (178 -7) (161 -8)) NIL ((13.47525 -5.72048283 0 0 27.148498 -13.677099 ) (27.049499 -12.559032 27.148498 -13.677099 -27.742504 8.38549806 ) (40.326744 -22.04338 -0.594006300 -5.29160118 -12.1784687 -7.86489106 ) (33.6435 -31.267429 -12.772476 -13.156492 -19.543609 -0.925933839 ) (11.09922 -44.886886 -32.316085 -14.082426 24.352932 41.568618 ) (-9.04039956 -38.184997 -7.96315194 27.486198 -23.868145 -33.348571 ) (-28.937622 -27.373088 -31.831298 -5.86237526 29.119644 31.825672 ) (-46.209098 -17.322628 -2.71165275 25.963298 39.389556 -21.954124 ) (-29.225967 -2.33639145 36.677909 4.00917435 -36.677909 -4.00917435 )) NATURAL) (2 ((161 -8) (161 -28)) NIL ((0 -20. 0 0 0 0 )) NATURAL) (2 ((161 -28) (131 -28)) NIL ((-30. 0 0 0 0 0 )) NATURAL) (2 ((131 -28) (131 -7)) NIL ((0 21. 0 0 0 0 )) NATURAL) (7 ((131 -7) (114 -5) (84 1) (62 10) (48 13) (39 9) (32 0)) NIL ((-13.073076 1.22948718 0 0 -23.561534 4.62307644 ) (-24.853843 3.54102564 -23.561534 4.62307644 39.807685 0.884614945 ) (-28.511535 8.60640908 16.2461509 5.50769139 -9.6692276 -14.161535 ) (-17.099998 7.03333283 6.57692338 -8.65384484 -1.13076973 1.7615366 ) (-11.0884609 -0.739743471 5.44615364 -6.89230824 -3.80769205 1.11538601 ) (-7.54615307 -7.07435895 1.63846135 -5.77692223 -1.63846135 5.77692223 )) NATURAL) (2 ((32 0) (22 0)) NIL ((-10. 0 0 0 0 0 )) NATURAL) (2 ((22 0) (22 100)) NIL ((0 100. 0 0 0 0 )) NATURAL) (2 ((22 100) (34 100)) NIL ((12. 0 0 0 0 0 )) NATURAL) (4 ((34 100) (50 63) (73 36) (108 17)) NIL ((14.933332 -39.13333 0 0 6.40000058 12.799999 ) (18.133331 -32.733329 6.40000058 12.799999 9.9999962 -4. ) (29.533332 -21.93333 16.399997 8.79999925 -16.399997 -8.79999925 )) NATURAL) (2 ((108 17) (131 12)) NIL ((23. -5. 0 0 0 0 )) NATURAL) (2 ((131 12) (131 100)) NIL ((0 88. 0 0 0 0 )) NATURAL) (11 ((131 100) (112 110) (74 132) (42 154) (20 185) (15 220) (23 250) (41 273) (67 288) (97 296) (131 300)) NIL ((-13.5979 6.63703728 0 0 -32.41259 20.177772 ) (-29.804195 16.725921 -32.41259 20.177772 48.062957 -28.888866 ) (-38.185302 22.459262 15.650373 -8.7110939 -9.83927728 23.377697 ) (-27.45457 25.437019 5.81109619 14.666603 15.2941398 -10.621927 ) (-13.9964027 34.792656 21.105236 4.04467488 -9.33728219 -10.889978 ) (2.44019174 33.39234 11.7679538 -6.8453045 -1.94501304 0.181846618 ) (13.2356376 26.637962 9.8229408 -6.66345788 -0.882658005 -1.83740043 ) (22.617248 19.055801 8.9402828 -8.5008583 -6.52435876 1.16775417 ) (28.295352 11.1388206 2.41592407 -7.33310414 2.98009395 3.16638088 ) (32.201324 5.38890744 5.39601803 -4.16672325 -5.39601803 4.16672325 )) NATURAL) (2 ((131 300) (131 316)) NIL ((0 16. 0 0 0 0 )) NATURAL) (2 ((131 316) (161 316)) NIL ((30. 0 0 0 0 0 )) NATURAL) (2 ((161 316) (161 298)) NIL ((0 -18. 0 0 0 0 )) NATURAL) (6 ((161 298) (173 296) (201 289) (223 282) (239 284) (244 294)) NIL ((7.34449769 -0.794258357 0 0 27.933013 -7.23444939 ) (21.311004 -4.4114828 27.933013 -7.23444939 -43.665069 6.17224789 ) (27.411479 -8.5598068 -15.732055 -1.06220078 14.72727 12.545454 ) (19.04306 -3.34928227 -1.00478506 11.483253 -15.244016 -2.35406685 ) (10.416267 6.9569378 -16.248802 9.1291866 16.248802 -9.1291866 )) NATURAL) (2 ((244 294) (256 294)) NIL ((12. 0 0 0 0 0 )) NATURAL)) ((6 ((161 14) (183 19) (201 34) (204 62) (187 79) (161 92)) NIL ((22.334926 3.44497585 0 0 -2.00956964 9.33014298 ) (21.330142 8.1100483 -2.00956964 9.33014298 -13.95215 13.349281 ) (12.3444957 24.11483 -15.961721 22.679424 -8.181818 -44.727264 ) (-7.7081337 24.430618 -24.143539 -22.047843 16.679424 21.559803 ) (-23.511959 13.1626777 -7.46411515 -0.488038778 7.46411515 0.488038778 )) NATURAL) (2 ((161 92) (161 14)) NIL ((0 -78. 0 0 0 0 )) NATURAL)) ((7 ((131 278) (111 274) (96 264) (88 248) (91 227) (111 210) (131 199)) NIL ((-20.961536 -2.71410227 0 0 5.76923085 -7.71538449 ) (-18.076919 -6.5717945 5.76923085 -7.71538449 1.15384578 2.57692337 ) (-11.730768 -12.998716 6.92307664 -5.1384611 1.61538315 -2.59230804 ) (-3.99999905 -19.43333 8.53845979 -7.73076916 16.3846168 13.7923069 ) (12.730768 -20.267948 24.923076 6.06153775 -31.153842 1.42307758 ) (22.076919 -13.494871 -6.2307682 7.4846153 6.2307682 -7.4846153 )) NATURAL) (2 ((131 199) (131 278)) NIL ((0 79. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 45Q) (FACE M R R) (WIDTH 334 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:31:37) (MADE-FROM NIL 40 130 25 71) (SPLINES ((3 ((271 294) (271 294) (94 0)) NIL ((44.25 73.5 0 0 -265.5 -441. ) (-88.5 -147. -265.5 -441. 265.5 441. )) NATURAL) (2 ((94 0) (62 0)) NIL ((-32. 0 0 0 0 0 )) NATURAL) (3 ((62 0) (239 294) (239 294)) NIL ((221.25 367.5 0 0 -265.5 -441. ) (88.5 147. -265.5 -441. 265.5 441. )) NATURAL) (2 ((239 294) (271 294)) NIL ((32. 0 0 0 0 0 )) NATURAL)) ((21 ((79 127) (105 133) (124 146) (136 164) (141 184) (144 214) (141 244) (136 264) (124 282) (105 295) (79 301) (53 295) (34 282) (22 264) (17 244) (14 214) (17 184) (22 164) (34 146) (53 133) (79 127)) NIL ((27.505523 4.49280548 0 0 -9.0331478 9.0431652 ) (22.988948 9.01438714 -9.0331478 9.0431652 3.16574478 -3.21582604 ) (15.538673 16.449638 -5.86740303 5.82733917 -3.62983322 -8.17986299 ) (7.8563528 18.187046 -9.49723626 -2.35252428 11.353588 17.935279 ) (4.0359106 24.802162 1.85635328 15.582756 -11.7845268 -15.561258 ) (-5.56930899E-7 32.604286 -9.92817498 0.0214966945 11.7845268 -15.6902389 ) (-4.03591156 24.780666 1.85635328 -15.668743 -11.353588 18.322219 ) (-7.85635377 18.273033 -9.49723626 2.65347767 3.62983227 -9.59864427 ) (-15.538673 16.127189 -5.86740399 -6.94516659 -3.16574383 2.07235908 ) (-22.988948 10.2182006 -9.0331478 -4.8728075 9.0331459 -10.690786 ) (-27.505523 -1.60187482E-7 -5.11072471E-7 -15.5635948 9.0331497 10.690784 ) (-22.988948 -10.2182006 9.0331497 -4.8728094 -3.16574574 -2.07235718 ) (-15.538673 -16.127189 5.86740399 -6.94516659 3.62983227 9.59864427 ) (-7.8563528 -18.273033 9.49723626 2.65347767 -11.353588 -18.322219 ) (-4.03591156 -24.780666 -1.85635352 -15.668743 11.7845287 15.6902389 ) (-3.91155481E-8 -32.604286 9.92817689 0.0214962214 -11.7845287 15.56126 ) (4.03591156 -24.802162 -1.85635352 15.5827579 11.353588 -17.935279 ) (7.85635377 -18.187046 9.49723626 -2.35252428 -3.62983227 8.17986299 ) (15.538673 -16.449638 5.86740399 5.82733917 3.16574383 3.21582604 ) (22.988948 -9.01438714 9.0331478 9.0431652 -9.0331478 -9.0431652 )) NATURAL)) ((17 ((79 141) (93 151) (96 172) (97 190) (96 214) (97 238) (96 256) (93 277) (79 287) (65 277) (62 256) (61 238) (62 214) (61 190) (62 172) (65 151) (79 141)) NIL ((16.803104 -0.223070144 0.182082086 24.092327 -17.364887 -10.93856 ) (8.302742 18.399978 -17.1828079 13.153766 19.73196 -23.861171 ) (0.985916854 19.623157 2.54915523 -10.707405 -7.5629673 22.383258 ) (-0.246411472 20.107383 -5.01381207 11.6758537 10.519905 -11.671869 ) (-2.70843506E-4 25.947299 5.50609303 0.00398380961 -10.516653 -11.695772 ) (0.247495413 20.103397 -5.01056099 -11.6917896 7.54671 22.454963 ) (-0.989710332 19.639091 2.5361495 10.763174 -19.670185 -24.12408 ) (-8.28865434 18.340225 -17.134037 -13.360906 17.134037 -9.9586353 ) (-16.8556709 -1.90734863E-6 0 -23.319541 17.134037 9.95863725 ) (-8.2886524 -18.340225 17.134037 -13.3609047 -19.670185 24.124076 ) (-0.989710093 -19.639091 -2.5361495 10.763174 7.54670907 -22.454959 ) (0.247495472 -20.103401 5.01056004 -11.6917877 -10.516653 11.69577 ) (-2.70843506E-4 -25.947299 -5.50609303 0.00398329925 10.519903 11.671871 ) (-0.246411145 -20.107383 5.0138111 11.6758556 -7.56296635 -22.383258 ) (0.985917092 -19.623157 -2.54915523 -10.707405 19.73196 23.861171 ) (8.3027439 -18.399974 17.1828079 13.153768 -17.364887 10.9385585 )) PSEUDOCYCLIC)) ((21 ((257 167) (283 161) (302 148) (314 130) (319 110) (322 80) (319 50) (314 30) (302 12) (283 -1) (257 -7) (231 -1) (212 12) (200 30) (195 50) (192 80) (195 110) (200 130) (212 148) (231 161) (257 167)) NIL ((27.627128 -0.143936932 -0.421261072 -15.064924 -8.49900819 10.058393 ) (22.956363 -10.1796646 -8.9202709 -5.0065298 3.0226221 -1.9024229 ) (15.547403 -16.137405 -5.8976488 -6.9089527 -3.59148312 9.5512943 ) (7.85401345 -18.27071 -9.4891319 2.64234209 11.343313 -18.302753 ) (4.03653813 -24.779747 1.85418176 -15.660413 -11.781774 15.659725 ) (-1.68442726E-4 -32.610298 -9.9275932 -6.87903608E-4 11.7837886 15.663852 ) (-4.03586579 -24.779056 1.85619712 15.663166 -11.3533897 -18.315147 ) (-7.85636616 -18.273464 -9.4971943 -2.65198326 3.62977982 9.59674836 ) (-15.538669 -16.127075 -5.86741448 6.9447651 -3.16573143 -2.07184219 ) (-22.988948 -10.218229 -9.0331459 4.8729229 9.0331459 10.6906147 ) (-27.505523 1.60187482E-7 0 15.563537 9.0331459 -10.6906128 ) (-22.988948 10.218231 9.0331459 4.87292385 -3.16573143 2.07184028 ) (-15.538669 16.127075 5.86741448 6.94476414 3.62977982 -9.59674645 ) (-7.85636426 18.273464 9.4971943 -2.65198326 -11.3533916 18.315151 ) (-4.03586579 24.779056 -1.85619783 15.6631679 11.783792 -15.663854 ) (-1.68045051E-4 32.610298 9.92759515 -6.88414671E-4 -11.781776 -15.659725 ) (4.03653813 24.779747 -1.854182 -15.660413 11.343313 18.302753 ) (7.8540144 18.27071 9.4891319 2.64234161 -3.59148312 -9.5512943 ) (15.547405 16.137405 5.8976488 -6.9089527 3.0226221 1.9024229 ) (22.956363 10.1796627 8.9202709 -5.0065298 -8.4990101 -10.058395 )) PSEUDOCYCLIC)) ((17 ((257 5) (271 15) (274 36) (275 54) (274 78) (275 102) (274 120) (271 141) (257 151) (243 141) (240 120) (239 102) (240 78) (239 54) (240 36) (243 15) (257 5)) NIL ((16.803104 -0.223070144 0.182082086 24.092327 -17.364887 -10.93856 ) (8.302742 18.399978 -17.1828079 13.153766 19.73196 -23.861171 ) (0.985916854 19.623157 2.54915523 -10.707405 -7.5629673 22.383258 ) (-0.246411472 20.107383 -5.01381207 11.6758537 10.519905 -11.671869 ) (-2.70843506E-4 25.947299 5.50609303 0.00398380961 -10.516653 -11.695772 ) (0.247495413 20.103397 -5.01056099 -11.6917896 7.54671 22.454963 ) (-0.989710332 19.639091 2.5361495 10.763174 -19.670185 -24.12408 ) (-8.28865434 18.340225 -17.134037 -13.360906 17.134037 -9.9586353 ) (-16.8556709 -1.90734863E-6 0 -23.319541 17.134037 9.95863725 ) (-8.2886524 -18.340225 17.134037 -13.3609047 -19.670185 24.124076 ) (-0.989710093 -19.639091 -2.5361495 10.763174 7.54670907 -22.454959 ) (0.247495472 -20.103401 5.01056004 -11.6917877 -10.516653 11.69577 ) (-2.70843506E-4 -25.947299 -5.50609303 0.00398329925 10.519903 11.671871 ) (-0.246411145 -20.107383 5.0138111 11.6758556 -7.56296635 -22.383258 ) (0.985917092 -19.623157 -2.54915523 -10.707405 19.73196 23.861171 ) (8.3027439 -18.399974 17.1828079 13.153768 -17.364887 10.9385585 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 46Q) (FACE M R R) (WIDTH 350 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:43:50) (MADE-FROM NIL 66 130 35 72) (SPLINES ((3 ((218 174) (218 174) (326 174)) NIL ((-27. 0 0 0 162. 0 ) (54. 0 162. 0 -162. 0 )) NATURAL) (2 ((326 174) (326 164)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((326 164) (307 154) (289 132) (271 108) (252 83)) NIL ((-19.25 -6.91071416 0 0 1.5 -18.535713 ) (-18.499996 -16.1785698 1.5 -18.535713 -1.5 20.678569 ) (-17.75 -24.375 -6.35782838E-8 2.14285707 -1.49999952 -4.17857075 ) (-18.5 -24.321426 -1.49999976 -2.03571415 1.49999976 2.03571415 )) NATURAL) (5 ((252 83) (270 64) (292 46) (315 38) (332 49)) NIL ((17.107139 -18.892856 0 0 5.35714245 -0.642857075 ) (19.785713 -19.214283 5.35714245 -0.642857075 -2.78571415 9.2142849 ) (23.75 -15.249998 2.5714283 8.5714283 -12.2142849 17.785709 ) (20.214283 2.2142868 -9.6428566 26.357139 9.6428566 -26.357139 )) NATURAL) (3 ((332 49) (332 49) (342 41)) NIL ((-2.5 2. 0 0 15. -12. ) (5. -4. 15. -12. -15. 12. )) NATURAL) (6 ((342 41) (323 17) (294 -4) (262 -11) (226 -3) (193 22)) NIL ((-16.444973 -24.004783 0 0 -15.3301429 0.0287084579 ) (-24.110046 -23.990428 -15.3301429 0.0287084579 16.6507149 17.856456 ) (-31.11483 -15.033491 1.32057380 17.885166 -9.27272607 -5.45454788 ) (-34.430618 0.124403000 -7.95215226 12.430618 14.440189 9.96172715 ) (-35.162674 17.5358848 6.48803807 22.392345 -6.48803807 -22.392345 )) NATURAL) (11 ((193 22) (161 3) (124 -7) (83 -6) (45 7) (22 29) (9 59) (12 94) (32 123) (62 143) (92 157)) NIL ((-30.93714 -20.81504 0 0 -6.37713147 10.8902549 ) (-34.125709 -15.369913 -6.37713147 10.8902549 1.88565731 -0.451280594 ) (-39.560012 -4.70529843 -4.49147415 10.438974 4.83450318 2.9148693 ) (-41.63423 7.19110966 0.343029499 13.3538437 20.776321 -5.2081909 ) (-30.903041 17.9408569 21.119354 8.14565278 -15.939798 -0.0821170807 ) (-17.753585 26.045452 5.1795559 8.0635357 12.9828586 -0.463335037 ) (-6.08260155 33.877319 18.162414 7.60020066 0.00836563111 -16.064537 ) (12.0839958 33.44525 18.17078 -8.4643383 -7.0163231 -1.27850341 ) (26.746616 24.341659 11.154457 -9.7428417 -13.943071 3.17855263 ) (30.929534 16.188095 -2.78861427 -6.5642891 2.78861427 6.5642891 )) NATURAL) (13 ((92 157) (78 188) (72 220) (75 249) (94 278) (126 295) (168 300) (205 296) (235 278) (247 246) (236 215) (209 192) (176 180)) NIL ((-15.753526 30.469062 0 0 10.521162 3.18560314 ) (-10.4929447 32.061866 10.521162 3.18560314 -4.60581589 -9.92801477 ) (-2.27469063 30.283462 5.91534615 -6.74241257 13.902105 12.5264606 ) (10.591711 29.804279 19.817451 5.78404808 -9.0026245 -22.177825 ) (25.907848 24.499412 10.8148269 -16.393779 4.10840798 4.18486214 ) (38.776878 10.198061 14.9232349 -12.2089176 -25.431003 5.43837738 ) (40.98461 0.708333016 -10.5077705 -6.77054024 7.6156225 -7.93837739 ) (34.284652 -10.0313968 -2.89214802 -14.708917 -17.031482 -3.68486214 ) (22.876762 -26.582744 -19.923633 -18.393779 -5.4896736 22.677825 ) (0.208288818 -33.63761 -25.413307 4.28404808 8.9901886 2.97353935 ) (-20.709922 -27.866794 -16.423118 7.25758744 11.528898 7.42801476 ) (-31.36859 -16.8951988 -4.8942194 14.685602 4.8942194 -14.685602 )) NATURAL) (3 ((176 180) (205 138) (236 100)) NIL ((28.5 -43. 0 0 3. 6. ) (30. -40. 3. 6. -3. -6. )) NATURAL) (6 ((236 100) (241 111) (244 131) (241 148) (230 159) (218 164)) NIL ((5.25358773 8.4593296 0 0 -1.52153110 15.244018 ) (4.49282265 16.081337 -1.52153110 15.244018 -4.39234448 -22.220092 ) (0.775119424 20.215309 -5.91387558 -6.97607613 -4.90909004 1.63636398 ) (-7.5933008 14.057415 -10.8229656 -5.33971215 12.0287056 -2.32535934 ) (-12.4019127 7.5550232 1.20574140 -7.66507149 -1.20574140 7.66507149 )) NATURAL) (2 ((218 164) (218 174)) NIL ((0 10. 0 0 0 0 )) NATURAL)) ((9 ((169 197) (179 218) (182 243) (176 269) (158 284) (144 271) (144 246) (155 217) (169 197)) NIL ((11.465389 20.08155 0 0 -8.79234124 5.51067734 ) (7.06921864 22.836891 -8.79234124 5.51067734 1.96170807 -3.55338669 ) (-0.742268205 26.570873 -6.83063317 1.95729065 -11.054491 -9.29713059 ) (-13.100147 23.8796 -17.885124 -7.33983994 24.256256 -31.25809 ) (-18.857139 0.910711766 6.3711338 -38.59793 10.029451 32.32952 ) (-7.4712801 -21.522457 16.400585 -6.26840878 -4.37407494 -2.06001568 ) (6.7422676 -28.820873 12.02651 -8.32842446 -10.533136 23.91053 ) (13.5022087 -25.194034 1.4933722 15.582105 -1.4933722 -15.582105 )) NATURAL)) ((4 ((100 141) (127 100) (150 68) (177 34)) NIL ((28.333332 -43.533332 0 0 -8. 15.1999988 ) (24.333332 -35.933326 -8. 15.1999988 16. -21.999996 ) (24.333332 -31.733333 8. -6.79999924 -8. 6.79999924 )) NATURAL) (7 ((177 34) (148 34) (121 43) (100 63) (88 91) (89 119) (100 141)) NIL ((-29.224357 -1.76794863 0 0 1.34615397 10.6076927 ) (-28.55128 3.53589726 1.34615397 10.6076927 5.26922989 0.961536408 ) (-24.57051 14.624359 6.6153841 11.569229 1.57692241 -2.45384407 ) (-17.166664 24.966663 8.1923065 9.11538507 6.42307854 -9.1461544 ) (-5.76282025 29.508972 14.615385 -0.0307693854 -3.2692337 -8.9615364 ) (7.2179489 24.997432 11.346151 -8.99230767 -11.346151 8.99230767 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 50Q) (FACE M R R) (WIDTH 162 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:49:11) (MADE-FROM NIL 142 130 35 72) (SPLINES ((2 ((152 300) (143 312)) NIL ((-9. 12. 0 0 0 0 )) NATURAL) (17 ((143 312) (122 303) (98 289) (74 268) (51 242) (33 213) (22 182) (14 144) (13 112) (14 80) (22 42) (33 11) (51 -18) (74 -44) (98 -65) (122 -79) (143 -88)) NIL ((-20.19886 -8.08247376 0 0 -4.80682278 -5.5051546 ) (-22.602272 -10.8350505 -4.80682278 -5.5051546 6.03411675 -2.47422695 ) (-24.392036 -17.577316 1.22729444 -7.97938157 -1.32964873 3.40206242 ) (-23.829566 -23.855667 -0.102354377 -4.57731915 5.28447628 0.865979195 ) (-21.289684 -28. 5.18212223 -3.71133995 4.19173908 5.13401985 ) (-14.01169 -29.144329 9.3738613 1.42268037 -10.051439 -15.402059 ) (-9.6635475 -35.422676 -0.677578807 -13.979379 12.014028 26.474224 ) (-4.33411217 -36.164947 11.3364505 12.494844 -14.0046749 -12.494842 ) (1.59256160E-7 -29.917522 -2.66822576 5.11072471E-7 14.0046749 -12.494846 ) (4.33411217 -36.164947 11.3364505 -12.494846 -12.014028 26.474227 ) (9.6635475 -35.422676 -0.677578926 13.979381 10.051441 -15.402061 ) (14.011692 -29.144329 9.3738632 -1.42268037 -4.19174195 5.13401985 ) (21.289684 -27.999996 5.18212128 3.71133947 -5.28447533 0.865979672 ) (23.829566 -23.855667 -0.102354094 4.57731915 1.32964825 3.40206146 ) (24.392036 -17.577316 1.22729420 7.9793806 -6.03411675 -2.474226 ) (22.602272 -10.8350505 -4.80682278 5.5051546 4.80682278 -5.5051546 )) NATURAL) (2 ((143 -88) (152 -76)) NIL ((9. 12. 0 0 0 0 )) NATURAL) (6 ((152 -76) (134 -59) (117 -33) (104 3) (97 45) (93 112)) NIL ((-18.081337 15.311004 0 0 0.488038302 10.13397 ) (-17.837318 20.37799 0.488038302 10.13397 3.55980825 3.33014298 ) (-15.5693779 32.177032 4.0478468 13.464113 3.27272701 -17.45454 ) (-9.88516618 36.91387 7.3205738 -3.99043036 -4.65071774 42.488029 ) (-4.8899517 54.167465 2.66985607 38.497604 -2.66985607 -38.497604 )) NATURAL) (6 ((93 112) (97 179) (104 221) (117 257) (134 283) (152 300)) NIL ((3.55502367 73.416259 0 0 2.66985655 -38.497604 ) (4.8899517 54.167457 2.66985655 -38.497604 4.65071678 42.488029 ) (9.88516618 36.91387 7.3205738 3.99042988 -3.27272797 -17.45454 ) (15.5693779 32.177032 4.04784584 -13.464113 -3.5598073 3.33014298 ) (17.837318 20.377986 0.488038302 -10.13397 -0.488038302 10.13397 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 51Q) (FACE M R R) (WIDTH 162 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:51:46) (MADE-FROM NIL 226 130 35 72) (SPLINES ((17 ((17 312) (38 303) (62 289) (86 268) (109 242) (127 213) (138 182) (146 144) (147 112) (146 80) (138 42) (127 11) (109 -18) (86 -44) (62 -65) (38 -79) (17 -88)) NIL ((20.19886 -8.08247376 0 0 4.80682278 -5.5051546 ) (22.602272 -10.8350505 4.80682278 -5.5051546 -6.03411675 -2.47422695 ) (24.392036 -17.577316 -1.22729444 -7.97938157 1.32964873 3.40206242 ) (23.829566 -23.855667 0.102354377 -4.57731915 -5.28447628 0.865979195 ) (21.289684 -28. -5.18212223 -3.71133995 -4.19173908 5.13401985 ) (14.01169 -29.144329 -9.3738613 1.42268037 10.051439 -15.402059 ) (9.6635475 -35.422676 0.677578807 -13.979379 -12.014028 26.474224 ) (4.33411217 -36.164947 -11.3364505 12.494844 14.0046749 -12.494842 ) (-1.59256160E-7 -29.917522 2.66822576 5.11072471E-7 -14.0046749 -12.494846 ) (-4.33411217 -36.164947 -11.3364505 -12.494846 12.014028 26.474227 ) (-9.6635475 -35.422676 0.677578926 13.979381 -10.051441 -15.402061 ) (-14.011692 -29.144329 -9.3738632 -1.42268037 4.19174195 5.13401985 ) (-21.289684 -27.999996 -5.18212128 3.71133947 5.28447533 0.865979672 ) (-23.829566 -23.855667 0.102354094 4.57731915 -1.32964825 3.40206146 ) (-24.392036 -17.577316 -1.22729420 7.9793806 6.03411675 -2.474226 ) (-22.602272 -10.8350505 4.80682278 5.5051546 -4.80682278 -5.5051546 )) NATURAL) (2 ((17 -88) (8 -76)) NIL ((-9. 12. 0 0 0 0 )) NATURAL) (11 ((8 -76) (26 -59) (43 -33) (56 3) (63 45) (67 112) (63 179) (56 221) (43 257) (26 283) (8 300)) NIL ((18.091159 15.311004 0 0 -0.546961427 10.13397 ) (17.817676 20.37799 -0.546961427 10.13397 -3.2651925 3.33014298 ) (15.63812 32.177032 -3.81215429 13.464113 -4.39226532 -17.45454 ) (9.6298332 36.91387 -8.2044201 -3.99043036 8.8342533 42.488029 ) (5.84254074 54.167465 0.629834295 38.497604 -12.9447498 -38.497604 ) (-1.99303030E-7 73.416259 -12.3149166 0 12.9447498 -38.497604 ) (-5.84254074 54.167457 0.629834414 -38.497604 -8.8342533 42.488029 ) (-9.6298332 36.91387 -8.2044201 3.99043083 4.39226532 -17.454544 ) (-15.63812 32.177032 -3.81215429 -13.464115 3.26519299 3.33014488 ) (-17.817676 20.377986 -0.546961308 -10.13397 0.546961308 10.13397 )) NATURAL) (2 ((8 300) (17 312)) NIL ((9. 12. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 52Q) (FACE M R R) (WIDTH 282 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:56:10) (MADE-FROM NIL 104 130 52 68) (SPLINES ((2 ((129 224) (114 288)) NIL ((-15. 64. 0 0 0 0 )) NATURAL) (2 ((114 288) (164 288)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((164 288) (149 224)) NIL ((-15. -64. 0 0 0 0 )) NATURAL) (2 ((149 224) (198 266)) NIL ((49. 42. 0 0 0 0 )) NATURAL) (2 ((198 266) (223 236)) NIL ((25. -30. 0 0 0 0 )) NATURAL) (2 ((223 236) (158 208)) NIL ((-65. -28. 0 0 0 0 )) NATURAL) (2 ((158 208) (223 180)) NIL ((65. -28. 0 0 0 0 )) NATURAL) (2 ((223 180) (198 150)) NIL ((-25. -30. 0 0 0 0 )) NATURAL) (2 ((198 150) (149 192)) NIL ((-49. 42. 0 0 0 0 )) NATURAL) (2 ((149 192) (164 128)) NIL ((15. -64. 0 0 0 0 )) NATURAL) (2 ((164 128) (114 128)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((114 128) (129 192)) NIL ((15. 64. 0 0 0 0 )) NATURAL) (2 ((129 192) (80 150)) NIL ((-49. -42. 0 0 0 0 )) NATURAL) (2 ((80 150) (55 180)) NIL ((-25. 30. 0 0 0 0 )) NATURAL) (2 ((55 180) (120 208)) NIL ((65. 28. 0 0 0 0 )) NATURAL) (2 ((120 208) (55 236)) NIL ((-65. 28. 0 0 0 0 )) NATURAL) (2 ((55 236) (80 266)) NIL ((25. 30. 0 0 0 0 )) NATURAL) (2 ((80 266) (129 224)) NIL ((49. -42. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 55Q) (FACE M R R) (WIDTH 267 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 14:58:21) (MADE-FROM NIL 121 130 101 78) (SPLINES ((2 ((213 80) (53 80)) NIL ((-160. 0 0 0 0 0 )) NATURAL) (2 ((53 80) (53 140)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((53 140) (213 140)) NIL ((160. 0 0 0 0 0 )) NATURAL) (2 ((213 140) (213 80)) NIL ((0 -60. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 100Q) (FACE M R R) (WIDTH 241 0) (FIDUCIAL 275 275) (VERSION 0 3-OCT-77 15:01:19) (MADE-FROM NIL 136 116 118 52) (SPLINES ((12 ((158 121) (145 128) (128 130) (110 126) (92 113) (80 98) (72 82) (70 63) (74 45) (89 32) (112 29) (133 40)) NIL ((-11.972738 8.0720539 0 0 -6.16356755 -6.43233109 ) (-15.054521 4.85588837 -6.16356755 -6.43233109 6.8178396 2.16165829 ) (-17.809169 -0.495613098 0.654272318 -4.2706728 -3.10779333 -8.21430207 ) (-18.708793 -8.87343789 -2.45352125 -12.4849758 11.6133327 12.6955566 ) (-15.355648 -15.010633 9.1598129 0.210582316 -7.34554005 -0.567935109 ) (-9.86860658 -15.084018 1.81427216 -0.357352793 5.76882458 -4.42381764 ) (-5.16992092 -17.653282 7.58309746 -4.78117085 -3.72976494 6.26320649 ) (0.548294068 -19.302848 3.85333252 1.48203635 9.15023805 3.37098885 ) (8.9767456 -16.1353149 13.00357 4.85302544 -2.87118912 4.25283432 ) (20.544719 -9.15587426 10.132381 9.10585977 -15.6654758 9.61767388 ) (22.844364 4.75882149 -5.53309536 18.723533 5.53309536 -18.723533 )) NATURAL) (21 ((133 40) (140 32) (148 27) (164 25) (191 37) (208 57) (219 90) (215 123) (198 146) (174 160) (143 167) (108 164) (78 154) (51 134) (31 105) (23 71) (27 43) (43 17) (63 2) (88 -4) (112 -1)) NIL ((7.04713917 -8.83371926 0 0 -0.282836199 5.00231648 ) (6.9057207 -6.33256055 -0.282836199 5.00231648 7.41418076 -7.01158429 ) (10.329975 -4.83603668 7.1313448 -2.00926781 12.626108 23.044021 ) (23.774375 4.67670918 19.757453 21.034755 -39.918617 -19.16452 ) (23.572517 16.1292038 -20.161163 1.8702321 21.04837 17.614074 ) (13.935541 26.806472 0.887209058 19.48431 -20.274875 -21.291782 ) (4.68531037 35.644889 -19.387668 -1.8074727 6.05114175 -10.446945 ) (-11.676788 28.613945 -13.3365268 -12.254419 8.0703125 3.0795784 ) (-20.978157 17.8993149 -5.26621437 -9.1748409 -2.33239746 4.12862969 ) (-27.410572 10.7887878 -7.59861184 -5.04621125 1.25927829 -7.59409905 ) (-34.379539 1.94552779 -6.33933354 -12.64031 15.29528 8.24776269 ) (-33.071235 -6.5709009 8.95594789 -4.39254666 -8.4404068 -7.39695454 ) (-28.335495 -14.661924 0.515540362 -11.789501 6.46634865 3.34005737 ) (-24.586776 -24.781395 6.98188973 -8.4494438 6.57500649 0.0367221832 ) (-14.3173847 -33.212478 13.556896 -8.41272164 -2.76637268 20.51305 ) (-2.1436758 -31.368675 10.7905235 12.10033 4.49048424 -16.0889358 ) (10.8920898 -27.312812 15.2810077 -3.9886055 -15.195562 19.842693 ) (18.575313 -21.380069 0.0854441673 15.854089 8.29176904 -9.281847 ) (22.806644 -10.1669025 8.37721444 6.57224274 -11.971517 5.28469467 ) (25.1981 -0.952312470 -3.5943036 11.856937 3.5943036 -11.856937 )) NATURAL) (2 ((112 -1) (107 19)) NIL ((-5. 20. 0 0 0 0 )) NATURAL) (18 ((107 19) (86 18) (66 26) (50 47) (45 71) (49 95) (63 118) (83 134) (107 143) (136 146) (165 142) (186 130) (199 110) (200 86) (192 68) (184 59) (172 52) (162 56)) NIL ((-21.157852 -2.53653526 0 0 0.947122574 9.21921159 ) (-20.684291 2.07307052 0.947122574 9.21921159 1.26438713 7.9039421 ) (-19.104972 15.244255 2.2115097 17.123153 11.9953289 -16.834991 ) (-10.8958015 23.949909 14.206838 0.288160145 -7.24570466 -0.563958168 ) (-0.311814904 23.956092 6.96113396 -0.275798023 4.9874878 1.09082985 ) (9.1430626 24.225708 11.9486217 0.815032006 -6.70424843 -9.79936029 ) (17.739559 20.141059 5.24437332 -8.9843292 -2.17049026 2.10661602 ) (21.898689 12.210039 3.07388306 -6.8777132 3.38620949 1.37289524 ) (26.665676 6.01877404 6.46009255 -5.50481797 -5.37434674 -1.59819507 ) (30.438594 -0.285140633 1.08574557 -7.10301304 -11.8888187 -0.980116845 ) (25.579929 -7.87821198 -10.8030738 -8.08312989 4.92962837 -0.481334686 ) (17.241668 -16.202007 -5.8734455 -8.56446458 -7.82969475 2.90545654 ) (7.4533777 -23.313743 -13.70314 -5.65900803 2.38915062 12.859506 ) (-5.05518723 -22.542999 -11.3139896 7.20049954 16.273094 5.65650845 ) (-8.23262979 -12.514246 4.95910454 12.8570079 -13.481531 -17.485542 ) (-10.0142917 -8.40000917 -8.5224266 -4.62853527 13.653032 22.285663 ) (-11.710201 -1.88571024 5.13060665 17.657131 -5.13060665 -17.657131 )) NATURAL) (5 ((162 56) (178 116) (178 126) (168 126) (158 121)) NIL ((19.571426 72.76785 0 0 -21.428569 -76.60713 ) (8.8571415 34.464279 -21.428569 -76.60713 11.1428566 83.03569 ) (-7. -0.624999643 -10.285713 6.42857075 12.857141 -15.535713 ) (-10.857141 -1.96428537 2.5714283 -9.1071434 -2.5714283 9.1071434 )) NATURAL)) ((10 ((140 100) (136 107) (124 107) (108 95) (100 75) (104 56) (118 54) (128 64) (136 84) (140 100)) NIL ((-2.25083256 8.15301515 0 0 -10.4950046 -6.9180908 ) (-7.49833489 4.69396878 -10.4950046 -6.9180908 4.47502804 -7.409544 ) (-15.7558269 -5.92889405 -6.0199766 -14.3276348 16.59489 6.55626965 ) (-13.478355 -16.978393 10.5749149 -7.77136517 1.14539718 5.1844616 ) (-2.33074379 -22.157527 11.720312 -2.58690309 2.82352638 26.705879 ) (10.8013305 -11.391489 14.543838 24.118976 -24.439506 -16.007988 ) (13.1254139 4.72349262 -9.89566995 8.1109867 10.934515 7.32608224 ) (8.6970024 16.49752 1.03884577 15.4370689 -7.29855633 -25.296333 ) (6.08656979 19.286418 -6.25971127 -9.85926629 6.25971127 9.85926629 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 134Q) (FACE M R R) (WIDTH 312 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 15:06:12) (MADE-FROM NIL 60 130 27 74) (SPLINES ((2 ((241 0) (33 294)) NIL ((-208. 294. 0 0 0 0 )) NATURAL) (2 ((33 294) (65 294)) NIL ((32. 0 0 0 0 0 )) NATURAL) (2 ((65 294) (273 0)) NIL ((208. -294. 0 0 0 0 )) NATURAL) (2 ((273 0) (241 0)) NIL ((-32. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 176Q) (FACE M R R) (WIDTH 223 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 15:07:05) (MADE-FROM NIL 90 130 59 73) (SPLINES ((2 ((146 200) (186 200)) NIL ((40. 0 0 0 0 0 )) NATURAL) (12 ((186 200) (184 188) (181 173) (173 156) (162 146) (149 142) (133 141) (115 147) (101 154) (87 157) (77 151) (74 143)) NIL ((-2.0406394 -11.4451789 0 0 0.243838072 -3.3289156 ) (-1.91872048 -13.109638 0.243838072 -3.3289156 -7.21918965 -1.35542106 ) (-5.28447724 -17.116264 -6.97535229 -4.68433666 4.63292313 14.7505989 ) (-9.943367 -14.4253 -2.34242868 10.066263 0.687495947 -3.64697933 ) (-11.942049 -6.18252755 -1.65493273 6.41928387 -1.38290715 -6.1626854 ) (-14.288435 -2.84458589 -3.03783989 0.256598294 -1.15586662 10.2977218 ) (-17.904209 2.5608735 -4.1937065 10.554321 12.006374 -11.0282058 ) (-16.094726 7.60109139 7.81266785 -0.473885357 -10.8696327 -2.18489456 ) (-13.716875 6.03475857 -3.05696487 -2.6587801 7.47215558 -10.23221 ) (-13.037763 -1.74012756 4.4151907 -12.890991 4.98101139 13.113739 ) (-6.13206673 -8.07424928 9.3962021 0.222748071 -9.3962021 -0.222748071 )) NATURAL) (2 ((74 143) (34 143)) NIL ((-40. 0 0 0 0 0 )) NATURAL) (12 ((34 143) (36 155) (39 170) (47 187) (58 197) (71 201) (87 202) (105 196) (119 189) (133 186) (143 192) (146 200)) NIL ((2.0406394 11.4451789 0 0 -0.243838072 3.3289156 ) (1.91872048 13.109638 -0.243838072 3.3289156 7.21918965 1.35542106 ) (5.28447724 17.116264 6.97535229 4.68433666 -4.63292313 -14.7505989 ) (9.943367 14.4253 2.34242868 -10.066263 -0.687495947 3.64697933 ) (11.942049 6.18252755 1.65493273 -6.41928387 1.38290715 6.1626854 ) (14.288435 2.84458589 3.03783989 -0.256598294 1.15586662 -10.2977218 ) (17.904209 -2.5608735 4.1937065 -10.554321 -12.006374 11.0282058 ) (16.094726 -7.60109139 -7.81266785 0.473885357 10.8696327 2.18489456 ) (13.716875 -6.03475857 3.05696487 2.6587801 -7.47215558 10.23221 ) (13.037763 1.74012756 -4.4151907 12.890991 -4.98101139 -13.113739 ) (6.13206673 8.07424928 -9.3962021 -0.222748071 9.3962021 0.222748071 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 30Q) (FACE M R R) (WIDTH 490 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 15:10:26) (MADE-FROM NIL 13 131 0 0) (SPLINES ((2 ((0 -53) (489 -53)) NIL ((489. 0 0 0 0 0 )) NATURAL) (2 ((489 -53) (489 -93)) NIL ((0 -40. 0 0 0 0 )) NATURAL) (2 ((489 -93) (0 -93)) NIL ((-489. 0 0 0 0 0 )) NATURAL) (2 ((0 -93) (0 -53)) NIL ((0 40. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 40Q) (FACE M R R) (WIDTH 312 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 15:11:15) (MADE-FROM NIL 142 130 0 0) (SPLINES)) ((FAMILY TIMESROMAND) (CHARACTER 53Q) (FACE M R R) (WIDTH 327 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:36:02) (MADE-FROM NIL 122 130 68 75) (SPLINES ((2 ((132 0) (192 0)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((192 0) (192 80)) NIL ((0 80. 0 0 0 0 )) NATURAL) (2 ((192 80) (272 80)) NIL ((80. 0 0 0 0 0 )) NATURAL) (2 ((272 80) (272 140)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((272 140) (192 140)) NIL ((-80. 0 0 0 0 0 )) NATURAL) (2 ((192 140) (192 220)) NIL ((0 80. 0 0 0 0 )) NATURAL) (2 ((192 220) (132 220)) NIL ((-60. 0 0 0 0 0 )) NATURAL) (2 ((132 220) (132 140)) NIL ((0 -80. 0 0 0 0 )) NATURAL) (2 ((132 140) (52 140)) NIL ((-80. 0 0 0 0 0 )) NATURAL) (2 ((52 140) (52 80)) NIL ((0 -60. 0 0 0 0 )) NATURAL) (2 ((52 80) (132 80)) NIL ((80. 0 0 0 0 0 )) NATURAL) (2 ((132 80) (132 0)) NIL ((0 -80. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 75Q) (FACE M R R) (WIDTH 267 0) (FIDUCIAL 385 385) (VERSION 0 4-OCT-77 9:36:52) (MADE-FROM NIL 120 130 84 94) (SPLINES ((2 ((214 40) (54 40)) NIL ((-160. 0 0 0 0 0 )) NATURAL) (2 ((54 40) (54 100)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((54 100) (214 100)) NIL ((160. 0 0 0 0 0 )) NATURAL) (2 ((214 100) (214 40)) NIL ((0 -60. 0 0 0 0 )) NATURAL)) ((2 ((54 140) (54 200)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((54 200) (214 200)) NIL ((160. 0 0 0 0 0 )) NATURAL) (2 ((214 200) (214 140)) NIL ((0 -60. 0 0 0 0 )) NATURAL) (2 ((214 140) (54 140)) NIL ((-160. 0 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.S3-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.S3-SF deleted file mode 100644 index 0185738c..00000000 --- a/obsolete/lispusers/splinefonts/TIMESROMAN.S3-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY TIMESROMAND) (CHARACTER 56Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:21:11) (MADE-FROM NIL 201 130 35 72) (SPLINES ((17 ((86 -6) (67 -3) (52 4) (44 13) (41 27) (44 41) (52 50) (67 57) (86 60) (105 57) (120 50) (128 41) (131 27) (128 13) (120 4) (105 -3) (86 -6)) NIL ((-19.639171 1.98203754 0 0 3.83505154 6.10777474 ) (-17.721649 5.0359249 3.83505154 6.10777474 4.82474232 -6.53887368 ) (-11.474226 7.87426186 8.65979386 -0.431099415 -5.1340208 8.04772187 ) (-5.38144303 11.4670238 3.52577257 7.6166229 3.71134043 -7.65201569 ) (8.00937414E-8 15.2576389 7.237113 -0.0353937074 -3.71133947 -7.43965436 ) (5.38144303 11.5024166 3.52577353 -7.47504807 5.13401795 7.41063786 ) (11.474226 7.73268796 8.65979196 -0.0644102097 -4.8247404 -4.20289994 ) (17.721649 5.5668268 3.83505154 -4.26731014 -3.83505106 -2.59903431 ) (19.639171 0 1.27768117E-7 -6.86634446 -3.835052 2.59903335 ) (17.721649 -5.56682778 -3.835052 -4.2673111 -4.82473946 4.20290089 ) (11.474226 -7.73268796 -8.65979196 -0.0644097030 5.1340189 -7.4106388 ) (5.38144303 -11.5024166 -3.52577305 -7.475049 -3.71133995 7.4396553 ) (-1.59256160E-7 -15.2576389 -7.237113 -0.0353935584 3.71133995 7.65201569 ) (-5.38144303 -11.4670238 -3.52577305 7.6166229 -5.1340208 -8.04772187 ) (-11.474226 -7.87426186 -8.65979386 -0.431099653 4.82474232 6.53887368 ) (-17.721649 -5.0359249 -3.83505154 6.10777474 3.83505154 -6.10777474 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 72Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:22:34) (MADE-FROM NIL 201 130 35 72) (SPLINES ((17 ((86 205) (67 202) (52 195) (44 186) (41 172) (44 158) (52 149) (67 142) (86 139) (105 142) (120 149) (128 158) (131 172) (128 186) (120 195) (105 202) (86 205)) NIL ((-19.818656 -0.00128221511 0.621745348 -6.86153794 3.04670906 2.59230709 ) (-17.673553 -5.5666666 3.66845465 -4.26923085 5.0359783 4.20769406 ) (-11.487112 -7.73204995 8.70443345 -0.0615364760 -5.19062138 -7.4230852 ) (-5.37798977 -11.5051288 3.51381207 -7.484622 3.72650528 7.48464394 ) (-9.24904831E-4 -15.2474289 7.24031735 2.27427262E-5 -3.7154026 7.48450757 ) (5.38169098 -11.5051517 3.52491474 7.48453046 5.13510609 -7.42267228 ) (11.474159 -7.7319584 8.6600208 0.0618574098 -4.8250265 4.20618153 ) (17.721668 -5.56700897 3.83499432 4.2680397 -3.83499432 2.59793949 ) (19.6391639 3.18512320E-7 0 6.8659792 -3.83499432 -2.59793949 ) (17.721668 5.56700993 -3.83499432 4.2680397 -4.82502842 -4.20618153 ) (11.474159 7.7319584 -8.66002275 0.0618574098 5.135108 7.4226713 ) (5.38169098 11.5051517 -3.52491427 7.4845295 -3.71540403 -7.4845066 ) (-9.25144181E-4 15.2474289 -7.2403183 2.27427262E-5 3.72650576 -7.48464299 ) (-5.37798977 11.5051288 -3.51381254 -7.48462105 -5.1906185 7.42308427 ) (-11.487112 7.73204995 -8.70443154 -0.0615367144 5.03597546 -4.20769406 ) (-17.673553 5.5666666 -3.6684556 -4.26923085 3.04671001 -2.59230709 )) PSEUDOCYCLIC)) ((17 ((86 -6) (67 -3) (52 4) (44 13) (41 27) (44 41) (52 50) (67 57) (86 60) (105 57) (120 50) (128 41) (131 27) (128 13) (120 4) (105 -3) (86 -6)) NIL ((-19.818656 0.00128221511 0.621745348 6.86153794 3.04670906 -2.59230709 ) (-17.673553 5.5666666 3.66845465 4.26923085 5.0359783 -4.20769406 ) (-11.487112 7.73204995 8.70443345 0.0615364760 -5.19062138 7.4230852 ) (-5.37798977 11.5051288 3.51381207 7.484622 3.72650528 -7.48464394 ) (-9.24904831E-4 15.2474289 7.24031735 -2.27427262E-5 -3.7154026 -7.48450757 ) (5.38169098 11.5051517 3.52491474 -7.48453046 5.13510609 7.42267228 ) (11.474159 7.7319584 8.6600208 -0.0618574098 -4.8250265 -4.20618153 ) (17.721668 5.56700897 3.83499432 -4.2680397 -3.83499432 -2.59793949 ) (19.6391639 -3.18512320E-7 0 -6.8659792 -3.83499432 2.59793949 ) (17.721668 -5.56700993 -3.83499432 -4.2680397 -4.82502842 4.20618153 ) (11.474159 -7.7319584 -8.66002275 -0.0618574098 5.135108 -7.4226713 ) (5.38169098 -11.5051517 -3.52491427 -7.4845295 -3.71540403 7.4845066 ) (-9.25144181E-4 -15.2474289 -7.2403183 -2.27427262E-5 3.72650576 7.48464299 ) (-5.37798977 -11.5051288 -3.51381254 7.48462105 -5.1906185 -7.42308427 ) (-11.487112 -7.73204995 -8.70443154 0.0615367144 5.03597546 4.20769406 ) (-17.673553 -5.5666666 -3.6684556 4.26923085 3.04671001 2.59230709 )) PSEUDOCYCLIC)))) ((FAMILY TIMESROMAND) (CHARACTER 73Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:26:06) (MADE-FROM NIL 201 130 35 72) (SPLINES ((17 ((86 205) (67 202) (52 195) (44 186) (41 172) (44 158) (52 149) (67 142) (86 139) (105 142) (120 149) (128 158) (131 172) (128 186) (120 195) (105 202) (86 205)) NIL ((-19.818656 -0.00128221511 0.621745348 -6.86153794 3.04670906 2.59230709 ) (-17.673553 -5.5666666 3.66845465 -4.26923085 5.0359783 4.20769406 ) (-11.487112 -7.73204995 8.70443345 -0.0615364760 -5.19062138 -7.4230852 ) (-5.37798977 -11.5051288 3.51381207 -7.484622 3.72650528 7.48464394 ) (-9.24904831E-4 -15.2474289 7.24031735 2.27427262E-5 -3.7154026 7.48450757 ) (5.38169098 -11.5051517 3.52491474 7.48453046 5.13510609 -7.42267228 ) (11.474159 -7.7319584 8.6600208 0.0618574098 -4.8250265 4.20618153 ) (17.721668 -5.56700897 3.83499432 4.2680397 -3.83499432 2.59793949 ) (19.6391639 3.18512320E-7 0 6.8659792 -3.83499432 -2.59793949 ) (17.721668 5.56700993 -3.83499432 4.2680397 -4.82502842 -4.20618153 ) (11.474159 7.7319584 -8.66002275 0.0618574098 5.135108 7.4226713 ) (5.38169098 11.5051517 -3.52491427 7.4845295 -3.71540403 -7.4845066 ) (-9.25144181E-4 15.2474289 -7.2403183 2.27427262E-5 3.72650576 -7.48464299 ) (-5.37798977 11.5051288 -3.51381254 -7.48462105 -5.1906185 7.42308427 ) (-11.487112 7.73204995 -8.70443154 -0.0615367144 5.03597546 -4.20769406 ) (-17.673553 5.5666666 -3.6684556 -4.26923085 3.04671001 -2.59230709 )) PSEUDOCYCLIC)) ((24 ((92 -4) (78 -6) (59 -3) (44 4) (36 13) (33 27) (36 41) (44 50) (59 57) (78 60) (101 58) (121 49) (135 33) (140 6) (134 -19) (114 -44) (94 -58) (75 -66) (52 -73) (44 -70) (50 -63) (69 -50) (85 -29) (92 -4)) NIL ((-12.4890136 -3.06699467 0 0 -9.06590844 6.4019699 ) (-17.0219688 0.133990109 -9.06590844 6.4019699 15.3295459 -2.0098505 ) (-18.423103 5.53103447 6.26363755 4.3921194 1.74772072 -4.3625698 ) (-11.285606 7.74186898 8.01135827 0.0295492597 -4.3204298 7.4601326 ) (-5.4344635 11.5014858 3.69092798 7.4896822 3.53399801 -7.47796345 ) (0.0234638825 15.2521858 7.224926 0.0117186158 -3.8155613 -7.548275 ) (5.3406086 11.489765 3.4093647 -7.5365572 5.7282505 7.67106915 ) (11.614099 7.78874398 9.1376152 0.134512752 -7.0974474 -5.13600445 ) (17.202991 5.35525418 2.04016733 -5.0014925 4.6615448 0.872951508 ) (21.573928 0.790237070 6.7017126 -4.128541 -11.5487308 -4.35579968 ) (22.501277 -5.51620388 -4.8470192 -8.48434068 -0.466615677 4.55025006 ) (17.4209518 -11.72542 -5.31363487 -3.93409014 -4.58480644 -13.845201 ) (9.8149128 -22.582111 -9.8984413 -17.779293 0.805843354 26.830558 ) (0.319392502 -26.946125 -9.09259797 9.0512676 -10.638561 -15.4770488 ) (-14.092487 -25.63338 -19.731159 -6.4257822 23.748405 23.07764 ) (-21.94944 -20.520339 4.0172472 16.651859 -0.355079651 -10.8335209 ) (-18.109733 -9.28524209 3.66216755 5.81833744 -16.328083 -9.74355317 ) (-22.61161 -8.33868218 -12.665918 -3.9252162 35.667419 19.807739 ) (-17.443813 -2.36002731 23.001506 15.882526 -12.341625 -15.487413 ) (-0.613120318 5.77879143 10.6598816 0.395112217 7.6990776 6.14191056 ) (13.896299 9.2448597 18.358959 6.53702355 -24.454681 2.91976929 ) (20.027915 17.2417679 -6.09572316 9.4567928 -5.88034535 -5.8209915 ) (10.9920215 23.788063 -11.976068 3.63580132 11.976068 -3.63580132 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 54Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:27:04) (MADE-FROM NIL 201 130 35 72) (SPLINES ((24 ((92 -4) (78 -6) (59 -3) (44 4) (36 13) (33 27) (36 41) (44 50) (59 57) (78 60) (101 58) (121 49) (135 33) (140 6) (134 -19) (114 -44) (94 -58) (75 -66) (52 -73) (44 -70) (50 -63) (69 -50) (85 -29) (92 -4)) NIL ((-12.4890136 -3.06699467 0 0 -9.06590844 6.4019699 ) (-17.0219688 0.133990109 -9.06590844 6.4019699 15.3295459 -2.0098505 ) (-18.423103 5.53103447 6.26363755 4.3921194 1.74772072 -4.3625698 ) (-11.285606 7.74186898 8.01135827 0.0295492597 -4.3204298 7.4601326 ) (-5.4344635 11.5014858 3.69092798 7.4896822 3.53399801 -7.47796345 ) (0.0234638825 15.2521858 7.224926 0.0117186158 -3.8155613 -7.548275 ) (5.3406086 11.489765 3.4093647 -7.5365572 5.7282505 7.67106915 ) (11.614099 7.78874398 9.1376152 0.134512752 -7.0974474 -5.13600445 ) (17.202991 5.35525418 2.04016733 -5.0014925 4.6615448 0.872951508 ) (21.573928 0.790237070 6.7017126 -4.128541 -11.5487308 -4.35579968 ) (22.501277 -5.51620388 -4.8470192 -8.48434068 -0.466615677 4.55025006 ) (17.4209518 -11.72542 -5.31363487 -3.93409014 -4.58480644 -13.845201 ) (9.8149128 -22.582111 -9.8984413 -17.779293 0.805843354 26.830558 ) (0.319392502 -26.946125 -9.09259797 9.0512676 -10.638561 -15.4770488 ) (-14.092487 -25.63338 -19.731159 -6.4257822 23.748405 23.07764 ) (-21.94944 -20.520339 4.0172472 16.651859 -0.355079651 -10.8335209 ) (-18.109733 -9.28524209 3.66216755 5.81833744 -16.328083 -9.74355317 ) (-22.61161 -8.33868218 -12.665918 -3.9252162 35.667419 19.807739 ) (-17.443813 -2.36002731 23.001506 15.882526 -12.341625 -15.487413 ) (-0.613120318 5.77879143 10.6598816 0.395112217 7.6990776 6.14191056 ) (13.896299 9.2448597 18.358959 6.53702355 -24.454681 2.91976929 ) (20.027915 17.2417679 -6.09572316 9.4567928 -5.88034535 -5.8209915 ) (10.9920215 23.788063 -11.976068 3.63580132 11.976068 -3.63580132 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 7Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:31:50) (MADE-FROM NIL 142 130 35 72) (SPLINES ((24 ((80 228) (94 230) (113 227) (128 220) (136 211) (139 197) (136 183) (128 174) (113 167) (94 164) (71 166) (51 175) (37 191) (31 218) (38 243) (58 268) (78 282) (97 290) (120 297) (128 294) (122 287) (103 274) (87 253) (80 228)) NIL ((12.4890136 3.06699467 0 0 9.06591035 -6.4019699 ) (17.0219688 -0.133990109 9.06591035 -6.4019699 -15.329553 2.0098505 ) (18.423103 -5.53103447 -6.26364327 -4.3921194 -1.74769401 4.3625698 ) (11.285612 -7.74186898 -8.01133729 -0.0295492597 4.32033539 -7.4601326 ) (5.43444157 -11.5014858 -3.69100189 -7.4896822 -3.53364849 7.47796345 ) (-0.0233840942 -15.2521858 -7.22465039 -0.0117186158 3.81425572 7.548275 ) (-5.34090615 -11.489765 -3.41039467 7.5365572 -5.7233753 -7.67106915 ) (-11.612989 -7.78874398 -9.13377 -0.134512752 7.07924843 5.13600445 ) (-17.207134 -5.35525418 -2.05452156 5.0014925 -4.59362126 -0.872951508 ) (-21.558467 -0.790237070 -6.6481428 4.128541 11.2952366 4.35579968 ) (-22.55899 5.51620388 4.64709378 8.48434068 1.4126749 -4.55025006 ) (-17.205558 11.72542 6.05976868 3.93409014 1.05406284 13.845201 ) (-10.618759 22.582111 7.1138315 17.779293 6.3710699 -26.830558 ) (-0.319392502 26.946125 13.484901 -9.0512676 3.46165085 15.4770488 ) (14.896333 25.63338 16.946552 6.4257822 -20.217666 -23.07764 ) (21.73405 20.520339 -3.2711153 -16.651859 -0.590978146 10.8335209 ) (18.167446 9.28524209 -3.86209345 -5.81833744 16.581581 9.74355317 ) (22.596145 8.33868218 12.719488 3.9252162 -35.735343 -19.807739 ) (17.447956 2.36002731 -23.015861 -15.882526 12.359827 15.487413 ) (0.612009645 -5.77879143 -10.656034 -0.395112217 -7.7039547 -6.14191056 ) (-13.8960018 -9.2448597 -18.359989 -6.53702355 24.455986 -2.91976929 ) (-20.027996 -17.2417679 6.09599686 -9.4567928 5.88000298 5.8209915 ) (-10.9919986 -23.788063 11.9759998 -3.63580132 -11.9759998 3.63580132 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 47Q) (FACE M R R) (WIDTH 168 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:37:31) (MADE-FROM NIL 201 130 35 72) (SPLINES ((24 ((92 236) (85 211) (69 190) (50 177) (44 170) (52 167) (75 174) (94 182) (114 196) (134 221) (140 246) (135 273) (121 289) (101 298) (78 300) (59 297) (44 290) (36 281) (33 267) (36 253) (44 244) (59 237) (78 234) (92 236)) NIL ((-5.00398827 -25.605964 0 0 -11.976068 3.63580179 ) (-10.992023 -23.788063 -11.976068 3.63580179 5.8803463 5.82099056 ) (-20.027915 -17.2417679 -6.0957222 9.4567928 24.454681 -2.91976929 ) (-13.896299 -9.2448597 18.358959 6.53702355 -7.6990757 -6.1419115 ) (0.613121629 -5.77879143 10.659883 0.395111680 12.341619 15.487413 ) (17.443817 2.36002684 23.001503 15.882526 -35.667419 -19.807739 ) (22.61161 8.33868218 -12.665918 -3.9252162 16.328083 9.74355508 ) (18.109733 9.28524209 3.66216755 5.81833935 0.355080604 10.8335189 ) (21.949443 20.520343 4.01724816 16.651859 -23.748405 -23.07764 ) (14.092485 25.63338 -19.731159 -6.4257822 10.638561 15.4770488 ) (-0.319393754 26.946125 -9.09259797 9.0512676 -0.805843354 -26.830555 ) (-9.8149128 22.582111 -9.8984413 -17.779289 4.58480644 13.8451976 ) (-17.4209518 11.72542 -5.31363487 -3.93409157 0.466615677 -4.5502491 ) (-22.501277 5.51620293 -4.8470192 -8.48434068 11.5487308 4.35579968 ) (-21.573928 -0.790237547 6.7017126 -4.128541 -4.6615448 -0.872951508 ) (-17.202991 -5.35525418 2.04016733 -5.0014925 7.0974493 5.1360054 ) (-11.614099 -7.78874398 9.1376171 0.134513020 -5.72825337 -7.67107106 ) (-5.3406086 -11.489765 3.40936375 -7.53655816 3.81556225 7.54827595 ) (-0.0234634876 -15.2521858 7.224926 0.0117186382 -3.53399706 7.4779644 ) (5.4344635 -11.5014858 3.69092894 7.48968316 4.32042694 -7.46013356 ) (11.285606 -7.74186898 8.01135636 0.0295491926 -1.74771785 4.3625698 ) (18.423103 -5.53103447 6.2636385 4.3921194 -15.3295479 2.0098505 ) (17.0219688 -0.133989960 -9.06591035 6.4019699 9.06591035 -6.4019699 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 42Q) (FACE M R R) (WIDTH 303 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:38:40) (MADE-FROM NIL 24 130 0 0) (SPLINES ((8 ((211 300) (191 297) (175 289) (168 275) (170 252) (180 223) (191 189) (198 168)) NIL ((-20.560287 -1.93747854 0 0 3.36173153 -6.37512875 ) (-18.879421 -5.1250429 3.36173153 -6.37512875 7.19134236 1.87564373 ) (-11.922018 -10.562349 10.5530738 -4.49948502 -2.1271038 -7.1274452 ) (-2.43249702 -18.6255569 8.42597009 -11.62693 1.31707191 8.63414384 ) (6.65200997 -25.935417 9.743042 -2.99278593 -9.14118577 -9.4091358 ) (11.824457 -33.632766 0.601855278 -12.401922 -6.75231934 35.002395 ) (9.05015374 -28.533493 -6.15046406 22.600479 6.15046406 -22.600479 )) NATURAL) (2 ((198 168) (224 168)) NIL ((26. 0 0 0 0 0 )) NATURAL) (8 ((224 168) (231 189) (242 223) (252 252) (254 275) (247 289) (231 297) (211 300)) NIL ((5.97492218 17.233253 0 0 6.1504631 22.600479 ) (9.05015374 28.533493 6.1504631 22.600479 -6.75231839 -35.002395 ) (11.824457 33.632766 -0.601855397 -12.401922 -9.14118577 9.4091358 ) (6.652009 25.935417 -9.743042 -2.99278593 1.31707191 -8.63414575 ) (-2.4324975 18.6255569 -8.42597009 -11.626932 -2.1271038 7.12744809 ) (-11.9220199 10.562349 -10.5530738 -4.49948406 7.19134236 -1.87564468 ) (-18.879421 5.1250429 -3.36173153 -6.37512875 3.36173153 6.37512875 )) NATURAL)) ((8 ((91 300) (71 297) (55 289) (48 275) (50 252) (60 223) (71 189) (78 168)) NIL ((-20.560287 -1.93747854 0 0 3.36173153 -6.37512875 ) (-18.879421 -5.1250429 3.36173153 -6.37512875 7.19134236 1.87564373 ) (-11.922018 -10.562349 10.5530738 -4.49948502 -2.1271038 -7.1274452 ) (-2.43249702 -18.6255569 8.42597009 -11.62693 1.31707191 8.63414384 ) (6.65200997 -25.935417 9.743042 -2.99278593 -9.14118577 -9.4091358 ) (11.824457 -33.632766 0.601855278 -12.401922 -6.75231934 35.002395 ) (9.05015374 -28.533493 -6.15046406 22.600479 6.15046406 -22.600479 )) NATURAL) (2 ((78 168) (104 168)) NIL ((26. 0 0 0 0 0 )) NATURAL) (8 ((104 168) (111 189) (122 223) (132 252) (134 275) (127 289) (111 297) (91 300)) NIL ((5.97492218 17.233253 0 0 6.1504631 22.600479 ) (9.05015374 28.533493 6.1504631 22.600479 -6.75231839 -35.002395 ) (11.824457 33.632766 -0.601855397 -12.401922 -9.14118577 9.4091358 ) (6.652009 25.935417 -9.743042 -2.99278593 1.31707191 -8.63414575 ) (-2.4324975 18.6255569 -8.42597009 -11.626932 -2.1271038 7.12744809 ) (-11.9220199 10.562349 -10.5530738 -4.49948406 7.19134236 -1.87564468 ) (-18.879421 5.1250429 -3.36173153 -6.37512875 3.36173153 6.37512875 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 57Q) (FACE M R R) (WIDTH 312 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:41:07) (MADE-FROM NIL 117 130 0 0) (SPLINES ((2 ((35 0) (67 0)) NIL ((32. 0 0 0 0 0 )) NATURAL) (2 ((67 0) (270 294)) NIL ((203. 294. 0 0 0 0 )) NATURAL) (2 ((270 294) (238 294)) NIL ((-32. 0 0 0 0 0 )) NATURAL) (2 ((238 294) (35 0)) NIL ((-203. -294. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 74Q) (FACE M R R) (WIDTH 267 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:44:20) (MADE-FROM NIL 88 130 0 0) (SPLINES ((2 ((166 0) (38 147)) NIL ((-128. 147. 0 0 0 0 )) NATURAL) (2 ((38 147) (166 294)) NIL ((128. 147. 0 0 0 0 )) NATURAL) (2 ((166 294) (226 294)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((226 294) (98 147)) NIL ((-128. -147. 0 0 0 0 )) NATURAL) (2 ((98 147) (226 0)) NIL ((128. -147. 0 0 0 0 )) NATURAL) (2 ((226 0) (166 0)) NIL ((-60. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 76Q) (FACE M R R) (WIDTH 267 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:46:22) (MADE-FROM NIL 155 130 0 0) (SPLINES ((2 ((39 0) (167 147)) NIL ((128. 147. 0 0 0 0 )) NATURAL) (2 ((167 147) (39 294)) NIL ((-128. 147. 0 0 0 0 )) NATURAL) (2 ((39 294) (99 294)) NIL ((60. 0 0 0 0 0 )) NATURAL) (2 ((99 294) (227 147)) NIL ((128. -147. 0 0 0 0 )) NATURAL) (2 ((227 147) (99 0)) NIL ((-128. -147. 0 0 0 0 )) NATURAL) (2 ((99 0) (39 0)) NIL ((-60. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 77Q) (FACE M R R) (WIDTH 243 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:48:44) (MADE-FROM NIL 166 130 35 72) (SPLINES ((17 ((121 -6) (140 -3) (155 4) (163 13) (166 27) (163 41) (155 50) (140 57) (121 60) (102 57) (87 50) (79 41) (76 27) (79 13) (87 4) (102 -3) (121 -6)) NIL ((19.639171 1.98203754 0 0 -3.83505154 6.10777474 ) (17.721649 5.0359249 -3.83505154 6.10777474 -4.82474232 -6.53887368 ) (11.474226 7.87426186 -8.65979386 -0.431099415 5.1340208 8.04772187 ) (5.38144303 11.4670238 -3.52577257 7.6166229 -3.71134043 -7.65201569 ) (-8.00937414E-8 15.2576389 -7.237113 -0.0353937074 3.71133947 -7.43965436 ) (-5.38144303 11.5024166 -3.52577353 -7.47504807 -5.13401795 7.41063786 ) (-11.474226 7.73268796 -8.65979196 -0.0644102097 4.8247404 -4.20289994 ) (-17.721649 5.5668268 -3.83505154 -4.26731014 3.83505106 -2.59903431 ) (-19.639171 0 -1.27768117E-7 -6.86634446 3.835052 2.59903335 ) (-17.721649 -5.56682778 3.835052 -4.2673111 4.82473946 4.20290089 ) (-11.474226 -7.73268796 8.65979196 -0.0644097030 -5.1340189 -7.4106388 ) (-5.38144303 -11.5024166 3.52577305 -7.475049 3.71133995 7.4396553 ) (1.59256160E-7 -15.2576389 7.237113 -0.0353935584 -3.71133995 7.65201569 ) (5.38144303 -11.4670238 3.52577305 7.6166229 5.1340208 -8.04772187 ) (11.474226 -7.87426186 8.65979386 -0.431099653 -4.82474232 6.53887368 ) (17.721649 -5.0359249 3.83505154 6.10777474 -3.83505154 -6.10777474 )) NATURAL)) ((2 ((100 93) (130 93)) NIL ((30. 0 0 0 0 0 )) NATURAL) (28 ((130 93) (133 114) (143 132) (169 148) (197 169) (216 197) (217 232) (205 259) (181 280) (149 292) (111 295) (72 290) (42 274) (25 246) (33 213) (61 203) (84 206) (101 224) (96 250) (87 265) (96 275) (112 267) (123 245) (127 215) (120 173) (105 141) (99 113) (100 93)) NIL ((2.20930052 21.587924 0 0 4.74419689 -3.52756643 ) (4.58139897 19.824142 4.74419689 -3.52756643 18.279014 -0.362166881 ) (18.465103 16.115493 23.023212 -3.88973332 -23.860263 10.976232 ) (29.558181 17.713874 -0.837053538 7.08650017 -6.83794499 -1.54276752 ) (25.302154 24.028991 -7.67499924 5.54373265 -14.787948 7.1948328 ) (10.233181 33.170143 -22.462947 12.738565 11.989748 -27.23656 ) (-6.2348919 32.29042 -10.4731998 -14.497997 -3.1710453 11.7514228 ) (-18.293613 23.66814 -13.644245 -2.74657297 6.69443608 -7.76913357 ) (-28.59064 17.036998 -6.94980908 -10.515707 0.393295288 1.32511329 ) (-35.343803 7.18384934 -6.55651379 -9.1905937 3.73237848 2.46868038 ) (-40.034126 -0.772403956 -2.8241353 -6.72191334 14.6771907 -5.19983578 ) (-35.519668 -10.094236 11.8530559 -11.921749 -2.44114303 0.330665588 ) (-24.887184 -21.85065 9.4119129 -11.591083 19.087368 -2.12282944 ) (-5.9315853 -34.50315 28.499282 -13.7139129 -1.90833282 50.16065 ) (21.613529 -23.136734 26.59095 36.446739 -41.45404 -30.519794 ) (27.477458 -1.94989419 -14.86309 5.92694378 17.724498 11.918533 ) (21.476619 9.93631745 2.86140919 17.845478 -35.443946 -5.15433884 ) (6.6160507 25.204624 -32.582542 12.691139 28.051315 -33.30117 ) (-11.940832 21.245174 -4.53122425 -20.610034 31.238666 24.359039 ) (-0.852723838 12.814661 26.707443 3.7490058 -21.005985 -28.13499 ) (15.351724 2.49617195 5.70145703 -24.385986 -13.214729 10.180927 ) (14.4458179 -16.79935 -7.51327229 -14.205059 1.86490535 11.411287 ) (7.8649988 -25.298767 -5.64836693 -2.79377174 -6.24489403 -19.826076 ) (-0.905814410 -38.005577 -11.8932609 -22.61985 -0.885330201 43.89302 ) (-13.241739 -38.678909 -12.778591 21.27317 27.786216 -23.746013 ) (-12.1272239 -29.27875 15.007625 -2.4728465 -8.259531 15.0910568 ) (-1.24936437 -24.206069 6.7480936 12.6182117 -6.7480936 -12.6182117 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 133Q) (FACE M R R) (WIDTH 210 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:51:16) (MADE-FROM NIL 147 130 0 0) (SPLINES ((2 ((183 294) (183 244)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (2 ((183 244) (133 244)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((133 244) (133 -32)) NIL ((0 -276. 0 0 0 0 )) NATURAL) (2 ((133 -32) (183 -32)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((183 -32) (183 -82)) NIL ((0 -50. 0 0 0 0 )) NATURAL) (2 ((183 -82) (49 -82)) NIL ((-134. 0 0 0 0 0 )) NATURAL) (2 ((49 -82) (49 294)) NIL ((0 376. 0 0 0 0 )) NATURAL) (2 ((49 294) (183 294)) NIL ((134. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 135Q) (FACE M R R) (WIDTH 208 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:52:23) (MADE-FROM NIL 159 130 0 0) (SPLINES ((2 ((157 -82) (23 -82)) NIL ((-134. 0 0 0 0 0 )) NATURAL) (2 ((23 -82) (23 -32)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((23 -32) (73 -32)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((73 -32) (73 244)) NIL ((0 276. 0 0 0 0 )) NATURAL) (2 ((73 244) (23 244)) NIL ((-50. 0 0 0 0 0 )) NATURAL) (2 ((23 244) (23 294)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((23 294) (157 294)) NIL ((134. 0 0 0 0 0 )) NATURAL) (3 ((157 294) (157 294) (157 -82)) NIL ((0 94. 0 0 0 -564. ) (0 -188. 0 -564. 0 564. )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 136Q) (FACE M R R) (WIDTH 223 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:53:31) (MADE-FROM NIL 118 130 0 0) (SPLINES ((2 ((142 15) (142 155)) NIL ((0 140. 0 0 0 0 )) NATURAL) (2 ((142 155) (192 155)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((192 155) (112 265)) NIL ((-80. 110. 0 0 0 0 )) NATURAL) (2 ((112 265) (32 155)) NIL ((-80. -110. 0 0 0 0 )) NATURAL) (2 ((32 155) (82 155)) NIL ((50. 0 0 0 0 0 )) NATURAL) (2 ((82 155) (82 15)) NIL ((0 -140. 0 0 0 0 )) NATURAL) (2 ((82 15) (142 15)) NIL ((60. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 137Q) (FACE M R R) (WIDTH 327 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:54:28) (MADE-FROM NIL 102 130 0 0) (SPLINES ((2 ((144 27) (144 77)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((144 77) (284 77)) NIL ((140. 0 0 0 0 0 )) NATURAL) (2 ((284 77) (284 137)) NIL ((0 60. 0 0 0 0 )) NATURAL) (2 ((284 137) (144 137)) NIL ((-140. 0 0 0 0 0 )) NATURAL) (2 ((144 137) (144 187)) NIL ((0 50. 0 0 0 0 )) NATURAL) (2 ((144 187) (34 107)) NIL ((-110. -80. 0 0 0 0 )) NATURAL) (2 ((34 107) (144 27)) NIL ((110. -80. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 174Q) (FACE M R R) (WIDTH 163 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:57:15) (MADE-FROM NIL 156 130 0 0) (SPLINES ((2 ((124 294) (40 294)) NIL ((-84. 0 0 0 0 0 )) NATURAL) (3 ((40 294) (40 294) (40 -82)) NIL ((0 94. 0 0 0 -564. ) (0 -188. 0 -564. 0 564. )) NATURAL) (2 ((40 -82) (124 -82)) NIL ((84. 0 0 0 0 0 )) NATURAL) (3 ((124 -82) (124 294) (124 294)) NIL ((0 470. 0 0 0 -564. ) (0 188. 0 -564. 0 564. )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 173Q) (FACE M R R) (WIDTH 237 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 16:58:29) (MADE-FROM NIL 126 130 0 0) (SPLINES ((2 ((197 294) (154 294)) NIL ((-43. 0 0 0 0 0 )) NATURAL) (6 ((154 294) (125 289) (105 279) (87 261) (75 236) (70 210)) NIL ((-31.34928 -4.10526276 0 0 14.095693 -5.3684206 ) (-24.301433 -6.78947354 14.095693 -5.3684206 -16.478466 -3.15789509 ) (-18.444973 -13.736841 -2.38277435 -8.5263157 9.81817819 1.90734863E-6 ) (-15.918659 -22.263156 7.43540478 -8.52631379 1.20574283 9.1578922 ) (-7.88038254 -26.210525 8.6411476 0.631578803 -8.6411476 -0.631578803 )) NATURAL) (2 ((70 210) (70 157)) NIL ((0 -53. 0 0 0 0 )) NATURAL) (5 ((70 157) (66 139) (55 127) (40 122) (25 122)) NIL ((-2.41071415 -19.196426 0 0 -9.5357132 7.17857075 ) (-7.1785717 -15.607141 -9.5357132 7.17857075 5.67857075 0.107143402 ) (-13.875 -8.3749981 -3.85714245 7.28571416 4.82142735 -1.6071434 ) (-15.321428 -1.89285683 0.964285732 5.67857075 -0.964285732 -5.67857075 )) NATURAL) (2 ((25 122) (25 96)) NIL ((0 -26. 0 0 0 0 )) NATURAL) (5 ((25 96) (40 96) (55 91) (66 79) (70 61)) NIL ((14.8392849 0.946428419 0 0 0.964285732 -5.67857075 ) (15.321428 -1.89285731 0.964285732 -5.67857075 -4.8214283 -1.6071434 ) (13.874998 -8.375 -3.85714293 -7.28571416 -5.6785698 0.107143402 ) (7.17857075 -15.607141 -9.5357132 -7.17857075 9.5357132 7.17857075 )) NATURAL) (2 ((70 61) (70 8)) NIL ((0 -53. 0 0 0 0 )) NATURAL) (6 ((70 8) (75 -18) (87 -43) (105 -61) (125 -71) (154 -76)) NIL ((3.55980873 -25.894733 0 0 8.6411476 -0.631578923 ) (7.88038254 -26.210525 8.6411476 -0.631578923 -1.20574188 9.15789414 ) (15.918659 -22.263156 7.43540574 8.5263157 -9.81818009 -1.90734863E-6 ) (18.444973 -13.736841 -2.38277483 8.52631379 16.478466 -3.15789318 ) (24.301433 -6.78947354 14.095693 5.3684206 -14.095693 -5.3684206 )) NATURAL) (2 ((154 -76) (197 -76)) NIL ((43. 0 0 0 0 0 )) NATURAL) (2 ((197 -76) (197 -51)) NIL ((0 25. 0 0 0 0 )) NATURAL) (7 ((197 -51) (183 -50) (171 -47) (164 -41) (158 -30) (156 -18) (154 -6)) NIL ((-14.17564 0.588461519 0 0 1.05384636 2.46923065 ) (-13.6487179 1.82307696 1.05384636 2.46923065 6.7307682 -0.346154213 ) (-9.22948648 4.11923027 7.78461457 2.12307644 -9.97692109 4.91538525 ) (-6.4333334 8.69999887 -2.19230747 7.03846169 9.17692185 -7.31538487 ) (-4.037179 12.0807686 6.98461533 -0.276923179 -8.7307682 0.346153974 ) (-1.41794872 11.976923 -1.74615383 0.0692307949 1.74615383 -0.0692307949 )) NATURAL) (2 ((154 -6) (154 57)) NIL ((0 63. 0 0 0 0 )) NATURAL) (5 ((154 57) (151 73) (143 89) (131 100) (114 109)) NIL ((-1.85714292 15.6785698 0 0 -6.85714245 1.92857122 ) (-5.28571415 16.642856 -6.85714245 1.92857122 4.28571415 -9.6428547 ) (-10. 13.749998 -2.5714283 -7.7142849 -4.28571415 6.64285565 ) (-14.7142849 9.3571415 -6.85714245 -1.07142853 6.85714245 1.07142853 )) NATURAL) (5 ((114 109) (131 118) (143 129) (151 145) (154 161)) NIL ((18.142856 8.8214283 0 0 -6.85714245 1.07142877 ) (14.7142849 9.3571415 -6.85714245 1.07142877 4.28571415 6.64285565 ) (9.9999981 13.75 -2.5714283 7.7142849 -4.28571415 -9.6428547 ) (5.28571415 16.642856 -6.85714245 -1.92857146 6.85714245 1.92857146 )) NATURAL) (2 ((154 161) (154 224)) NIL ((0 63. 0 0 0 0 )) NATURAL) (7 ((154 224) (156 236) (158 248) (164 259) (171 265) (183 268) (197 269)) NIL ((2.29102564 12.011537 0 0 -1.74615383 -0.0692307055 ) (1.41794872 11.976923 -1.74615383 -0.0692307055 8.7307682 0.346153498 ) (4.037179 12.0807686 6.98461533 0.276922822 -9.17692185 -7.31538296 ) (6.4333334 8.69999887 -2.19230747 -7.03846074 9.97692109 4.91538334 ) (9.22948648 4.11923027 7.78461457 -2.12307691 -6.7307682 -0.346153259 ) (13.6487179 1.82307672 1.05384612 -2.46923017 -1.05384612 2.46923017 )) NATURAL) (2 ((197 269) (197 294)) NIL ((0 25. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 175Q) (FACE M R R) (WIDTH 237 0) (FIDUCIAL 385 385) (VERSION 0 3-OCT-77 17:00:08) (MADE-FROM NIL 147 130 0 0) (SPLINES ((2 ((42 294) (85 294)) NIL ((43. 0 0 0 0 0 )) NATURAL) (6 ((85 294) (114 289) (134 279) (152 261) (164 236) (169 210)) NIL ((31.34928 -4.10526276 0 0 -14.095693 -5.3684206 ) (24.301433 -6.78947354 -14.095693 -5.3684206 16.478466 -3.15789509 ) (18.444973 -13.736841 2.38277435 -8.5263157 -9.81817819 1.90734863E-6 ) (15.918659 -22.263156 -7.43540478 -8.52631379 -1.20574283 9.1578922 ) (7.88038254 -26.210525 -8.6411476 0.631578803 8.6411476 -0.631578803 )) NATURAL) (2 ((169 210) (169 157)) NIL ((0 -53. 0 0 0 0 )) NATURAL) (5 ((169 157) (173 139) (184 127) (199 122) (214 122)) NIL ((2.41071415 -19.196426 0 0 9.5357132 7.17857075 ) (7.1785717 -15.607141 9.5357132 7.17857075 -5.67857075 0.107143402 ) (13.875 -8.3749981 3.85714245 7.28571416 -4.82142735 -1.6071434 ) (15.321428 -1.89285683 -0.964285732 5.67857075 0.964285732 -5.67857075 )) NATURAL) (2 ((214 122) (214 96)) NIL ((0 -26. 0 0 0 0 )) NATURAL) (5 ((214 96) (199 96) (184 91) (173 79) (169 61)) NIL ((-14.8392849 0.946428419 0 0 -0.964285732 -5.67857075 ) (-15.321428 -1.89285731 -0.964285732 -5.67857075 4.8214283 -1.6071434 ) (-13.874998 -8.375 3.85714293 -7.28571416 5.6785698 0.107143402 ) (-7.17857075 -15.607141 9.5357132 -7.17857075 -9.5357132 7.17857075 )) NATURAL) (2 ((169 61) (169 8)) NIL ((0 -53. 0 0 0 0 )) NATURAL) (6 ((169 8) (164 -18) (152 -43) (134 -61) (114 -71) (85 -76)) NIL ((-3.55980873 -25.894733 0 0 -8.6411476 -0.631578923 ) (-7.88038254 -26.210525 -8.6411476 -0.631578923 1.20574188 9.15789414 ) (-15.918659 -22.263156 -7.43540574 8.5263157 9.81818009 -1.90734863E-6 ) (-18.444973 -13.736841 2.38277483 8.52631379 -16.478466 -3.15789318 ) (-24.301433 -6.78947354 -14.095693 5.3684206 14.095693 -5.3684206 )) NATURAL) (2 ((85 -76) (42 -76)) NIL ((-43. 0 0 0 0 0 )) NATURAL) (2 ((42 -76) (42 -51)) NIL ((0 25. 0 0 0 0 )) NATURAL) (7 ((42 -51) (56 -50) (68 -47) (75 -41) (81 -30) (83 -18) (85 -6)) NIL ((14.17564 0.588461519 0 0 -1.05384636 2.46923065 ) (13.6487179 1.82307696 -1.05384636 2.46923065 -6.7307682 -0.346154213 ) (9.22948648 4.11923027 -7.78461457 2.12307644 9.97692109 4.91538525 ) (6.4333334 8.69999887 2.19230747 7.03846169 -9.17692185 -7.31538487 ) (4.037179 12.0807686 -6.98461533 -0.276923179 8.7307682 0.346153974 ) (1.41794872 11.976923 1.74615383 0.0692307949 -1.74615383 -0.0692307949 )) NATURAL) (2 ((85 -6) (85 57)) NIL ((0 63. 0 0 0 0 )) NATURAL) (5 ((85 57) (88 73) (96 89) (108 100) (125 109)) NIL ((1.85714292 15.6785698 0 0 6.85714245 1.92857122 ) (5.28571415 16.642856 6.85714245 1.92857122 -4.28571415 -9.6428547 ) (10. 13.749998 2.5714283 -7.7142849 4.28571415 6.64285565 ) (14.7142849 9.3571415 6.85714245 -1.07142853 -6.85714245 1.07142853 )) NATURAL) (5 ((125 109) (108 118) (96 129) (88 145) (85 161)) NIL ((-18.142856 8.8214283 0 0 6.85714245 1.07142877 ) (-14.7142849 9.3571415 6.85714245 1.07142877 -4.28571415 6.64285565 ) (-9.9999981 13.75 2.5714283 7.7142849 4.28571415 -9.6428547 ) (-5.28571415 16.642856 6.85714245 -1.92857146 -6.85714245 1.92857146 )) NATURAL) (2 ((85 161) (85 224)) NIL ((0 63. 0 0 0 0 )) NATURAL) (7 ((85 224) (83 236) (81 248) (75 259) (68 265) (56 268) (42 269)) NIL ((-2.29102564 12.011537 0 0 1.74615383 -0.0692307055 ) (-1.41794872 11.976923 1.74615383 -0.0692307055 -8.7307682 0.346153498 ) (-4.037179 12.0807686 -6.98461533 0.276922822 9.17692185 -7.31538296 ) (-6.4333334 8.69999887 2.19230747 -7.03846074 -9.97692109 4.91538334 ) (-9.22948648 4.11923027 -7.78461457 -2.12307691 6.7307682 -0.346153259 ) (-13.6487179 1.82307672 -1.05384612 -2.46923017 1.05384612 2.46923017 )) NATURAL) (2 ((42 269) (42 294)) NIL ((0 25. 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/lispusers/splinefonts/TIMESROMAN.UC1-SF b/obsolete/lispusers/splinefonts/TIMESROMAN.UC1-SF deleted file mode 100644 index e2745a27..00000000 --- a/obsolete/lispusers/splinefonts/TIMESROMAN.UC1-SF +++ /dev/null @@ -1 +0,0 @@ - ((FAMILY TIMESROMAND) (CHARACTER 101Q) (FACE M R R) (WIDTH 344 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:54:14) (MADE-FROM NIL 89 130 69 77) (SPLINES ((2 ((191 0) (332 0)) NIL ((141. 0 0 0 0 0 )) NATURAL) (2 ((332 0) (332 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (3 ((332 10) (320 19) (313 29)) NIL ((-13.25 8.75 0 0 7.5 1.5 ) (-9.5 9.5 7.5 1.5 -7.5 -1.5 )) NATURAL) (2 ((313 29) (180 294)) NIL ((-133. 265. 0 0 0 0 )) NATURAL) (2 ((180 294) (146 294)) NIL ((-34. 0 0 0 0 0 )) NATURAL) (2 ((146 294) (50 54)) NIL ((-96. -240. 0 0 0 0 )) NATURAL) (4 ((50 54) (40 33) (28 18) (11 10)) NIL ((-9.79999925 -22.133331 0 0 -1.20000004 6.8000002 ) (-10.3999996 -18.733329 -1.20000004 6.8000002 -5.99999905 1.99999904 ) (-14.599998 -10.933332 -7.1999998 8.79999925 7.1999998 -8.79999925 )) NATURAL) (2 ((11 10) (11 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((11 0) (116 0)) NIL ((105. 0 0 0 0 0 )) NATURAL) (2 ((116 0) (116 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (7 ((116 10) (104 13) (89 19) (78 35) (80 58) (84 74) (91 96)) NIL ((-11.152563 2.73589706 0 0 -5.08461476 1.58461571 ) (-13.6948719 3.52820492 -5.08461476 1.58461571 7.42307664 10.076921 ) (-15.067947 10.151281 2.33846187 11.661537 17.392303 0.107692718 ) (-4.03333187 21.866664 19.730766 11.7692299 -22.992301 -28.50769 ) (4.20128155 19.382049 -3.26153803 -16.73846 8.57692147 29.923076 ) (5.22820473 17.605125 5.3153839 13.184616 -5.3153839 -13.184616 )) NATURAL) (3 ((91 96) (177 96) (177 96)) NIL ((107.5 0 0 0 -129. 0 ) (43. 0 -129. 0 129. 0 )) NATURAL) (2 ((177 96) (200 44)) NIL ((23. -52. 0 0 0 0 )) NATURAL) (4 ((200 44) (208 26) (202 13) (191 10)) NIL ((11.3999996 -18.666664 0 0 -20.399997 4. ) (1.19999909 -16.666664 -20.399997 4. 17.999996 10. ) (-10.1999988 -7.66666604 -2.39999962 14. 2.39999962 -14. )) NATURAL) (2 ((191 10) (191 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL)) ((2 ((97 113) (169 113)) NIL ((72. 0 0 0 0 0 )) NATURAL) (2 ((169 113) (129 195)) NIL ((-40. 82. 0 0 0 0 )) NATURAL) (2 ((129 195) (97 113)) NIL ((-32. -82. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 102Q) (FACE M R R) (WIDTH 340 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:56:46) (MADE-FROM NIL 91 130 82 78) (SPLINES ((2 ((16 0) (16 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((16 10) (27 11) (40 16) (46 27) (47 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((47 39) (47 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((47 255) (46 267) (40 278) (27 283) (16 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((16 284) (16 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((16 294) (191 294)) NIL ((175. 0 0 0 0 0 )) NATURAL) (10 ((191 294) (232 292) (264 284) (287 269) (304 246) (308 215) (297 189) (276 172) (246 160) (204 154)) NIL ((42.83139 -0.786138774 0 0 -10.988382 -7.28316689 ) (37.337204 -4.42772198 -10.988382 -7.28316689 0.941915513 0.415834427 ) (26.819778 -11.5029716 -10.0464668 -6.86733246 7.22071839 -0.380169869 ) (20.38367 -18.560386 -2.82574797 -7.24750233 -11.824789 -4.895154 ) (11.6455288 -28.255466 -14.650537 -12.142656 -1.92156791 19.960781 ) (-3.96579123 -30.417732 -16.572105 7.81812764 7.51106454 3.05201626 ) (-16.7823639 -21.073596 -9.06104089 10.8701439 1.87731838 -8.16884805 ) (-24.904747 -14.287876 -7.1837225 2.7012949 -9.02034379 5.6233797 ) (-36.59864 -8.7748909 -16.204067 8.3246746 16.204067 -8.3246746 )) NATURAL) (11 ((204 154) (236 149) (271 141) (299 127) (317 103) (324 73) (316 40) (295 19) (266 6) (243 2) (225 0)) NIL ((30.846077 -4.45746613 0 0 6.92353726 -3.25520086 ) (34.307838 -6.0850668 6.92353726 -3.25520086 -16.617683 -1.72399473 ) (32.922538 -10.2022647 -9.694149 -4.9791956 -0.452787399 -7.84881879 ) (23.001995 -19.105869 -10.146936 -12.828014 0.428838730 9.11927224 ) (13.069475 -27.374248 -9.7180977 -3.70874214 -7.2625656 -4.628273 ) (-0.279904365 -33.397125 -16.980663 -8.33701516 4.62141609 27.393817 ) (-14.949859 -28.037231 -12.359247 19.056804 0.776903153 -14.947021 ) (-26.920654 -16.453933 -11.582344 4.10978318 22.270965 8.39427377 ) (-27.367511 -8.1470165 10.688623 12.5040569 -5.86077976 -12.6300697 ) (-19.609279 -1.95799517 4.82784367 -0.126014232 -4.82784367 0.126014232 )) NATURAL) (2 ((225 0) (16 0)) NIL ((-209. 0 0 0 0 0 )) NATURAL)) ((3 ((147 161) (147 161) (147 278)) NIL ((0 -29.25 0 0 0 175.5 ) (0 58.5 0 175.5 0 -175.5 )) NATURAL) (9 ((147 278) (165 278) (186 272) (204 256) (214 230) (213 202) (200 175) (172 161) (147 161)) NIL ((17.0887298 1.07391381 0 0 5.4675989 -6.44348336 ) (19.822532 -2.14782762 5.4675989 -6.44348336 -9.3379955 -3.78258324 ) (20.621131 -10.482603 -3.87039757 -10.2260666 -4.11561108 -2.42617798 ) (14.69293 -21.921756 -7.98600865 -12.652244 -4.1995573 13.487295 ) (4.60714245 -27.830356 -12.1855659 0.835051299 2.91384315 -3.5230112 ) (-6.12150193 -28.756809 -9.2717228 -2.68796015 -13.455816 18.604747 ) (-22.121131 -22.142395 -22.727539 15.916788 32.909423 1.10401344 ) (-28.393959 -5.6736002 10.1818847 17.020801 -10.1818847 -17.020801 )) NATURAL)) ((2 ((147 144) (147 36)) NIL ((0 -108. 0 0 0 0 )) NATURAL) (13 ((147 36) (150 25) (161 16) (181 15) (199 22) (214 38) (221 57) (221 83) (215 111) (200 131) (184 141) (166 145) (147 144)) NIL ((1.53440761 -11.070934 0 0 8.7935543 0.425616741 ) (5.93118477 -10.8581276 8.7935543 0.425616741 4.03222656 9.8719158 ) (16.740852 -5.4965515 12.8257808 10.297533 -18.922458 -3.91328716 ) (20.1054 2.84433746 -6.09667969 6.38424588 5.65762043 5.7812376 ) (16.837532 12.1192016 -0.439059258 12.165483 -9.70802117 -13.211664 ) (11.544462 17.678852 -10.147081 -1.04618191 3.17446899 11.0654239 ) (2.98461485 22.165382 -6.97261239 10.019243 3.01014614 -7.0500412 ) (-2.48292446 28.659606 -3.96246624 2.96920204 -9.21505357 -12.865255 ) (-11.052917 25.196178 -13.1775207 -9.8960533 15.8500709 -1.48893165 ) (-16.3054008 14.555662 2.6725502 -11.3849849 -6.18523026 6.82098199 ) (-16.725467 6.5811672 -3.51268005 -4.56400299 2.89085007 -1.79499531 ) (-18.79272 1.1196661 -0.621829868 -6.3589983 0.621829868 6.3589983 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 103Q) (FACE M R R) (WIDTH 317 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:57:54) (MADE-FROM NIL 87 130 80 88) (SPLINES ((21 ((295 206) (283 206) (278 217) (269 237) (252 257) (231 271) (203 277) (168 268) (147 247) (135 223) (127 194) (124 157) (127 121) (135 86) (151 54) (176 34) (209 25) (243 31) (271 48) (286 63) (299 51)) NIL ((-14.023639 -2.3255701 0 0 12.1418419 13.95342 ) (-7.95271874 4.65114117 12.1418419 13.95342 -18.709209 -3.76710892 ) (-5.16548252 16.721004 -6.56736756 10.1863117 -3.30500221 -10.884983 ) (-13.385351 21.464824 -9.87236978 -0.698672533 7.92921925 -6.6929493 ) (-19.293109 17.419677 -1.94315004 -7.39162255 -4.41187954 1.65678596 ) (-23.442199 10.856449 -6.35503007 -5.73483658 -8.28169824 -11.9341926 ) (-33.938079 -0.845483781 -14.636728 -17.669029 37.538665 4.07999039 ) (-29.805473 -16.474514 22.901939 -13.5890388 -15.872972 13.614221 ) (-14.840019 -23.256443 7.02896596 0.0251838676 -4.0467739 -4.53687954 ) (-9.8344402 -25.499698 2.98219156 -4.51169586 2.06007337 -7.4667034 ) (-5.82221318 -33.744743 5.04226494 -11.978399 1.80648422 16.403694 ) (0.123294025 -37.521293 6.84874917 4.42529679 -3.2860117 -4.14808369 ) (5.3290367 -35.170044 3.56273747 0.277212322 5.3375635 0.188641011 ) (11.560556 -34.798507 8.90030099 0.465853334 -0.0642452240 15.393518 ) (20.428733 -26.635898 8.83605577 15.859373 0.919410706 -7.7627182 ) (29.724494 -14.657884 9.75546647 8.0966549 -9.61338998 9.65735055 ) (34.673263 -1.73255491 0.142075598 17.754005 -4.4658451 -6.86668587 ) (32.58242 12.588106 -4.32376957 10.8873195 -14.5232219 -6.1906042 ) (20.997036 20.380123 -18.846992 4.69671536 20.558738 -46.370887 ) (12.4294166 1.89139294 1.71174884 -41.674179 -1.71174884 41.674179 )) NATURAL) (26 ((299 51) (277 28) (249 10) (218 -1) (180 -5) (144 -2) (111 8) (82 23) (59 43) (39 69) (27 94) (20 123) (17 154) (21 184) (34 217) (52 244) (76 267) (104 284) (136 295) (172 300) (212 298) (241 293) (262 288) (280 285) (286 294) (296 294)) NIL ((-20.465946 -23.943889 0 0 -9.20431329 5.6633482 ) (-25.068103 -21.112216 -9.20431329 5.6633482 10.021566 1.68325901 ) (-29.26163 -14.6072387 0.817253590 7.3466072 -12.881954 -0.396385193 ) (-34.885353 -7.4588232 -12.064701 6.950222 17.506252 -0.0977230073 ) (-38.196929 -0.557461977 5.44155407 6.852499 -3.14307118 0.787275315 ) (-34.326911 6.68867398 2.29848289 7.6397743 1.06602907 -3.05137062 ) (-31.495414 12.802763 3.36451197 4.5884037 4.8789568 -0.581792832 ) (-25.691421 17.100269 8.24346925 4.00661087 -8.5818615 5.37854195 ) (-21.738884 23.79615 -0.338392854 9.3851528 11.448492 -14.9323749 ) (-16.353031 25.715114 11.1100998 -5.54722309 -7.21210194 12.3509617 ) (-8.84898377 26.343372 3.89799738 6.80373955 -0.600089073 -4.4714737 ) (-5.25102997 30.911376 3.2979083 2.33226585 3.61245775 -6.4650688 ) (-0.146893501 30.011108 6.91036606 -4.13280297 4.15026284 12.3317489 ) (8.83860398 32.044181 11.0606289 8.198946 -8.2135105 -18.861927 ) (15.792476 30.81216 2.84711695 -10.6629829 4.70378399 9.1159687 ) (20.991485 24.707164 7.5509014 -1.54701376 -4.60162544 -5.60194683 ) (26.241573 20.359176 2.94927549 -7.14896107 1.70271826 1.29182338 ) (30.042209 13.8561248 4.65199375 -5.85713768 -2.2092433 0.434653282 ) (33.589576 8.2163143 2.44275045 -5.4224844 7.13425065 -3.03043842 ) (39.599456 1.27861070 9.57700158 -8.4529228 -26.327758 5.68710327 ) (36.012573 -4.33076 -16.750759 -2.76581907 8.17679978 4.28201866 ) (23.350219 -4.95556927 -8.57395936 1.5162003 11.6205539 -4.81518173 ) (20.586536 -5.84696007 3.04659605 -3.29898214 -24.659015 26.978706 ) (11.303623 4.3434124 -21.612422 23.679725 33.015525 -43.099655 ) (6.19896508 6.4733095 11.4031047 -19.419929 -11.4031047 19.419929 )) NATURAL) (2 ((296 294) (295 206)) NIL ((-1. -88. 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 104Q) (FACE M R R) (WIDTH 356 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 15:59:49) (MADE-FROM NIL 93 130 82 78) (SPLINES ((2 ((181 0) (14 0)) NIL ((-167. 0 0 0 0 0 )) NATURAL) (2 ((14 0) (14 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((14 10) (25 11) (38 16) (44 27) (45 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((45 255) (44 267) (38 278) (25 283) (14 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((14 284) (14 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((14 294) (181 294)) NIL ((167. 0 0 0 0 0 )) NATURAL) (19 ((181 294) (210 292) (236 288) (260 281) (284 269) (303 254) (321 234) (333 211) (342 176) (343 147) (342 118) (333 83) (321 60) (303 40) (284 25) (260 13) (236 6) (210 2) (181 0)) NIL ((29.633724 -1.5916388 0 0 -3.80235243 -2.45016622 ) (27.732547 -2.81672191 -3.80235243 -2.45016622 1.01176214 0.250832081 ) (24.436077 -5.14147187 -2.79059028 -2.19933414 5.75530434 -4.55316258 ) (24.523136 -9.61738778 2.96471405 -6.7524967 -12.0329799 5.9618187 ) (21.471363 -13.388975 -9.0682659 -0.790677190 12.3766117 -7.29411507 ) (18.5914039 -17.826709 3.30834723 -8.0847931 -13.4734687 11.214649 ) (15.163015 -20.30418 -10.1651229 3.1298561 11.517271 -25.564483 ) (10.7565269 -29.956565 1.35214877 -22.434627 -14.595617 37.04328 ) (4.81086636 -33.869545 -13.243469 14.6086578 16.8652038 -14.6086578 ) (-1.59256160E-7 -26.565223 3.6217351 -5.11072471E-7 -16.8652038 -14.608654 ) (-4.81086827 -33.869545 -13.243469 -14.6086559 14.595617 37.043273 ) (-10.7565288 -29.956562 1.35214853 22.434623 -11.517271 -25.564476 ) (-15.163015 -20.30418 -10.1651229 -3.12985516 13.4734687 11.214647 ) (-18.5914039 -17.826709 3.30834723 8.0847931 -12.3766098 -7.294116 ) (-21.471363 -13.388973 -9.068264 0.790676714 12.032978 5.96181965 ) (-24.523136 -9.61738778 2.96471405 6.7524967 -5.75530434 -4.55316258 ) (-24.436077 -5.14147187 -2.79059028 2.19933367 -1.01176166 0.250832558 ) (-27.732547 -2.81672191 -3.80235195 2.45016622 3.80235195 -2.45016622 )) NATURAL)) ((2 ((145 272) (145 272)) NIL ((0 0 0 0 0 0 )) NATURAL)) ((2 ((145 272) (145 36)) NIL ((0 -236. 0 0 0 0 )) NATURAL) (19 ((145 36) (147 28) (157 18) (182 16) (204 25) (221 41) (234 63) (242 90) (245 119) (246 147) (244 172) (240 198) (232 229) (218 253) (203 268) (184 277) (164 281) (148 280) (145 272)) NIL ((0.969433427 -7.07190228 0 0 6.1833992 -5.56858444 ) (4.06113243 -9.85619355 6.1833992 -5.56858444 17.083004 15.842924 ) (18.786033 -7.50331689 23.266403 10.2743396 -32.515426 2.19688225 ) (25.794723 3.8694644 -9.24902535 12.4712219 4.97872639 -6.63045407 ) (19.03506 13.025459 -4.27029896 5.84076786 0.600520611 0.324934006 ) (15.065023 19.028694 -3.66977835 6.16570187 -1.38080835 -0.669278145 ) (10.7048397 24.859756 -5.0505867 5.49642372 -1.07728576 -3.64782 ) (5.11561108 28.532268 -6.12787247 1.84860348 5.68994999 -2.73944139 ) (1.8327136 29.011154 -0.437921703 -0.890838028 -3.68251753 -3.39441252 ) (-0.446466982 26.423107 -4.12043953 -4.28525067 3.0401206 4.31709099 ) (-3.04684639 24.296402 -1.08031892 0.0318403318 -2.4779644 10.126047 ) (-5.36614704 29.391269 -3.55828333 10.157888 -5.12826252 -20.821285 ) (-11.4885616 29.138511 -8.6865463 -10.6633968 10.991018 1.15910148 ) (-14.6795997 19.054668 2.30447245 -9.50429536 -8.8358135 4.18487263 ) (-16.793033 11.6428089 -6.53134156 -5.31942272 6.3522358 0.101410865 ) (-20.148258 6.3740921 -0.179104834 -5.21801186 1.42686581 1.409482 ) (-19.613929 1.86082101 1.24776101 -3.80852985 17.940292 -5.73933697 ) (-9.39601899 -4.81737709 19.1880569 -9.5478668 -19.1880569 9.5478668 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 105Q) (FACE M R R) (WIDTH 302 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:01:30) (MADE-FROM NIL 93 130 82 78) (SPLINES ((2 ((14 0) (14 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((14 10) (25 11) (38 16) (44 27) (45 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((45 255) (44 267) (38 278) (25 283) (14 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((14 284) (14 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((14 294) (257 294)) NIL ((243. 0 0 0 0 0 )) NATURAL) (2 ((257 294) (261 218)) NIL ((4. -76. 0 0 0 0 )) NATURAL) (2 ((261 218) (248 218)) NIL ((-13. 0 0 0 0 0 )) NATURAL) (9 ((248 218) (243 227) (237 242) (223 262) (206 274) (186 279) (164 281) (147 280) (145 272)) NIL ((-5.26095295 7.87279034 0 0 1.56572151 6.7632551 ) (-4.4780922 11.254417 1.56572151 6.7632551 -13.828607 2.1837244 ) (-9.8266754 19.109535 -12.262886 8.9469795 11.7487106 -21.498157 ) (-16.215206 17.307434 -0.514174938 -12.551178 -3.16623783 5.8089094 ) (-18.3125 7.66071416 -3.68041277 -6.74226857 0.916238309 4.26251889 ) (-21.534793 3.04970503 -2.76417446 -2.4797492 5.5012865 1.14101576 ) (-21.54832 1.14046359 2.73711204 -1.33873343 19.078605 -8.82658196 ) (-9.2719059 -4.61156082 21.815719 -10.1653156 -21.815719 10.1653156 )) NATURAL) (2 ((145 272) (145 158)) NIL ((0 -114. 0 0 0 0 )) NATURAL) (5 ((145 158) (163 162) (177 174) (186 191) (190 215)) NIL ((18.803569 2.08928585 0 0 -4.8214283 11.4642849 ) (16.392856 7.8214283 -4.8214283 11.4642849 0.107143402 -9.3214264 ) (11.624998 14.625 -4.7142849 2.14285707 -1.6071434 7.82142735 ) (6.10714245 20.678569 -6.3214283 9.9642849 6.3214283 -9.9642849 )) NATURAL) (2 ((190 215) (204 215)) NIL ((14. 0 0 0 0 0 )) NATURAL) (2 ((204 215) (204 89)) NIL ((0 -126. 0 0 0 0 )) NATURAL) (2 ((204 89) (190 89)) NIL ((-14. 0 0 0 0 0 )) NATURAL) (5 ((190 89) (186 109) (177 126) (163 138) (145 142)) NIL ((-2.9464283 20.589283 0 0 -6.3214283 -3.53571415 ) (-6.10714245 18.821426 -6.3214283 -3.53571415 1.6071434 -0.321428776 ) (-11.625 15.124998 -4.7142849 -3.85714293 -0.107143402 -7.1785698 ) (-16.392856 7.67857075 -4.8214283 -11.035713 4.8214283 11.035713 )) NATURAL) (2 ((145 142) (145 36)) NIL ((0 -106. 0 0 0 0 )) NATURAL) (9 ((145 36) (147 30) (156 20) (181 18) (211 21) (233 32) (250 47) (262 64) (271 84)) NIL ((1.14101600 -4.4138441 0 0 5.153903 -9.51693536 ) (3.7179675 -9.17231179 5.153903 -9.51693536 16.230484 23.584678 ) (16.98711 -6.8969059 21.384387 14.067745 -16.0758438 -12.821794 ) (30.333576 0.759941102 5.3085413 1.24594950 -17.927093 9.7025032 ) (26.678569 6.85714245 -12.618555 10.9484539 9.7842388 -7.9882183 ) (18.952133 13.811487 -2.8343153 2.96023512 -3.20986652 -1.7496314 ) (14.512886 15.8969059 -6.04418183 1.21060371 3.05522776 2.98674488 ) (9.9963169 18.600883 -2.98895407 4.1973486 2.98895407 -4.1973486 )) NATURAL) (2 ((271 84) (286 80)) NIL ((15. -4. 0 0 0 0 )) NATURAL) (2 ((286 80) (266 0)) NIL ((-20. -80. 0 0 0 0 )) NATURAL) (2 ((266 0) (14 0)) NIL ((-252. 0 0 0 0 0 )) NATURAL)) ((2 ((145 272) (145 272)) NIL ((0 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 106Q) (FACE M R R) (WIDTH 274 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:03:04) (MADE-FROM NIL 93 130 82 78) (SPLINES ((2 ((14 0) (14 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((14 10) (25 11) (38 16) (44 27) (45 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((45 255) (44 267) (38 278) (25 283) (14 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((14 284) (14 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((14 294) (257 294)) NIL ((243. 0 0 0 0 0 )) NATURAL) (2 ((257 294) (261 228)) NIL ((4. -66. 0 0 0 0 )) NATURAL) (2 ((261 228) (245 228)) NIL ((-16. 0 0 0 0 0 )) NATURAL) (5 ((245 228) (237 248) (220 266) (199 277) (173 280)) NIL ((-5.78571415 20.178569 0 0 -13.285713 -1.07142877 ) (-12.4285717 19.642856 -13.285713 -1.07142877 12.4285698 -6.64285565 ) (-19.5 15.249998 -0.857143045 -7.7142849 -6.4285698 -2.3571434 ) (-23.571426 6.35714245 -7.2857132 -10.071428 7.2857132 10.071428 )) NATURAL) (2 ((173 280) (145 280)) NIL ((-28. 0 0 0 0 0 )) NATURAL) (2 ((145 280) (145 162)) NIL ((0 -118. 0 0 0 0 )) NATURAL) (5 ((145 162) (165 164) (180 171) (191 185) (196 214)) NIL ((21.160713 0.892857195 0 0 -6.9642849 6.6428566 ) (17.678569 4.2142849 -6.9642849 6.6428566 4.82142735 -3.21428442 ) (13.124998 9.25 -2.14285707 3.42857218 -6.32142735 18.214279 ) (7.8214283 21.785713 -8.4642849 21.642852 8.4642849 -21.642852 )) NATURAL) (2 ((196 214) (210 214)) NIL ((14. 0 0 0 0 0 )) NATURAL) (2 ((210 214) (210 89)) NIL ((0 -125. 0 0 0 0 )) NATURAL) (2 ((210 89) (196 89)) NIL ((-14. 0 0 0 0 0 )) NATURAL) (5 ((196 89) (191 118) (180 132) (165 139) (145 141)) NIL ((-3.58928585 32.607139 0 0 -8.4642849 -21.642856 ) (-7.8214283 21.785713 -8.4642849 -21.642856 6.32142735 18.214283 ) (-13.125 9.2499981 -2.14285707 -3.42857122 -4.8214283 -3.21428537 ) (-17.678569 4.2142849 -6.96428586 -6.6428566 6.96428586 6.6428566 )) NATURAL) (2 ((145 141) (145 39)) NIL ((0 -102. 0 0 0 0 )) NATURAL) (5 ((145 39) (146 27) (152 16) (165 11) (176 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((176 10) (176 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((176 0) (14 0)) NIL ((-162. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 107Q) (FACE M R R) (WIDTH 350 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:04:05) (MADE-FROM NIL 93 130 82 78) (SPLINES ((25 ((298 296) (289 284) (268 287) (236 296) (200 301) (166 300) (130 295) (98 284) (70 267) (46 244) (28 217) (17 188) (12 154) (14 123) (21 94) (32 68) (52 42) (76 23) (105 8) (138 -2) (174 -6) (214 -6) (253 -1) (289 9) (315 20)) NIL ((-6.48319245 -15.5386657 0 0 -15.100845 21.231998 ) (-14.033615 -4.92266464 -15.100845 21.231998 3.5042324 -16.160003 ) (-27.382343 8.22933007 -11.5966129 5.07199288 7.08391667 -10.5919685 ) (-35.436996 8.00533868 -4.51269627 -5.5199766 10.160097 -1.47210884 ) (-34.869644 1.74930858 5.64740086 -6.99208546 -11.724308 4.48040486 ) (-35.084396 -3.00257444 -6.07690716 -2.5116806 12.7371368 -4.44951058 ) (-34.792739 -7.7390108 6.66022969 -6.96119118 -3.22424364 1.3176403 ) (-29.744628 -14.0413818 3.43598604 -5.64355088 0.159837722 -0.821053506 ) (-26.228725 -20.095459 3.59582377 -6.46460438 2.58489275 1.96657467 ) (-21.340454 -25.576774 6.1807165 -4.4980297 1.50059128 4.95475292 ) (-14.4094429 -27.597427 7.6813078 0.456723809 -2.58725929 -9.7855873 ) (-8.02176477 -32.0335 5.0940485 -9.32886506 2.8484478 16.1876068 ) (-1.50349259 -33.268562 7.9424963 6.85874367 -2.80653286 -6.96485234 ) (5.03573704 -29.892242 5.13596344 -0.106108874 -3.62231398 5.67179966 ) (8.3605423 -27.162452 1.51364922 5.565691 11.2957878 -9.72234918 ) (15.522087 -26.457935 12.8094387 -4.15665818 -11.560844 15.2176017 ) (22.551101 -23.005794 1.24859380 11.0609436 4.94758892 -9.14805795 ) (26.27349 -16.5188789 6.1961832 1.91288566 -2.22951364 3.37462616 ) (31.354919 -12.91868 3.96666956 5.28751183 -2.02953386 1.64955234 ) (34.306823 -6.80639268 1.93713569 6.93706418 4.34765053 -3.97283316 ) (38.417778 -1.85574507 6.28478623 2.96423101 -9.3610668 2.2417779 ) (40.022033 2.22937488 -3.07628202 5.2060089 3.0966239 1.00572204 ) (38.494064 7.9382448 0.0203422196 6.21173096 -15.0254268 -6.2646637 ) (31.001693 11.0176429 -15.005085 -0.0529328808 15.005085 0.0529328808 )) NATURAL) (2 ((315 20) (315 89)) NIL ((0 69. 0 0 0 0 )) NATURAL) (5 ((315 89) (316 108) (324 117) (331 120) (339 123)) NIL ((-0.964285494 21.25 0 0 11.785713 -13.5 ) (4.9285717 14.499998 11.785713 -13.5 -16.928569 7.50000096 ) (8.2499981 4.74999905 -5.1428566 -5.99999905 7.92857075 7.4999981 ) (7.0714283 2.5 2.78571415 1.49999976 -2.78571415 -1.49999976 )) NATURAL) (2 ((339 123) (339 133)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((339 133) (187 133)) NIL ((-152. 0 0 0 0 0 )) NATURAL) (2 ((187 133) (187 123)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((187 123) (199 122) (210 115) (215 102) (217 90)) NIL ((11.8928566 0.160714298 0 0 0.642857075 -6.96428586 ) (12.2142849 -3.3214283 0.642857075 -6.96428586 -9.2142849 -1.17857074 ) (8.2499981 -10.875 -8.5714283 -8.1428566 6.21428586 11.6785698 ) (2.78571415 -13.1785698 -2.35714245 3.53571415 2.35714245 -3.53571415 )) NATURAL) (2 ((217 90) (217 19)) NIL ((0 -71. 0 0 0 0 )) NATURAL) (16 ((217 19) (200 11) (172 13) (146 28) (128 56) (120 97) (118 141) (121 181) (130 223) (145 253) (170 274) (206 279) (240 266) (266 245) (282 224) (295 196)) NIL ((-14.0182419 -9.93531228 0 0 -17.890541 11.611883 ) (-22.963512 -4.12937165 -17.890541 11.611883 23.452705 1.94058037 ) (-29.1277 8.45280076 5.56216717 13.552463 2.07970333 -1.37420463 ) (-22.52568 21.31816 7.6418705 12.1782589 4.22847367 3.55624008 ) (-12.769571 35.274536 11.870344 15.7344989 -6.9935951 -12.8507557 ) (-4.39602566 44.583663 4.87674904 2.88374233 -0.254091263 -12.1532116 ) (0.353678048 41.390792 4.62265778 -9.2694702 2.00995827 19.463611 ) (5.98131466 41.853134 6.63261605 10.194141 -1.78574085 -29.70124 ) (11.7210598 37.196655 4.84687519 -19.507099 5.1330061 15.341362 ) (19.134437 25.360233 9.9798813 -4.1657362 5.2537136 -13.664211 ) (31.741176 14.362392 15.2335949 -17.829948 -20.147857 -2.68451309 ) (36.90084 -4.8098135 -4.91426468 -20.514461 -2.66227054 12.402265 ) (30.65544 -19.123142 -7.5765352 -8.11219598 -5.20305348 13.075447 ) (20.477378 -20.697612 -12.7795887 4.96325207 11.474485 -16.704063 ) (13.4350338 -24.086395 -1.30510235 -11.740812 1.30510235 11.740812 )) NATURAL) (2 ((295 196) (310 196)) NIL ((15. 0 0 0 0 0 )) NATURAL) (2 ((310 196) (308 296)) NIL ((-2. 100. 0 0 0 0 )) NATURAL) (2 ((308 296) (298 296)) NIL ((-10. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 110Q) (FACE M R R) (WIDTH 398 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:09:07) (MADE-FROM NIL 86 130 82 78) (SPLINES ((2 ((15 0) (15 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((15 10) (26 11) (39 16) (45 27) (46 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((46 39) (46 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((46 255) (45 267) (39 278) (26 283) (15 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((15 284) (15 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((15 294) (177 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((177 294) (177 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((177 284) (166 283) (153 278) (147 267) (146 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((146 255) (146 161)) NIL ((0 -94. 0 0 0 0 )) NATURAL) (2 ((146 161) (247 161)) NIL ((101. 0 0 0 0 0 )) NATURAL) (2 ((247 161) (247 255)) NIL ((0 94. 0 0 0 0 )) NATURAL) (5 ((247 255) (246 267) (240 278) (227 283) (216 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((216 284) (216 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((216 294) (378 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((378 294) (378 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((378 284) (367 283) (354 278) (348 267) (347 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((347 255) (347 39)) NIL ((0 -216. 0 0 0 0 )) NATURAL) (5 ((347 39) (348 27) (354 16) (367 11) (378 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((378 10) (378 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((378 0) (216 0)) NIL ((-162. 0 0 0 0 0 )) NATURAL) (2 ((216 0) (216 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((216 10) (227 11) (240 16) (246 27) (247 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((247 39) (247 139)) NIL ((0 100. 0 0 0 0 )) NATURAL) (2 ((247 139) (146 139)) NIL ((-101. 0 0 0 0 0 )) NATURAL) (2 ((146 139) (146 39)) NIL ((0 -100. 0 0 0 0 )) NATURAL) (5 ((146 39) (147 27) (153 16) (166 11) (177 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((177 10) (177 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((177 0) (15 0)) NIL ((-162. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 111Q) (FACE M R R) (WIDTH 193 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:10:25) (MADE-FROM NIL 104 130 82 78) (SPLINES ((2 ((14 0) (14 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((14 10) (25 11) (38 16) (44 27) (45 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((45 255) (44 267) (38 278) (25 283) (14 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((14 284) (14 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((14 294) (176 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((176 294) (176 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((176 284) (165 283) (152 278) (146 267) (145 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((145 255) (144 39)) NIL ((-1. -216. 0 0 0 0 )) NATURAL) (5 ((144 39) (145 27) (151 16) (164 11) (175 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((175 10) (175 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((175 0) (14 0)) NIL ((-161. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 112Q) (FACE M R R) (WIDTH 271 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:11:38) (MADE-FROM NIL 115 130 82 78) (SPLINES ((2 ((124 59) (124 255)) NIL ((0 196. 0 0 0 0 )) NATURAL) (5 ((124 255) (123 267) (117 278) (104 283) (93 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((93 284) (93 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((93 294) (255 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((255 294) (255 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((255 284) (244 283) (231 278) (225 267) (224 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((224 255) (223 79)) NIL ((-1. -176. 0 0 0 0 )) NATURAL) (18 ((223 79) (217 45) (197 18) (164 1) (118 -5) (78 -3) (42 7) (21 25) (12 53) (26 81) (56 91) (86 81) (101 55) (92 33) (95 15) (111 16) (124 36) (124 59)) NIL ((-2.9017105 -35.337036 0 0 -18.5897369 8.0222225 ) (-12.1965789 -31.325923 -18.5897369 8.0222225 8.9486904 1.8888855 ) (-26.311969 -22.359256 -9.6410465 9.911108 -11.2050266 2.42223167 ) (-41.555526 -11.2370338 -20.846073 12.3333397 35.871421 -5.57781029 ) (-44.465889 -1.69259977 15.02535 6.7555294 -18.280677 1.88901138 ) (-38.580879 6.0074358 -3.25532723 8.6445408 25.251281 -1.97823906 ) (-29.210563 13.662857 21.995956 6.66630173 -16.724468 6.02394868 ) (-15.576843 23.341133 5.27148724 12.69025 23.646598 -10.1175556 ) (1.51794481 30.972602 28.918087 2.57269335 -11.8619308 -25.553714 ) (24.505065 20.768436 17.056156 -22.981021 -18.198871 4.3324356 ) (32.461784 -0.0463663712 -1.14271569 -18.648586 -11.342575 -3.77604294 ) (25.647781 -20.582973 -12.485292 -22.424629 -26.43082 34.771736 ) (-0.0529238358 -25.62173 -38.916114 12.3471107 63.065887 -15.310928 ) (-7.43609429 -20.930084 24.149772 -2.96381903 -9.8327484 26.47198 ) (11.797304 -10.657913 14.317024 23.508163 -17.734897 -0.577007294 ) (17.246875 12.5617447 -3.41787434 22.931156 -15.227651 -24.163944 ) (6.21517563 23.410926 -18.645526 -1.23278904 18.645526 1.23278904 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 113Q) (FACE M R R) (WIDTH 347 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:15:22) (MADE-FROM NIL 93 130 82 78) (SPLINES ((2 ((191 284) (191 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((191 294) (311 294)) NIL ((120. 0 0 0 0 0 )) NATURAL) (2 ((311 294) (311 286)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (4 ((311 286) (285 273) (255 248) (208 199)) NIL ((-26.066665 -11.3999996 0 0 0.399999619 -9.60000039 ) (-25.866664 -16.1999969 0.399999619 -9.60000039 -25.999996 -23.999996 ) (-38.466667 -37.799995 -25.599998 -33.599998 25.599998 33.599998 )) NATURAL) (4 ((208 199) (273 90) (311 30) (335 8)) NIL ((71.26666 -119.5333 0 0 -37.599998 63.199997 ) (52.466659 -87.933319 -37.599998 63.199997 26. -22. ) (27.866664 -35.733329 -11.599998 41.199996 11.599998 -41.199996 )) NATURAL) (2 ((335 8) (335 0)) NIL ((0 -8. 0 0 0 0 )) NATURAL) (2 ((335 0) (192 0)) NIL ((-143. 0 0 0 0 0 )) NATURAL) (2 ((192 0) (192 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (3 ((192 10) (204 17) (204 28)) NIL ((15. 6. 0 0 -18. 6. ) (6. 9. -18. 6. 18. -6. )) NATURAL) (2 ((204 28) (145 137)) NIL ((-59. 109. 0 0 0 0 )) NATURAL) (2 ((145 137) (145 39)) NIL ((0 -98. 0 0 0 0 )) NATURAL) (4 ((145 39) (146 27) (152 16) (162 10)) NIL ((-0.0666666031 -11.933332 0 0 6.3999996 -0.399999857 ) (3.1333332 -12.133333 6.3999996 -0.399999857 -2. 7.99999905 ) (8.5333328 -8.5333328 4.39999962 7.59999943 -4.39999962 -7.59999943 )) NATURAL) (2 ((162 10) (162 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((162 0) (24 0)) NIL ((-138. 0 0 0 0 0 )) NATURAL) (2 ((24 0) (24 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (4 ((24 10) (38 16) (44 27) (45 39)) NIL ((15.799999 4.73333264 0 0 -10.799999 7.59999943 ) (10.3999996 8.5333328 -10.799999 7.59999943 6. -7.99999905 ) (2.59999943 12.133333 -4.79999924 -0.399999976 4.79999924 0.399999976 )) NATURAL) (2 ((45 39) (45 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (4 ((45 255) (44 267) (38 278) (24 284)) NIL ((-0.199999958 11.933332 0 0 -4.80000019 0.399999857 ) (-2.5999999 12.133333 -4.80000019 0.399999857 -5.99999905 -7.99999905 ) (-10.3999996 8.5333328 -10.799999 -7.59999943 10.799999 7.59999943 )) NATURAL) (2 ((24 284) (24 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((24 294) (162 294)) NIL ((138. 0 0 0 0 0 )) NATURAL) (2 ((162 294) (162 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (4 ((162 284) (152 278) (146 267) (145 255)) NIL ((-10.7333316 -4.73333264 0 0 4.39999962 -7.59999943 ) (-8.5333328 -8.5333328 4.39999962 -7.59999943 2. 7.99999905 ) (-3.1333332 -12.133333 6.3999996 0.399999976 -6.3999996 -0.399999976 )) NATURAL) (2 ((145 255) (145 163)) NIL ((0 -92. 0 0 0 0 )) NATURAL) (7 ((145 163) (174 190) (205 222) (221 247) (222 268) (206 280) (191 284)) NIL ((27.587177 25.198715 0 0 8.476923 10.8076915 ) (31.825637 30.602561 8.476923 10.8076915 -30.384613 -24.038459 ) (25.110256 29.391021 -21.907691 -13.230768 11.0615387 13.346151 ) (8.73333169 22.833332 -10.846153 0.115384549 -13.8615379 -11.346151 ) (-9.04358865 17.275638 -24.70769 -11.230768 32.384613 2.03846168 ) (-17.558971 7.06410218 7.6769228 -9.1923065 -7.6769228 9.1923065 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 114Q) (FACE M R R) (WIDTH 277 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:18:16) (MADE-FROM NIL 125 130 82 78) (SPLINES ((2 ((12 0) (12 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((12 10) (23 11) (36 16) (42 27) (43 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((43 39) (43 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((43 255) (42 267) (36 278) (23 283) (12 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((12 284) (12 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((12 294) (174 294)) NIL ((162. 0 0 0 0 0 )) NATURAL) (2 ((174 294) (174 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((174 284) (163 283) (150 278) (144 267) (143 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((143 255) (143 39)) NIL ((0 -216. 0 0 0 0 )) NATURAL) (8 ((143 39) (145 29) (154 19) (184 19) (214 31) (235 51) (247 71) (256 101)) NIL ((1.59704542 -9.46822358 0 0 2.41772652 -3.1906557 ) (2.80590868 -11.0635509 2.41772652 -3.1906557 29.911365 15.953277 ) (20.179317 -6.2775669 32.329093 12.7626228 -38.063201 -0.622465134 ) (33.476806 6.17382336 -5.73411179 12.1401577 -3.658535 -1.46341705 ) (25.913429 17.582271 -9.3926468 10.6767406 -1.30264663 -17.523868 ) (15.869459 19.497077 -10.695293 -6.84713078 8.86911584 23.55891 ) (9.6087246 24.429405 -1.8261764 16.71178 1.8261764 -16.71178 )) NATURAL) (2 ((256 101) (269 98)) NIL ((13. -3. 0 0 0 0 )) NATURAL) (2 ((269 98) (256 0)) NIL ((-13. -98. 0 0 0 0 )) NATURAL) (2 ((256 0) (12 0)) NIL ((-244. 0 0 0 0 0 )) NATURAL)))) ((FAMILY TIMESROMAND) (CHARACTER 115Q) (FACE M R R) (WIDTH 452 0) (FIDUCIAL 385 385) (VERSION 0 30-SEP-77 16:20:58) (MADE-FROM NIL 35 130 82 78) (SPLINES ((2 ((12 0) (12 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((12 10) (23 11) (36 16) (42 27) (43 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((43 39) (43 255)) NIL ((0 216. 0 0 0 0 )) NATURAL) (5 ((43 255) (42 267) (36 278) (23 283) (12 284)) NIL ((-0.196428597 11.910713 0 0 -4.8214283 0.535714150 ) (-2.60714292 12.1785698 -4.8214283 0.535714150 -5.8928566 -8.6785698 ) (-10.375 8.3749981 -10.7142849 -8.1428566 16.392852 4.17857075 ) (-12.892856 2.3214283 5.67857075 -3.96428537 -5.67857075 3.96428537 )) NATURAL) (2 ((12 284) (12 294)) NIL ((0 10. 0 0 0 0 )) NATURAL) (2 ((12 294) (148 294)) NIL ((136. 0 0 0 0 0 )) NATURAL) (2 ((148 294) (228 121)) NIL ((80. -173. 0 0 0 0 )) NATURAL) (2 ((228 121) (304 294)) NIL ((76. 173. 0 0 0 0 )) NATURAL) (2 ((304 294) (436 294)) NIL ((132. 0 0 0 0 0 )) NATURAL) (2 ((436 294) (436 284)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (5 ((436 284) (425 283) (412 278) (406 267) (405 255)) NIL ((-10.0535698 -0.339285672 0 0 -5.67857075 -3.96428585 ) (-12.892856 -2.3214283 -5.67857075 -3.96428585 16.392852 -4.17857075 ) (-10.374998 -8.375 10.7142849 -8.1428566 -5.8928566 8.6785698 ) (-2.60714245 -12.1785698 4.8214283 0.535714269 -4.8214283 -0.535714269 )) NATURAL) (2 ((405 255) (405 39)) NIL ((0 -216. 0 0 0 0 )) NATURAL) (5 ((405 39) (406 27) (412 16) (425 11) (436 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((436 10) (436 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((436 0) (274 0)) NIL ((-162. 0 0 0 0 0 )) NATURAL) (2 ((274 0) (274 10)) NIL ((0 10. 0 0 0 0 )) NATURAL) (5 ((274 10) (285 11) (298 16) (304 27) (305 39)) NIL ((10.0535698 0.339285672 0 0 5.67857075 3.96428585 ) (12.892856 2.3214283 5.67857075 3.96428585 -16.392852 4.17857075 ) (10.374998 8.375 -10.7142849 8.1428566 5.8928566 -8.6785698 ) (2.60714245 12.1785698 -4.8214283 -0.535714269 4.8214283 0.535714269 )) NATURAL) (2 ((305 39) (305 231)) NIL ((0 192. 0 0 0 0 )) NATURAL) (2 ((305 231) (205 0)) NIL ((-100. -231. 0 0 0 0 )) NATURAL) (3 ((205 0) (180 0) (180 0)) NIL ((-31.25 0 0 0 37.5 0 ) (-12.5 0 37.5 0 -37.5 0 )) NATURAL) (2 ((180 0) (75 225)) NIL ((-105. 225. 0 0 0 0 )) NATURAL) (2 ((75 225) (75 39)) NIL ((0 -186. 0 0 0 0 )) NATURAL) (5 ((75 39) (76 27) (82 16) (95 11) (106 10)) NIL ((0.196428597 -11.910713 0 0 4.8214283 -0.535714150 ) (2.60714292 -12.1785698 4.8214283 -0.535714150 5.8928566 8.6785698 ) (10.375 -8.3749981 10.7142849 8.1428566 -16.392852 -4.17857075 ) (12.892856 -2.3214283 -5.67857075 3.96428537 5.67857075 -3.96428537 )) NATURAL) (2 ((106 10) (106 0)) NIL ((0 -10. 0 0 0 0 )) NATURAL) (2 ((106 0) (12 0)) NIL ((-94. 0 0 0 0 0 )) NATURAL)))) STOP \ No newline at end of file diff --git a/obsolete/sources/FILESETS.NOETHER b/obsolete/sources/FILESETS.NOETHER deleted file mode 100644 index 0ac33fbb..00000000 --- a/obsolete/sources/FILESETS.NOETHER +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "15-Feb-90 16:21:14" {DSK}/users/osamu/SUNLOADUP/FILESETS.;1 6850 previous date%: " 5-Apr-89 16:28:12" {ERIS}SUNLOADUP>FILESETS.;7) (* " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FILESETSCOMS) (RPAQQ FILESETSCOMS ( (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") (* ;; "'90/02/15 osamu: REMOVE LLETHER from 1LISPSET.") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS))) (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" ) (* ;; "'90/02/15 osamu: REMOVE LLETHER from 1LISPSET.") (RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET)) (RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) (RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) (RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) (RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) (RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) (RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) (RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) (RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY)) (RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) (RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) (RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) (RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET))) (RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES)))) (RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) (RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) (RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) (RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL))) (PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/obsolete/sources/FILESETS.ORIG b/obsolete/sources/FILESETS.ORIG deleted file mode 100644 index a88668a2..00000000 --- a/obsolete/sources/FILESETS.ORIG +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 5-Apr-89 16:28:12" {ERIS}SUNLOADUP>FILESETS.;7 7015 changes to%: (VARS 1LISPSET) previous date%: " 6-Feb-89 15:49:03" {ERIS}SUNLOADUP>FILESETS.;6) (* " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FILESETSCOMS) (RPAQQ FILESETSCOMS ( (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS))) (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" ) (RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET)) (RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) (RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) (RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) (RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) (RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) (RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) (RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) (RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY)) (RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) (RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) (RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) (RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET))) (RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES)))) (RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) (RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) (RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) (RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL))) (PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/obsolete/sources/FILESETS.PUP b/obsolete/sources/FILESETS.PUP deleted file mode 100644 index 3dac6662..00000000 --- a/obsolete/sources/FILESETS.PUP +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-Apr-90 16:57:44" {DSK}mitani>SUNLOADUP>FILESETS;2 5281 changes to%: (VARS 1LISPSET) previous date%: " 5-Apr-89 16:28:12" {DSK}mitani>SUNLOADUP>FILESETS;1) (* " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FILESETSCOMS) (RPAQQ FILESETSCOMS ((* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS))) (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" ) (RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET)) (RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) (RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PUP LEAF PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) (RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) (RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) (RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) (RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) (RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) (RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY)) (RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) (RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) (RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) (RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET))) (RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES)))) (RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) (RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) (RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) (RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL))) (PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/obsolete/sources/LISPBCPLFILES.DM b/obsolete/sources/LISPBCPLFILES.DM deleted file mode 100644 index b4a5edfb..00000000 Binary files a/obsolete/sources/LISPBCPLFILES.DM and /dev/null differ diff --git a/obsolete/sources/LOADFULL.CM b/obsolete/sources/LOADFULL.CM deleted file mode 100644 index f2f0ba43..00000000 --- a/obsolete/sources/LOADFULL.CM +++ /dev/null @@ -1 +0,0 @@ -////////////////////////////////////////////////////////////////////////// // // L O A D F U L L . C M // // (C) Copyright 1990, Venue & Fuji Xerox, Ltd. // All Rights Reserved. // // Make LISP.SYSOUT and FULL.SYSOUT on {PELE:}Basics>. // ////////////////////////////////////////////////////////////////////////// ftp ERINYES Directory/C LispCore>SOURCES Retrieve/<>A LOADFULL.CM LoadInit.cm LoadFullFromDLInit.cm @LoadInit.CM@ @LoadFullFromDLInit.cm@ \ No newline at end of file diff --git a/obsolete/sources/LOADFULL.LISP b/obsolete/sources/LOADFULL.LISP deleted file mode 100644 index d5b39ee1..00000000 --- a/obsolete/sources/LOADFULL.LISP +++ /dev/null @@ -1 +0,0 @@ -(RESETVARS ((IDLE.PROFILE (QUOTE (TIMEOUT NIL)))) (DEL.PROCESS (QUOTE IDLE)) (SETQQ DISPLAYFONTDIRECTORIES ({ERIS}FONTS>)) (SETQQ PRESSFONTWIDTHSFILES ({ERIS}FONTS>FONTS.WIDTHS)) (SETQQ INTERPRESSFONTDIRECTORIES ({ERIS}FONTS>)) (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) (SETQQ LOADUPDIRECTORIES ({Eris}Sources> {Eris}Library> {Eris}Internal>Library>)) (LOADUP (QUOTE (GIVE-AND-TAKE CHANGECONTROL CHAT PUPCHAT NSCHAT PRESS PUPPRINT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP MAILCLIENT GRAPEVINE NSMAIL LAFITE FILEBROWSER TELERAID GRAPHER SPY AREDIT WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE))) (\DAYTIME0 \LASTUSERACTION) (ENDLOADUP)) STOP \ No newline at end of file diff --git a/obsolete/sources/LOADFULLFROMDLINIT.CM b/obsolete/sources/LOADFULLFROMDLINIT.CM deleted file mode 100644 index a8677653..00000000 --- a/obsolete/sources/LOADFULLFROMDLINIT.CM +++ /dev/null @@ -1 +0,0 @@ -////////////////////////////////////////////////////////////////////////// // // L O A D F U L L F R O M D L I N I T . C M // // (C) Copyright 1990, Venue & Fuji Xerox, Ltd. // All Rights Reserved. // // Make the INIT.DLINIT into a LISP.SYSOUT & a FULL.SYSOUT. // ////////////////////////////////////////////////////////////////////////// // IF YOU EDIT THIS FILE, BE SURE TO EDIT LOADFULLFROMDLINITSLOW.CM // LoadFullFromDLInit.cm, edited 8-Mar-87 15:40:50 vanMelle // ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE // bring over files necessary to run INIT.DLINIT. FTP/-E ERINYES Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb; // start up DLInit. MAKESYSNAME gets set here. The (SPECVARS . T) is because some file in the loadup (unknown) sets it wrong Lisp {DSK6}Init.DLInit ;" (SETQQ MAKESYSNAME LISPCORE) (PROGN (LOAD (QUOTE \"{Pele:MV:Envos}SOURCES>LOADUP.LISP\")) (HARDRESET)) SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS '\"{Pele:MV:Envos}Basics>LISP.SYSOUT\")) SHH(PROGN (IL:LOAD '\"{Pele:MV:Envos}SOURCES>LOADFULL.LISP\") (IL:MAKESYS '\"{Pele:MV:Envos}Basics>FULL.SYSOUT\") (IL:LOGOUT T)) " \ No newline at end of file diff --git a/obsolete/sources/LOADFULLFROMDLINITSLOW.CM b/obsolete/sources/LOADFULLFROMDLINITSLOW.CM deleted file mode 100644 index 9058d7f3..00000000 --- a/obsolete/sources/LOADFULLFROMDLINITSLOW.CM +++ /dev/null @@ -1 +0,0 @@ -// IF YOU EDIT THIS FILE, BE SURE TO EDIT LOADFULLFROMDLINIT.CM // LoadFullFromDLInitSlow.cm, edited 8-Mar-87 15:40:50 vanMelle // ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE // bring over files necessary to run INIT.DLINIT. FTP/-E ERIS Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb; // start up DLInit. MAKESYSNAME gets set here. The (SPECVARS . T) is because some file in the loadup (unknown) sets it wrong Lisp [ERIS]Next>Init.dlinit ;" (SETQQ MAKESYSNAME LISPCORE) (PROGN (LOAD (QUOTE {ERIS}SOURCES>LOADUP.LISP))(HARDRESET)) SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:* IL:MAKESYS '{ERIS}NEXT>LISP.SYSOUT)) SHH(PROGN (IL:LOAD '{ERIS}SOURCES>LOADFULL.LISP) (IL:MAKESYS '{ERIS}NEXT>FULL.SYSOUT) (IL:LOGOUT T)) " \ No newline at end of file diff --git a/obsolete/sources/LOADFULLFROMLISP.CM b/obsolete/sources/LOADFULLFROMLISP.CM deleted file mode 100644 index 64c731cd..00000000 --- a/obsolete/sources/LOADFULLFROMLISP.CM +++ /dev/null @@ -1 +0,0 @@ -// LoadFullFromLisp.cm Edited 24-Feb-87 19:10:47 -- van Melle -- Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.DFASL!2 Copy INIT.SAVE _ INIT.DFASL // save away site file to be restored below FTP/-E ERIS Login/C Dir/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S Current>Init.null Init.DFASL Lisp [ERIS]Next>Lisp.sysout ;" SHH(PROGN (DELFILE '{DSK}INIT.DFASL) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL;1) ) SHH(LOAD '{ERIS}SOURCES>LOADFULL.LISP) SHH(MAKESYS '{ERIS}NEXT>FULL.SYSOUT] SHH(LOGOUT] " \ No newline at end of file diff --git a/obsolete/sources/LOADFULLSLOW.CM b/obsolete/sources/LOADFULLSLOW.CM deleted file mode 100644 index 33eaa7e8..00000000 --- a/obsolete/sources/LOADFULLSLOW.CM +++ /dev/null @@ -1 +0,0 @@ -ftp ERIS Directory/C LispCore>SOURCES Retrieve/<>A LOADFULLSLOW.CM LoadInitSlow.cm LoadFullFromDLInitSlow.cm @LoadInitSlow.CM@ @LoadFullFromDLInitSlow.cm@ \ No newline at end of file diff --git a/obsolete/sources/LOADINIT.CM b/obsolete/sources/LOADINIT.CM deleted file mode 100644 index 3353168f..00000000 --- a/obsolete/sources/LOADINIT.CM +++ /dev/null @@ -1 +0,0 @@ -////////////////////////////////////////////////////////////////////////// // // L O A D I N I T . C M // // (C) Copyright 1990, Venue & Fuji Xerox, Ltd. // All Rights Reserved. // // Make the INIT.DLINIT starting sysout for a new loadup. // ////////////////////////////////////////////////////////////////////////// // IF YOU EDIT THIS FILE, EDIT LOADINITSLOW.CM TOO!!!! // Edit November 3, 1987 by vanMelle, note comment ^^ // The path given to the Lisp command below should point to the LispCore sysout cache. // Code that runs after Lisp starts up assures that the cached sysout // is the most recent, and if not, fetches a new one and restarts itself. // Edited so that the most recent patch file is loaded // Updated Lisp version for big physical memory --bvm 11/3/87 Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.LISP!2 Copy INIT.SAVE _ INIT.DFASL // save away site file to be restored below FTP/-E ERINYES Login/C Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S Current>Init-NOGREET Init.DFASL Lisp {DSK7}LispCore.Sysout;" (XCL:RESTORE-PROFILE \"INTERLISP\") (DELFILE '{DSK}INIT.DFASL) (AND (INFILEP '{DSK}INIT.SAVE) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL)) (DIRECTORY '{DSK6}INIT.DLINIT;* '(DELETE)) (* Make sure we have a valid sysout) (LET ((DATE (CAR (NLSETQ (GETFILEINFO '{Pele:mv:envos}Saved>FULL.SYSOUT 'ICREATIONDATE))))) (IF (AND DATE (IGREATERP DATE (GETFILEINFO '{DSK7}LispCore.Sysout;1 'ICREATIONDATE))) THEN (* Get new saved sysout) (NLSETQ (PROGN (COPYFILE '{Pele:mv:envos}Saved>FULL.SYSOUT '{DSK7}LispCore.Sysout;1) (COPYFILE '{DSK}REM.CM;1 '{CORE}REM.CM) (* Repeat current command now) (OUTFILE '{DSK}REM.CM;1) (PRIN1 '@LoadInit.cm@) (COPYBYTES (OPENSTREAM '{CORE}REM.CM 'INPUT)) (CLOSEF) (LOGOUT T] (PROGN (* Make old sysout work with new read tables) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM FILERDTBL) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM CODERDTBL) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM \\ORIGREADTABLE)) (LOAD \"{Pele:mv:envos}NEXT>LOAD-LISPCORE-PATCH\") CONN \"{pele:mv:envos}SOURCES>\" (SETQ DIRECTORIES '(\"{Pele:MV:Envos}SOURCES>\" \"{Pele:MV:Envos}LIBRARY>\" \"{Pele:MV:Envos}INTERNAL>LIBRARY>\")) (SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL) (SETQ *REMOVE-INTERLISP-COMMENTS* NIL) (* Get new exports since last loadup) (LOAD 'CONDITION-PACKAGE.LCOM 'SYSLOAD) (LOAD 'XCL-PACKAGE.LCOM 'SYSLOAD) (* FILESETS has where to get things from) (LOAD 'FILESETS) (FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) (* Versions are Lisp Microcode Bcpl) (PROGN (CNDIR '{CORE}) (IDLE.SET.OPTION 'TIMEOUT 0) (IDLE.SET.OPTION 'SAVEVM 0) (DORENAME 'I) (DLFIXINIT (MAKEINIT '(115000Q 13062Q 25400Q) NIL NIL '(\"{Pele:MV:Envos}SOURCES>\" \"{Pele:MV:Envos}INTERNAL>LIBRARY>\" \"{Pele:MV:Envos}LIBRARY>\")) '{DSK6}INIT.DLINIT \"{Pele:MV:Envos}NEXT>LispDLion.db\" 300) (LOGOUT T]] " \ No newline at end of file diff --git a/obsolete/sources/LOADINITSLOW.CM b/obsolete/sources/LOADINITSLOW.CM deleted file mode 100644 index 5628c9a8..00000000 --- a/obsolete/sources/LOADINITSLOW.CM +++ /dev/null @@ -1 +0,0 @@ -// LoadInitSlow.cm edited: November 3, 1987 by vanMelle // IF YOU EDIT THIS FILE, EDIT LOADINIT.CM TOO // edit 30-Nov-86 12:06:48 by masinter, merge LOADINIT changes, add comment above // Updated Lisp version for big physical memory --bvm 11/3/87 // The path given to the Lisp command below should point to the LispCore sysout cache. Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.LISP!2 Copy INIT.SAVE _ INIT.DFASL // save away site file to be restored below FTP/-E ERIS Login/C Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S Current>Init-NOGREET Init.DFASL Lisp [ERIS]saved>Full.Sysout;" (XCL:RESTORE-PROFILE \"INTERLISP\") (DELFILE '{DSK}INIT.DFASL) (AND (INFILEP '{DSK}INIT.SAVE) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL)) (PROGN (* Make old sysout work with new read tables) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM FILERDTBL) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM CODERDTBL) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM \\ORIGREADTABLE)) (LOAD '{ERIS}NEXT>LOAD-LISPCORE-PATCH) CONN {ERIS}SOURCES> (SETQ DIRECTORIES '({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}INTERNAL>LIBRARY>)) (SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL) (SETQ *REMOVE-INTERLISP-COMMENTS* NIL) (* Get new exports since last loadup) (LOAD 'CONDITION-PACKAGE.LCOM 'SYSLOAD) (LOAD 'XCL-PACKAGE.LCOM 'SYSLOAD) (* FILESETS has where to get things from) (LOAD 'FILESETS) (FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) (* Versions are Lisp Microcode Bcpl) (PROGN (CNDIR '{CORE}) (IDLE.SET.OPTION 'TIMEOUT 0) (IDLE.SET.OPTION 'SAVEVM 0) (DORENAME 'I) (DLFIXINIT (MAKEINIT '(115000Q 13062Q 25400Q) NIL NIL '({ERIS}SOURCES> {ERIS}LIBRARY>)) '{ERIS}NEXT>INIT.DLINIT '{ERIS}NEXT>LispDLion.db 300) (LOGOUT T]] " \ No newline at end of file diff --git a/obsolete/sources/LOADUP.LISP b/obsolete/sources/LOADUP.LISP deleted file mode 100644 index 5f2c4783..00000000 --- a/obsolete/sources/LOADUP.LISP +++ /dev/null @@ -1,53 +0,0 @@ -(SETQQ COMPILE.EXT LCOM) -(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES)) -(SETQ BOOTLOADEDFILES) -(* ;; "following files are really loaded earlier, this call to LOADUP just cleans up") -(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP))) -(* ;; "establish all package exports early") -(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE))) -(* ;; "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))) -(* ;; "needed for makesys") -(LOADUP (QUOTE (MOD44IO))) -(* ;; -"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 PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN))) -(LOADUP (QUOTE (BREAK-AND-TRACE))) -(LOADUP (QUOTE (FASDUMP XCL-COMPILER ADVISE))) -(* ;; "the bytecompiler and Interlisp compiler interface functions") -(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE))) -(LOADUP (QUOTE (HARDCOPY LOGOW IDLER ICONW FREEMENU SEDIT))) -(CLOSEW (LOGOW)) (MOVD 'NILL 'LOGOW) -(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) - (* ;; "Additional stuff that should be folded into original definitions") - (LOADUP (QUOTE (LOADUP-LISP))) - STOP - diff --git a/obsolete/sources/LispDMC.DM b/obsolete/sources/LispDMC.DM deleted file mode 100644 index e88c9f69..00000000 Binary files a/obsolete/sources/LispDMC.DM and /dev/null differ diff --git a/obsolete/sources/MAPATOMS b/obsolete/sources/MAPATOMS deleted file mode 100644 index 299f47a3..00000000 --- a/obsolete/sources/MAPATOMS +++ /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/sources/MAPATOMS.LCOM b/obsolete/sources/MAPATOMS.LCOM deleted file mode 100644 index a09cf6f2..00000000 Binary files a/obsolete/sources/MAPATOMS.LCOM and /dev/null differ diff --git a/obsolete/sources/NEW-EDIT-INTERFACE b/obsolete/sources/NEW-EDIT-INTERFACE deleted file mode 100644 index 2c6a174e..00000000 --- a/obsolete/sources/NEW-EDIT-INTERFACE +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "25-Jan-91 16:57:19" |{DSK}woz>SOURCES>NEW-EDIT-INTERFACE.;8| 6497 |changes| |to:| (FUNCTIONS XCL::EDIT-EXPRESSION XCL::EDIT-DEFINITION XCL::EDIT SEDIT::EDIT-EXPRESSION SEDIT::MYED) (VARS NEW-EDIT-INTERFACECOMS) |previous| |date:| " 3-Dec-90 18:01:41" |{DSK}woz>SOURCES>NEW-EDIT-INTERFACE.;1|) ; Copyright (c) 1990, 1991 by Venue. All rights reserved. (PRETTYCOMPRINT NEW-EDIT-INTERFACECOMS) (RPAQQ NEW-EDIT-INTERFACECOMS ((FUNCTIONS XCL::EDIT XCL::EDIT-DEFINITION XCL::EDIT-EXPRESSION))) (CL:DEFUN XCL::EDIT (CL:STRUCTURE XCL::PROPS XCL::OPTIONS) (* |;;;| "this is the new way to start the current editor, once you have all the props and options figured out.") (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (CL:FUNCALL (EDITMODE) CL:STRUCTURE XCL::PROPS XCL::OPTIONS)) (CL:DEFUN XCL::EDIT-DEFINITION (XCL::NAME TYPE &OPTIONAL XCL::SOURCE XCL::OPTIONS XCL::PROPS) (* |;;;| "this is a new version of IL:EDITDEF, consistent with the new definition of how to start the current editor. figure out how to get the definition (same as il:editdef), then build the necessary stuff to start the editor and have completion work properly. since we have a \"definition\" there is no need for a root-changed-fn, because putdef will be handed the right structure on completion anyway. Do not wait for completion, just return NAME.") (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (LET* ((XCL::DEFINITION (COND (XCL::SOURCE (GETDEF XCL::NAME TYPE XCL::SOURCE '(EDIT NOCOPY))) ((GETDEF XCL::NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR))) ((GETDEF XCL::NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR))) (T (LET ((XCL::FILES (WHEREIS XCL::NAME TYPE T))) (CL:IF (NULL XCL::FILES) (CL:FORMAT T "~S has no ~A definition.~%" XCL::NAME TYPE) (LET ((XCL::FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%" XCL::NAME XCL::FILES) (CL:IF (CL:ENDP (CDR XCL::FILES)) (CL:IF (CL:Y-OR-N-P "Shall I load this file PROP? " ) (CAR XCL::FILES)) (ASKUSER NIL NIL "indicate which file to load PROP: " (MAKEKEYLST XCL::FILES) T))))) (CL:WHEN XCL::FILE (LOAD XCL::FILE 'PROP) (GETDEF XCL::NAME TYPE '? '(EDIT NOCOPY))))))))) (XCL::USER-COMPLETION (LISTGET XCL::PROPS :COMPLETION-FN)) (XCL::COMPLETION-FN #'(CL:LAMBDA (XCL::CONTEXT XCL::NEW-DEF XCL::CHANGED?) (CL:WHEN XCL::USER-COMPLETION (CL:FUNCALL XCL::USER-COMPLETION XCL::CONTEXT XCL::NEW-DEF XCL::CHANGED?)) (CL:WHEN (EQ XCL::CHANGED? T) (* |;;| "don't reinstall on :ABORT or NIL (no changes)") (PUTDEF XCL::NAME TYPE XCL::NEW-DEF 'CHANGED))))) (CL:WHEN XCL::DEFINITION (XCL::EDIT XCL::DEFINITION (LIST :NAME XCL::NAME :TYPE TYPE :COMPLETION-FN XCL::COMPLETION-FN) XCL::OPTIONS)) XCL::NAME)) (CL:DEFUN XCL::EDIT-EXPRESSION (XCL::EXPR &OPTIONAL XCL::OPTIONS XCL::PROPS) (* |;;;| "similar to ED, but just a one-time un-named edit of an expression. start the editor with :close-on-completion, wait until the edit session completes, and return the structure. Copy the expression before starting the editor so that changes won't be destructive, then recreate eqness on completion. This way aborted changes will not be kept.") (CL:UNLESS (CL:CONSP XCL::EXPR) (CL:ERROR "~S - Not Editable. Must be a list expression." XCL::EXPR) (CL:RETURN-FROM XCL::EDIT-EXPRESSION NIL)) (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (LET* ((XCL::EVENT (CREATE.EVENT "EDIT-EXPRESSION Completion")) (XCL::USER-COMPLETION (LISTGET XCL::PROPS :COMPLETION-FN)) (XCL::NEW-EXPR NIL) (XCL::COMPLETION-FN #'(CL:LAMBDA (XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?) (CL:WHEN XCL::USER-COMPLETION (CL:FUNCALL XCL::USER-COMPLETION XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?)) (CL:WHEN (EQ XCL::CHANGED? T) (CL:SETQ XCL::NEW-EXPR CL:STRUCTURE)) (NOTIFY.EVENT XCL::EVENT)))) (XCL::EDIT (CL:COPY-TREE XCL::EXPR) (LIST :COMPLETION-FN XCL::COMPLETION-FN) (LIST* :CLOSE-ON-COMPLETION XCL::OPTIONS)) (CL:UNLESS (CL:MEMBER :DONTWAIT XCL::OPTIONS) (AWAIT.EVENT XCL::EVENT)) (CL:IF (AND XCL::NEW-EXPR (CL:CONSP XCL::NEW-EXPR)) (RPLNODE2 XCL::EXPR (CL:COPY-TREE XCL::NEW-EXPR)) XCL::EXPR))) (PUTPROPS NEW-EDIT-INTERFACE COPYRIGHT ("Venue" 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/obsolete/sources/NEW-EDIT-INTERFACE.LCOM b/obsolete/sources/NEW-EDIT-INTERFACE.LCOM deleted file mode 100644 index db8f911d..00000000 --- a/obsolete/sources/NEW-EDIT-INTERFACE.LCOM +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "25-Jan-98 18:00:13" ("compiled on " |{DSK}sources>NEW-EDIT-INTERFACE.;1|) "30-Mar-95 20:33:04" |bcompl'd| |in| "Medley 14-Aug-95 ..." |dated| "14-Aug-95 15:27:48") (FILECREATED "25-Jan-91 16:57:19" |{DSK}woz>SOURCES>NEW-EDIT-INTERFACE.;8| 6497 |changes| |to:| (FUNCTIONS XCL::EDIT-EXPRESSION XCL::EDIT-DEFINITION XCL::EDIT SEDIT::EDIT-EXPRESSION SEDIT::MYED) ( VARS NEW-EDIT-INTERFACECOMS) |previous| |date:| " 3-Dec-90 18:01:41" |{DSK}woz>SOURCES>NEW-EDIT-INTERFACE.;1|) (PRETTYCOMPRINT NEW-EDIT-INTERFACECOMS) (RPAQQ NEW-EDIT-INTERFACECOMS ((FUNCTIONS XCL::EDIT XCL::EDIT-DEFINITION XCL::EDIT-EXPRESSION))) (CL:DEFUN XCL::EDIT (CL:STRUCTURE XCL::PROPS XCL::OPTIONS) (* |;;;| "this is the new way to start the current editor, once you have all the props and options figured out." ) (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (CL:FUNCALL (EDITMODE ) CL:STRUCTURE XCL::PROPS XCL::OPTIONS)) (CL:DEFUN XCL::EDIT-DEFINITION (XCL::NAME TYPE &OPTIONAL XCL::SOURCE XCL::OPTIONS XCL::PROPS) (* |;;;| "this is a new version of IL:EDITDEF, consistent with the new definition of how to start the current editor. figure out how to get the definition (same as il:editdef), then build the necessary stuff to start the editor and have completion work properly. since we have a \"definition\" there is no need for a root-changed-fn, because putdef will be handed the right structure on completion anyway. Do not wait for completion, just return NAME." ) (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (LET* ((XCL::DEFINITION (COND (XCL::SOURCE (GETDEF XCL::NAME TYPE XCL::SOURCE (QUOTE (EDIT NOCOPY)))) ((GETDEF XCL::NAME TYPE (QUOTE CURRENT) (QUOTE (EDIT NOCOPY NOERROR)))) ((GETDEF XCL::NAME TYPE (QUOTE SAVED) (QUOTE (EDIT NOCOPY NOERROR)))) (T (LET ((XCL::FILES (WHEREIS XCL::NAME TYPE T))) (CL:IF (NULL XCL::FILES) (CL:FORMAT T "~S has no ~A definition.~%" XCL::NAME TYPE) (LET ((XCL::FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%" XCL::NAME XCL::FILES) (CL:IF (CL:ENDP (CDR XCL::FILES)) (CL:IF ( CL:Y-OR-N-P "Shall I load this file PROP? ") (CAR XCL::FILES)) (ASKUSER NIL NIL "indicate which file to load PROP: " (MAKEKEYLST XCL::FILES) T))))) (CL:WHEN XCL::FILE (LOAD XCL::FILE (QUOTE PROP)) (GETDEF XCL::NAME TYPE (QUOTE ?) (QUOTE (EDIT NOCOPY)))))))))) (XCL::USER-COMPLETION ( LISTGET XCL::PROPS :COMPLETION-FN)) (XCL::COMPLETION-FN (CL:FUNCTION (CL:LAMBDA (XCL::CONTEXT XCL::NEW-DEF XCL::CHANGED?) (CL:WHEN XCL::USER-COMPLETION (CL:FUNCALL XCL::USER-COMPLETION XCL::CONTEXT XCL::NEW-DEF XCL::CHANGED?)) (CL:WHEN (EQ XCL::CHANGED? T) (* |;;| "don't reinstall on :ABORT or NIL (no changes)") (PUTDEF XCL::NAME TYPE XCL::NEW-DEF (QUOTE CHANGED))) )))) (CL:WHEN XCL::DEFINITION (XCL::EDIT XCL::DEFINITION (LIST :NAME XCL::NAME :TYPE TYPE :COMPLETION-FN XCL::COMPLETION-FN) XCL::OPTIONS)) XCL::NAME)) (CL:DEFUN XCL::EDIT-EXPRESSION (XCL::EXPR &OPTIONAL XCL::OPTIONS XCL::PROPS) (* |;;;| "similar to ED, but just a one-time un-named edit of an expression. start the editor with :close-on-completion, wait until the edit session completes, and return the structure. Copy the expression before starting the editor so that changes won't be destructive, then recreate eqness on completion. This way aborted changes will not be kept." ) (CL:UNLESS (CL:CONSP XCL::EXPR) (CL:ERROR "~S - Not Editable. Must be a list expression." XCL::EXPR ) (CL:RETURN-FROM XCL::EDIT-EXPRESSION NIL)) (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (LET* ((XCL::EVENT (CREATE.EVENT "EDIT-EXPRESSION Completion")) ( XCL::USER-COMPLETION (LISTGET XCL::PROPS :COMPLETION-FN)) (XCL::NEW-EXPR NIL) (XCL::COMPLETION-FN ( CL:FUNCTION (CL:LAMBDA (XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?) (CL:WHEN XCL::USER-COMPLETION ( CL:FUNCALL XCL::USER-COMPLETION XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?)) (CL:WHEN (EQ XCL::CHANGED? T ) (CL:SETQ XCL::NEW-EXPR CL:STRUCTURE)) (NOTIFY.EVENT XCL::EVENT))))) (XCL::EDIT (CL:COPY-TREE XCL::EXPR ) (LIST :COMPLETION-FN XCL::COMPLETION-FN) (LIST* :CLOSE-ON-COMPLETION XCL::OPTIONS)) (CL:UNLESS ( CL:MEMBER :DONTWAIT XCL::OPTIONS) (AWAIT.EVENT XCL::EVENT)) (CL:IF (AND XCL::NEW-EXPR (CL:CONSP XCL::NEW-EXPR)) (RPLNODE2 XCL::EXPR (CL:COPY-TREE XCL::NEW-EXPR)) XCL::EXPR))) (PUTPROPS NEW-EDIT-INTERFACE COPYRIGHT ("Venue" 1990 1991)) NIL \ No newline at end of file diff --git a/obsolete/sources/POSTLOADUP b/obsolete/sources/POSTLOADUP deleted file mode 100644 index 3b6e5450..00000000 --- a/obsolete/sources/POSTLOADUP +++ /dev/null @@ -1,37 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") -(FILECREATED "16-May-90 21:05:36" {DSK}local>lde>lispcore>sources>POSTLOADUP.;2 870 - - changes to%: (VARS POSTLOADUPCOMS) - - previous date%: " 8-DEC-81 15:27:54" {DSK}local>lde>lispcore>sources>POSTLOADUP.;1) - - -(* ; " -Copyright (c) 1990 by Venue. All rights reserved. -") - -(PRETTYCOMPRINT POSTLOADUPCOMS) - -(RPAQQ POSTLOADUPCOMS - [(* set up so that files can be loaded directly from phylum) - (* turn off checking for dates of source) - (P (MOVD 'NILL 'LOADUP2A) - (CHANGENAME 'LOADUP2 'ASSOC 'TRUE]) - - - -(* set up so that files can be loaded directly from phylum) - - - - -(* turn off checking for dates of source) - - -(MOVD 'NILL 'LOADUP2A) - -(CHANGENAME 'LOADUP2 'ASSOC 'TRUE) -(PUTPROPS POSTLOADUP COPYRIGHT ("Venue" 1990)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/sources/POSTLOADUP.LCOM b/obsolete/sources/POSTLOADUP.LCOM deleted file mode 100644 index e46fea2b..00000000 --- a/obsolete/sources/POSTLOADUP.LCOM +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "26-Jan-98 13:27:16" ("compiled on " {DSK}disk2>jdstools>lc3>lispcore3.0>sources>POSTLOADUP.;1) "30-Mar-95 20:33:04" bcompl'd in "Medley 14-Aug-95 ..." dated "14-Aug-95 15:27:48") (FILECREATED "16-May-90 21:05:36" {DSK}local>lde>lispcore>sources>POSTLOADUP.;2 870 changes to%: (VARS POSTLOADUPCOMS) previous date%: " 8-DEC-81 15:27:54" {DSK}local>lde>lispcore>sources>POSTLOADUP.;1) (PRETTYCOMPRINT POSTLOADUPCOMS) (RPAQQ POSTLOADUPCOMS ((* set up so that files can be loaded directly from phylum) (* turn off checking for dates of source) (P (MOVD (QUOTE NILL) (QUOTE LOADUP2A)) (CHANGENAME (QUOTE LOADUP2) ( QUOTE ASSOC) (QUOTE TRUE))))) (MOVD (QUOTE NILL) (QUOTE LOADUP2A)) (CHANGENAME (QUOTE LOADUP2) (QUOTE ASSOC) (QUOTE TRUE)) (PUTPROPS POSTLOADUP COPYRIGHT ("Venue" 1990)) NIL \ No newline at end of file diff --git a/obsolete/sources/SUNFONT b/obsolete/sources/SUNFONT deleted file mode 100644 index c449f5e4..00000000 --- a/obsolete/sources/SUNFONT +++ /dev/null @@ -1,32 +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}~/lispcore/fonts/display/presentation/" - - "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" - - "{DSK}~/lispcore/fonts/display/publishing/" - - "{DSK}~/lispcore/fonts/display/miscellaneous/" - )) -(PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL))) -STOP - - - - diff --git a/obsolete/sources/SYNCLISPFILES b/obsolete/sources/SYNCLISPFILES deleted file mode 100644 index 6f003db6..00000000 --- a/obsolete/sources/SYNCLISPFILES +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 6-Feb-2021 15:19:48" {DSK}larry>ilisp>medley>sources>SYNCLISPFILES.;2 7670 changes to%: (FNS SYNCLISPFILES) previous date%: " 5-Feb-2021 15:41:04" {DSK}larry>ilisp>medley>sources>SYNCLISPFILES.;1 ) (PRETTYCOMPRINT SYNCLISPFILESCOMS) (RPAQQ SYNCLISPFILESCOMS ((FNS) (FNS SYNCLISPFILES NOPUPPATCH))) (DEFINEQ (SYNCLISPFILES [LAMBDA (NOSYSLOAD) (* ; "Edited 6-Feb-2021 15:16 by larry") (* ; "Edited 5-Feb-2021 15:40 by lmm") (* ;  "Edited 23-Oct-2020 23:51 by rmk:") (* ;  "Edited 20-Apr-2018 18:28 by rmk:") (* ;; "This ensures that files in the xlisp.sysout are as up-to-date as possible with respect to sources. Reload (compiled, if possible) files that correspond to symbolic files whose filedates are later than the filedate in the system. If you want a new compilation of a file that has not been modified to be included, then you must make a trivial update of the symbolic file and recompile it, to give it a new, later date. This is because it is unsafe as a general default to load compiled files with dates later than the sysout, and the sysout doesn't record the dates of loaded compiled files, just their symbolic versions.") (* ;; " Should be run while connected to MEDLEYDIR") (LET ((SKIPFILES '(SYNCLISPFILES)) (SOURCEDIR (MEDLEYDIR "sources"))) (* ;;  "FASLOAD has to come first, unconditionally, to get the DFASL file dates converted properly.") (PRINTOUT T T "Synchronizing Lisp sysout at " (DATE) T) (PRINTOUT T 5 (CDAR (GETP 'SYNCLISPFILES 'FILEDATES)) T 5 "created " (CAAR (GETP 'SYNCLISPFILES 'FILEDATES)) T T) (* ;;  "FASLOAD has to come first, unconditionally, to get the DFASL file dates converted properly.") (push SKIPFILES 'FASLOAD) (LOAD (MEDLEYDIR "sources" "FASLOAD.DFASL") (IF NOSYSLOAD THEN NIL ELSE 'SYSLOAD)) (push SKIPFILES 'ATBL) (* ;  "Whole file can't be reloaded--smashes readtabl") (LOADFNS '(\ATBLSET \MAPCHARTABLE RESETREADTABLE) (MEDLEYDIR "sources" "ATBL.LCOM") 'SYSLOAD) (LOADVARS '\KEYNAMES (MEDLEYDIR "sources" "LLKEY") 'SYSLOAD) (* ; "Extended keynames for Mac/PC") (push SKIPFILES 'LLKEY) (* ; "Loading whole file freezes") (push SKIPFILES 'MAIKOLOADUPFNS) (* ;  "Can't reload even if compiled files are later") (push SKIPFILES 'SUNFONT) (* ;  "Old font organization, not relevant") (for LF FF CFILE LOADEDDATE FILEDATE IFILEDATE NOCOMPILEDFILES CFILES (COUNT _ 0) in (LDIFFERENCE SYSFILES SKIPFILES) do [SETQ LOADEDDATE (CAAR (GETP LF 'FILEDATES] (* ;  "Date of symbolic file whose compile file was loaded") (CL:UNLESS LOADEDDATE (PRINTOUT T T LF " does not have a loaded filedate, probably not a Lisp file; skipped" T) (GO $$ITERATE)) (SETQ FF (PACKFILENAME.STRING 'NAME LF 'BODY SOURCEDIR)) (SETQ FILEDATE (FILEDATE FF)) (* ; "Date of current source file") (CL:UNLESS FILEDATE (PRINTOUT T LF " does not have a file-directory date, not updated" T) (GO $$ITERATE)) (SETQ CFILES (for EXT in *COMPILED-EXTENSIONS* when (SETQ CFILE (INFILEP (PACKFILENAME.STRING 'EXTENSION EXT 'BODY FF))) collect CFILE) ) (SETQ CFILE (COND [CFILES (* ;;  "If more than one (LCOM, DFASL), pick the newest one.") (for CF in CFILES largest (IDATE (FILEDATE CF T] (T (PRINTOUT T "Note: No compiled file for " LF T) (push NOTCOMPILEDFILES LF) FF))) (SETQ IFILEDATE (IDATE FILEDATE)) (CL:UNLESS (IGREATERP IFILEDATE 0) (PRINTOUT T "Funny file date " FILEDATE " for " LF ", not updated" T) (GO $$ITERATE)) (* ;; "Load the compiled file if the date of the symbolic file is later than the symbolic file-date in the sysout. If an updated source and compiled file were copied from another directory, we update the FILEDATES property to point to the new location. If the loaded and file dates are the same, then update the FILEDATES property to point to the possibly new path name and version even if we don't need to load.") (SETQ LOADEDDATE (IDATE LOADEDDATE)) (if (IGREATERP IFILEDATE LOADEDDATE) then (add COUNT 1) (* ;; " FINALLY do the load") (LOAD CFILE (if NOSYSLOAD then NIL else 'SYSLOAD)) (CL:WHEN [STREQUAL FILEDATE (CAAR (GETP LF 'FILEDATES] (* ;; "If copied, the compiled file may install the original location. Not sure what happens with copied DFASLs") (RPLACD (CAR (GETP LF 'FILEDATES)) (INFILEP FF))) elseif (IEQP IFILEDATE LOADEDDATE) then (RPLACD (CAR (GETP LF 'FILEDATES)) (INFILEP FF))) finally (PRINTOUT T T T COUNT " files loaded" T) (CL:WHEN NOCOMPILEDFILES (PRINTOUT T "Symbolic files loaded: " .PPVTL NOCOMPILEDFILES T T))) (NOPUPPATCH]) (NOPUPPATCH [LAMBDA NIL (* ;  "Edited 14-May-2018 12:22 by rmk:") (* ;; "Fix it so pup stuff never gets run") (SETQ \PROCESSES (DREMOVE (FIND.PROCESS '\PUPGATELISTENER) \PROCESSES)) (SETQ \FILEDEVICES (for F in \FILEDEVICES unless (STRPOS "LEAF" F) collect F)) (MOVD 'NILL '\CANONICALIZE.PUP.HOSTNAME]) ) (PUTPROPS SYNCLISPFILES COPYRIGHT (NONE)) (DECLARE%: DONTCOPY (FILEMAP (NIL (449 7605 (SYNCLISPFILES 459 . 7113) (NOPUPPATCH 7115 . 7603))))) STOP \ No newline at end of file diff --git a/obsolete/sources/SYNCLISPFILES.LCOM b/obsolete/sources/SYNCLISPFILES.LCOM deleted file mode 100644 index ef7cdd66..00000000 Binary files a/obsolete/sources/SYNCLISPFILES.LCOM and /dev/null differ diff --git a/obsolete/sources/XMAS b/obsolete/sources/XMAS deleted file mode 100644 index f6a6705d..00000000 --- a/obsolete/sources/XMAS +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Oct-91 20:16:54" |{PELE:MV:ENVOS}SOURCES>XMAS.;1| 160511 changes to%: (RECORDS XSCREEN) (FNS CREATEXSCREEN) previous date%: " 2-Oct-91 15:15:20" {DSK}nilsson>xmas-split>XMAS.;3) (* ; " Copyright (c) 1991 by Venue. All rights reserved. ") (PRETTYCOMPRINT XMASCOMS) (RPAQQ XMASCOMS [(RECORDS XSCREEN SCREENREGION) (INITVARS XLIB::*DISPLAY* XLIB::*SCREEN* XLIB::*ROOT* XLIB::*BLACK* XLIB::*WHITE* XLIB::*DEFAULTFONT* (XLIB::*DEFAULT-FONT-NAME* "FIXED") XLIB::*GC* XLIB::*COLORMAP*) (MACROS \XCURVESMOOTH) (FNS XLIB::SETUP-CLX) (FNS \XDISPLAYINIT CREATEXSCREEN BITSPERPIXEL BITMAPHEIGHT BITMAPWIDTH DSPDESTINATION XDSPCREATE \DSPOPERATION.XDISPLAY \DSPRESET.XDISPLAY \BLTSHADE.XDISPLAY \BITBLT.XDISPLAY \XBITBLTSUB \XBLTSHADE.PIXMAP \XBITBLT.PIXMAP \DRAWPOINT.XDISPLAY \DRAWLINE.XDISPLAY \XLINEWITHBRUSH \DRAWCIRCLE.XDISPLAY \DRAWCURVE.XDISPLAY \XCURVE2 \XCURVE) (FNS BITBLT) (FNS XCREATEWFROMPIXMAP PIXMAPCREATE PIXMAPWIDTH PIXMAPHEIGHT) (FNS XCREATEW ADVISEXWDS XOPENW \XOPENW1 XCLOSEW \XCLOSEW1 \XSFFixClippingRegion XSHOWWFRAME XSHOWWTITLE \XCREATEBASEW \DSPCLIPPINGREGION.XDISPLAY) (FNS \XDSPPRINTCHAR \XBLTCHAR \XDSPPRINTCR/LF) (FNS OPENWINDOWS \INSURESCREEN DSPSOURCETYPE PUTWINDOWPROP RESHOWBORDER \XRESHOWBORDER1 \GETWINDOWHEIGHT) (FNS XWHICHW) (FNS TOTOPW) (FNS XSHAPEW1 XMOVEW XMOVEW1 XMOVEORRESIZED.WINDOW XMOVED.WINDOW) (INITVARS (\XSCREEN NIL)) [ADDVARS (\DISPLAYSTREAMTYPES XDISPLAY) (IMAGESTREAMTYPES (XDISPLAY (OPENSTREAM NILL) (FONTCREATE \CREATEXDISPLAYFONT) (FONTSAVAILABLE NILL) (CREATECHARSET NILL] (FILES XLLKEY XLLBITMAP XLLCURSOR XLLMOUSE XLLFONT XSERVER XWATCHER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA XLIB::SETUP-CLX]) (DECLARE%: EVAL@COMPILE (DATATYPE XSCREEN (SCONOFF SCDESTINATION SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA (* ;; "Access fns and their caches.") \SCBITSPERPIXELCACHE (* ; "The cache for pixeldepth.") \GETSCBITSPERPIXEL (* ; "The access function for pixdepth. This function must return a number, larger than 0. This function is applied to the screen structure.") \SCWIDTHCACHE (* ; "The screenwidth cache. ") \GETSCWIDTH (* ; "The access function for screenwidth. This function must return a number, larger than 0. This function is applied to the screen structure.") \SCHEIGHTCACHE (* ; "The screenheigth cache. ") \GETSCHEIGHT (* ; "The access function for screenheigth. This function must return a number, larger than 0. This function is applied to the screen structure") CREATEWFN OPENWFN CLOSEWFN) SCONOFF _ 'OFF (* ;; "The function for getting the pixeldepth of the screen.") [ACCESSFNS ((SCBITSPERPIXEL (OR \SCBITSPERPIXELCACHE (replace (XSCREEN \SCBITSPERPIXELCACHE) of DATUM with (APPLY (fetch (XSCREEN \GETSCBITSPERPIXEL ) of DATUM) (LIST DATUM))) (SHOULDNT "Pixel depth of screen is NIL")) (replace (XSCREEN \SCBITSPERPIXELCACHE) of DATUM with NEWVALUE)) (SCWIDTH (OR \SCWIDTHCACHE (replace (XSCREEN \SCWIDTHCACHE) of DATUM with (APPLY (fetch (XSCREEN \GETSCWIDTH ) of DATUM) (LIST DATUM))) (SHOULDNT "Width of screen is NIL")) (replace (XSCREEN \SCWIDTHCACHE) of DATUM with NEWVALUE)) (SCHEIGHT (OR \SCHEIGHTCACHE (replace (XSCREEN \SCHEIGHTCACHE) of DATUM with (APPLY (fetch (XSCREEN \GETSCHEIGHT ) of DATUM) (LIST DATUM))) (SHOULDNT "Heigth of screen is NIL")) (replace (XSCREEN \SCHEIGHTCACHE) of DATUM with NEWVALUE)) (SCREGION (create REGION LEFT _ 0 BOTTOM _ 0 (* ; "Behold clever recursion.") WIDTH _ (fetch (XSCREEN SCWIDTH) of DATUM) (* ; "Dito.") HEIGHT _ (fetch (XSCREEN SCHEIGHT) of DATUM] (SYSTEM)) (RECORD SCREENREGION (SCREEN . REGION) (SUBRECORD REGION) [TYPE? (AND (LISTP DATUM) (type? SCREEN (CAR DATUM)) (type? REGION (CDR DATUM] (SYSTEM)) ) (/DECLAREDATATYPE 'XSCREEN '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((XSCREEN 0 POINTER) (XSCREEN 2 POINTER) (XSCREEN 4 POINTER) (XSCREEN 6 POINTER) (XSCREEN 8 POINTER) (XSCREEN 10 POINTER) (XSCREEN 12 POINTER) (XSCREEN 14 POINTER) (XSCREEN 16 POINTER) (XSCREEN 18 POINTER) (XSCREEN 20 POINTER) (XSCREEN 22 POINTER) (XSCREEN 24 POINTER) (XSCREEN 26 POINTER) (XSCREEN 28 POINTER) (XSCREEN 30 POINTER) (XSCREEN 32 POINTER)) '34) (RPAQ? XLIB::*DISPLAY* NIL) (RPAQ? XLIB::*SCREEN* NIL) (RPAQ? XLIB::*ROOT* NIL) (RPAQ? XLIB::*BLACK* NIL) (RPAQ? XLIB::*WHITE* NIL) (RPAQ? XLIB::*DEFAULTFONT* NIL) (RPAQ? XLIB::*DEFAULT-FONT-NAME* "FIXED") (RPAQ? XLIB::*GC* NIL) (RPAQ? XLIB::*COLORMAP* NIL) (DECLARE%: EVAL@COMPILE (PUTPROPS \XCURVESMOOTH MACRO (OPENLAMBDA (NEWX NEWY USERFN DISPLAYSTREAM) (PROG [(DX (IABS (IDIFFERENCE NEWX \OLDX))) (DY (IABS (IDIFFERENCE NEWY \OLDY] (COND ((OR (IGREATERP DX 1) (IGREATERP DY 1)) [COND ((NEQ [IPLUS (ADD1 (IDIFFERENCE \OLDX \OLDERX)) (ITIMES 3 (ADD1 (IDIFFERENCE \OLDY \OLDERY] 4) [COND (DASHON (COND (USERFN (APPLY* USERFN \OLDX \OLDY DISPLAYSTREAM)) (T (DRAWPOINT \OLDX \OLDY BRUSHBM DISPLAYSTREAM] (COND (DASHTAIL (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] (SETQ \OLDERX \OLDX) (SETQ \OLDERY \OLDY) (SETQ \OLDX \CURX) (SETQ \OLDY \CURY))) (SETQ \CURX NEWX) (SETQ \CURY NEWY)))) ) (DEFINEQ (XLIB::SETUP-CLX [CL:LAMBDA (&OPTIONAL (XLIB:DISPLAY "unix:0.0")) (* ; "Edited 11-Sep-91 19:29 by jn") (CL:BLOCK XLIB::SETUP-CLX (LET ((XLIB::HOST-PORT (XSERVERNAME XLIB:DISPLAY))) (CL:SETQ XLIB::*DISPLAY* (XLIB:OPEN-DISPLAY (CAR XLIB::HOST-PORT) :DISPLAY (CDR XLIB::HOST-PORT))) (CL:SETQ XLIB::*SCREEN* (XLIB:DISPLAY-DEFAULT-SCREEN XLIB::*DISPLAY*)) (CL:SETQ XLIB::*BLACK* (XLIB:SCREEN-BLACK-PIXEL XLIB::*SCREEN*)) (CL:SETQ XLIB::*WHITE* (XLIB:SCREEN-WHITE-PIXEL XLIB::*SCREEN*)) (CL:SETQ XLIB::*COLORMAP* (XLIB:SCREEN-DEFAULT-COLORMAP XLIB::*SCREEN*)) (CL:SETQ XLIB::*ROOT* (XLIB:SCREEN-ROOT XLIB::*SCREEN*)) (CL:SETQ XLIB::*DEFAULTFONT* (XLIB:OPEN-FONT XLIB::*DISPLAY* XLIB::*DEFAULT-FONT-NAME*)) (CL:SETQ XLIB::*GC* (XLIB:CREATE-GCONTEXT :DRAWABLE XLIB::*ROOT*)) (CL:SETF (XLIB:DISPLAY-AFTER-FUNCTION XLIB::*DISPLAY*) #'XLIB:DISPLAY-FINISH-OUTPUT)))]) ) (DEFINEQ (\XDISPLAYINIT [LAMBDA NIL (DECLARE (GLOBALVARS XDisplayFDEV \XDISPLAYIMAGEOPS \XDisplayDeviceMethods \XDisplayDeviceData)) (* ; "Edited 16-Feb-91 15:03 by matsuda") (SETQ \XDisplayDeviceMethods (create WSOPS)) (SETQ \XDisplayDeviceData (create WSDATA WSDESTINATION _ "Destination" WSREGION _ (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 1024 HEIGHT _ 808))) (SETQ \XDISPLAYIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'XDISPLAY IMFONT _ (FUNCTION \DSPFONT.XDISPLAY) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.DISPLAY) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.DISPLAY) IMLINEFEED _ (FUNCTION \DSPLINEFEED.DISPLAY) IMXPOSITION _ (FUNCTION \DSPXPOSITION.DISPLAY) IMYPOSITION _ (FUNCTION \DSPYPOSITION.DISPLAY) IMCLOSEFN _ (FUNCTION NILL) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.XDISPLAY) IMFILLCIRCLE _ '\FILLCIRCLE.XDISPLAY IMDRAWLINE _ (FUNCTION \DRAWLINE.XDISPLAY) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.XDISPLAY) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.XDISPLAY) IMFILLPOLYGON _ (FUNCTION POLYSHADE.XDISPLAY) IMBITBLT _ (FUNCTION \BITBLT.XDISPLAY) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.XDISPLAY) IMBLTSHADE _ (FUNCTION \BLTSHADE.XDISPLAY) IMNEWPAGE _ (FUNCTION \NEWPAGE.XDISPLAY) IMSCALE _ [FUNCTION (LAMBDA NIL 1] IMSPACEFACTOR _ (FUNCTION NILL) IMFONTCREATE _ 'XDISPLAY IMCOLOR _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION \BACKCOLOR.XDISPLAY) IMOPERATION _ (FUNCTION \DSPOPERATION.XDISPLAY) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.XDISPLAY) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.XDISPLAY) IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.XDISPLAY) IMRESET _ (FUNCTION \DSPRESET.XDISPLAY) IMDRAWARC _ (FUNCTION \DRAWARC.XDISPLAY) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.XDISPLAY) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.XDISPLAY))) (SETQ XDisplayFDEV (create FDEV DEVICENAME _ 'XDISPLAY RESETABLE _ NIL RANDOMACCESSP _ NIL PAGEMAPPED _ NIL CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) NAME] READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) SETFILEINFO _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \GENERATENOFILES) TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV) NAME] REOPENFILE _ [FUNCTION (LAMBDA (NAME) NAME] EVENTFN _ (FUNCTION \XDisplayEventFn) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) BIN _ (FUNCTION \ILLEGAL.DEVICEOP) BOUT _ (FUNCTION \DSPPRINTCHAR) PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP) BACKFILEPTR _ (FUNCTION \PAGEDBACKFILEPTR) BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) WINDOWOPS _ \DisplayDeviceMethods WINDOWDATA _ \DisplayDeviceData DEVICEINFO _ (create DISPLAYSTATE))) (\DEFINEDEVICE 'XDISPLAY XDisplayFDEV]) (CREATEXSCREEN [LAMBDA (DESTINATION) (* ; "Edited 3-Oct-91 20:15 by jn") (PROG (TITLEDS SCREEN) (SETQ TITLEDS (XDSPCREATE DESTINATION)) (* ; "Create TITLEDS. ") (DSPOPERATION 'INVERT TITLEDS) (DSPFONT XWINDOWTITLEFONT TITLEDS) (DSPRIGHTMARGIN MAX.SMALLP TITLEDS) (* ;  "Set right margin so title doesn't autoCR. ") (* ;; "now create SCREEN. ") [SETQ SCREEN (create XSCREEN SCONOFF _ 'OFF SCDESTINATION _ DESTINATION SCTOPW _ NIL SCTITLEDS _ TITLEDS (* ;; "Cached fns.") \GETSCWIDTH _ '[LAMBDA (DATUM) (XLIB:DRAWABLE-WIDTH (fetch (XSCREEN SCDESTINATION ) of DATUM] \GETSCHEIGHT _ '[LAMBDA (DATUM) (XLIB:DRAWABLE-HEIGHT (fetch (XSCREEN SCDESTINATION ) of DATUM] \GETSCBITSPERPIXEL _ '(LAMBDA (DATUM) (XLIB:DRAWABLE-DEPTH (fetch (XSCREEN SCDESTINATION ) of DATUM] (RETURN SCREEN]) (BITSPERPIXEL [LAMBDA (BITMAP) (* ; "Edited 31-Jan-91 14:24 by matsuda") (* ;; "returns the height in pixels of a bitmap.") (COND ((type? BITMAP BITMAP) (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) ((XLIB:DRAWABLE-P BITMAP) (XLIB:DRAWABLE-DEPTH BITMAP)) ((type? SCREEN BITMAP) (BITSPERPIXEL (fetch (SCREEN SCDESTINATION) of BITMAP))) ((type? XSCREEN BITMAP) (BITSPERPIXEL (fetch (XSCREEN SCDESTINATION) of BITMAP))) ((type? WINDOW BITMAP) (BITSPERPIXEL (fetch (WINDOW SCREEN) of BITMAP))) ((ARRAYP BITMAP) (* ;  "Consider array to be a colormap.") (SELECTQ (ARRAYSIZE BITMAP) (256 8) (16 4) (LISPERROR "ILLEGAL ARG" BITMAP))) (T (LISPERROR "ILLEGAL ARG" BITMAP]) (BITMAPHEIGHT [LAMBDA (BITMAP) (* ; "Edited 17-Jul-91 08:44 by matsuda") (* ;; "returns the height in pixels of a bitmap.") (COND ((type? BITMAP BITMAP) (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) ((XLIB:DRAWABLE-P BITMAP) (XLIB:DRAWABLE-HEIGHT BITMAP)) ((type? WINDOW BITMAP) (WINDOWPROP BITMAP 'HEIGHT)) (T (\ILLEGAL.ARG BITMAP]) (BITMAPWIDTH [LAMBDA (BITMAP) (* ; "Edited 17-Jul-91 08:42 by matsuda") (* ;; "returns the width of a bitmap in pixels") (COND ((type? BITMAP BITMAP) (ffetch (BITMAP BITMAPWIDTH) of BITMAP)) ((XLIB:DRAWABLE-P BITMAP) (XLIB:DRAWABLE-WIDTH BITMAP)) ((type? WINDOW BITMAP) (WINDOWPROP BITMAP 'WIDTH)) (T (\ILLEGAL.ARG BITMAP]) (DSPDESTINATION [LAMBDA (DESTINATION DISPLAYSTREAM) (* ; "Edited 31-Jan-91 14:46 by matsuda") (DECLARE (GLOBALVARS \DISPLAYIMAGEOPS \4DISPLAYIMAGEOPS \8DISPLAYIMAGEOPS \24DISPLAYIMAGEOPS \XDISPLAYIMAGEOPS)) (PROG (DD) (SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM)) (RETURN (PROG1 (ffetch (\DISPLAYDATA DDDestination) of DD) [COND (DESTINATION (COND ((XLIB:DRAWABLE-P DESTINATION) (* ; "XDISPLAY case ") (UNINTERRUPTABLY (replace (STREAM DEVICE) of DISPLAYSTREAM with XDisplayFDEV) (replace (STREAM IMAGEOPS) of DISPLAYSTREAM with \XDISPLAYIMAGEOPS) (freplace (\DISPLAYDATA DDDestination) of DD with DESTINATION))) (T (* ; "LFDISPLAY case") (SETQ DESTINATION (\DTEST DESTINATION 'BITMAP)) (UNINTERRUPTABLY (replace (STREAM DEVICE) of DISPLAYSTREAM with (SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL ) of DESTINATION) (1 DisplayFDEV) (4 \4DISPLAYFDEV) (8 \8DISPLAYFDEV) (24 \24DISPLAYFDEV) (SHOULDNT))) (replace (STREAM IMAGEOPS) of DISPLAYSTREAM with (SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL ) of DESTINATION) (1 \DISPLAYIMAGEOPS) (4 \4DISPLAYIMAGEOPS) (8 \8DISPLAYIMAGEOPS) (24 \24DISPLAYIMAGEOPS) (SHOULDNT))) (freplace (\DISPLAYDATA DDDestination) of DD with DESTINATION) (\SFFixDestination DD DISPLAYSTREAM))])]) (XDSPCREATE [LAMBDA (DESTINATION) (* ; "Edited 15-Feb-91 18:29 by matsuda") (LET (DSTRM GC) (COND ((XLIB:DRAWABLE-P DESTINATION) (SETQ DSTRM (create STREAM USERCLOSEABLE _ NIL OUTCHARFN _ (FUNCTION \XDSPPRINTCHAR) IMAGEDATA _ (create \DISPLAYDATA) IMAGEOPS _ \XDISPLAYIMAGEOPS DEVICE _ XDisplayFDEV ACCESS _ 'OUTPUT)) (replace (\DISPLAYDATA DDPILOTBBT) of (fetch (STREAM IMAGEDATA) of DSTRM) with (SETQ GC (XLIB:CREATE-GCONTEXT :DRAWABLE DESTINATION))) (CL:SETF (XLIB:GCONTEXT-FOREGROUND GC) XLIB::*BLACK*) (* ; "temp foreground color ") (CL:SETF (XLIB:GCONTEXT-BACKGROUND GC) XLIB::*WHITE*) (* ; "temp background color") (DSPFONT XDEFAULTFONT DSTRM) (DSPDESTINATION DESTINATION DSTRM) (DSPRIGHTMARGIN (MAX SCREENWIDTH (XLIB:DRAWABLE-WIDTH DESTINATION)) DSTRM) (DSPSOURCETYPE 'INPUT DSTRM) (DSPOPERATION 'REPLACE DSTRM) DSTRM) (T NIL]) (\DSPOPERATION.XDISPLAY [LAMBDA (DISPLAYSTREAM OPERATION) (* ; "Edited 15-Feb-91 12:32 by matsuda") (* ;; "sets the operation field of a display stream") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (fetch DDOPERATION of DD) [COND (OPERATION (OR (FMEMB OPERATION '(PAINT REPLACE INVERT ERASE)) (LISPERROR "ILLEGAL ARG" OPERATION)) (UNINTERRUPTABLY (freplace DDOPERATION of DD with OPERATION) (\SETGCFUNCTION (fetch DDPILOTBBT of DD) (fetch DDSOURCETYPE of DD) OPERATION))])]) (\DSPRESET.XDISPLAY [LAMBDA (DISPLAYSTREAM) (DECLARE (GLOBALVARS \CURRENTDISPLAYLINE)) (* ; "Edited 22-Feb-91 17:41 by matsuda") (LET [CREG FONT FONTASCENT (DD (\DTEST (fetch (STREAM IMAGEDATA) of (SETQ DISPLAYSTREAM (\OUTSTREAMARG DISPLAYSTREAM))) '\DISPLAYDATA] (SETQ CREG (ffetch (\DISPLAYDATA DDClippingRegion) of DD)) (SETQ FONT (fetch (\DISPLAYDATA DDFONT) of DD)) (SETQ FONTASCENT (FONTASCENT FONT)) (SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT) (0 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (ffetch (\DISPLAYDATA DDLeftMargin) of DD)) (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (ADD1 (IDIFFERENCE (fetch (REGION TOP) of CREG) FONTASCENT)))) (ERROR "only supported rotations are 0")) (CL:SETF (XLIB:GCONTEXT-FOREGROUND XLIB::*GC*) XLIB::*WHITE*) (XLIB:DRAW-RECTANGLE (fetch (\DISPLAYDATA DDDestination) of DD) XLIB::*GC* (\DSPTRANSFORMX (fetch (REGION LEFT) of CREG) DD) (\DSPTRANSFORMY (fetch (REGION BOTTOM) of CREG) DD) (fetch (REGION WIDTH) of CREG) (fetch (REGION HEIGHT) of CREG) T) (* ; "(BITBLT NIL NIL NIL DISPLAYSTREAM (fetch (REGION LEFT) of CREG) (fetch (REGION BOTTOM) of CREG) (fetch (REGION WIDTH) of CREG) (fetch (REGION HEIGHT) of CREG) 'TEXTURE 'REPLACE (ffetch (\DISPLAYDATA DDTexture) of DD))") (* ;; "if this display stream is the tty display stream of a process, reset the # of lines in that process.") (PROG ((X (WFROMDS DISPLAYSTREAM T))) (COND ((AND X (SETQ X (WINDOWPROP X 'PROCESS)) (EQ (PROCESS.TTY X) DISPLAYSTREAM)) (PROCESS.EVAL X '(SETQ \CURRENTDISPLAYLINE 0]) (\BLTSHADE.XDISPLAY [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 28-Feb-91 13:08 by matsuda") (* ; "BLTSHADE to a display stream") (DECLARE (LOCALVARS . T)) (PROG (left top bottom right DESTINATIONBITMAP DESTDD DESTINATIONNBITS GC PIXMAP ORGFUNCTION) (SETQ DESTDD (fetch (STREAM IMAGEDATA) of STREAM)) (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DESTDD)) (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) [PROGN (* ;  "compute limits based on clipping regions.") (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) (SETQ right (fetch (\DISPLAYDATA DDClippingRight) of DESTDD)) (SETQ top (fetch (\DISPLAYDATA DDClippingTop) of DESTDD)) (COND (CLIPPINGREGION (* ;  "hard case, two destination clipping regions: do calculations to merge them.") (PROG (CRLEFT CRBOTTOM) [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX (fetch (REGION LEFT) of CLIPPINGREGION) DESTDD] [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY (fetch (REGION BOTTOM) of CLIPPINGREGION) DESTDD] [SETQ right (IMIN right (IPLUS CRLEFT (fetch (REGION WIDTH) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT) of CLIPPINGREGION] (SETQ DESTINATIONBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD)) (SETQ DESTINATIONNBITS (BITSPERPIXEL DESTINATIONBITMAP)) (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) (LITATOM (COND ((NULL TEXTURE) (* ;  "NIL case. default texture to background texture.") (ffetch (\DISPLAYDATA DDTexture) of DESTDD)) (T (\ILLEGAL.ARG TEXTURE)))) ((SMALLP FIXP) (LOGAND TEXTURE 65535)) (BITMAP TEXTURE) (\ILLEGAL.ARG TEXTURE))) (SETQ PIXMAP (PIXMAPFROMTEXTURE TEXTURE)) (SETQ ORGFUNCTION (XLIB:GCONTEXT-FUNCTION GC)) (CL:SETF (XLIB:GCONTEXT-FUNCTION GC) (SELECTQ (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)) (REPLACE CL:BOOLE-1) (PAINT CL:BOOLE-IOR) (INVERT CL:BOOLE-XOR) (ERASE CL:BOOLE-ANDC1) CL:BOOLE-1)) (CL:SETF (XLIB:GCONTEXT-TILE GC) PIXMAP) (CL:SETF (XLIB:GCONTEXT-FILL-STYLE GC) :TILED) (PROG (Y WIDTH HEIGHT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTINATIONBITMAP) top)) (XLIB:DRAW-RECTANGLE DESTINATIONBITMAP GC left Y WIDTH HEIGHT :FILL-P T)) (CL:SETF (XLIB:GCONTEXT-FUNCTION GC) ORGFUNCTION) (RETURN T]) (\BITBLT.XDISPLAY [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (DECLARE (LOCALVARS . T)) (* ; "Edited 17-Jul-91 10:37 by matsuda") (PROG (stodx stody left top bottom right DESTDD DESTBITMAP DESTINATIONNBITS SOURCENBITS MAXSHADE) (SETQ DESTDD (fetch (STREAM IMAGEDATA) of DESTSTRM)) (SETQ DESTBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD)) (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) [PROGN (* ;  "compute limits based on clipping regions.") (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) (SETQ right (fetch (\DISPLAYDATA DDClippingRight) of DESTDD)) (SETQ top (fetch (\DISPLAYDATA DDClippingTop) of DESTDD)) (COND (CLIPPINGREGION (* ;  "hard case, two destination clipping regions: do calculations to merge them.") (PROG (CRLEFT CRBOTTOM) [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX (fetch (REGION LEFT) of CLIPPINGREGION) DESTDD] [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY (fetch (REGION BOTTOM) of CLIPPINGREGION) DESTDD] [SETQ right (IMIN right (IPLUS CRLEFT (fetch (REGION WIDTH) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT) of CLIPPINGREGION] [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (* ; "Clip and translate coordinates.") (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) [PROGN (* ; "compute left margin") (SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx) 0)) (* ; "compute bottom margin") (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody) 0)) (* ; "compute right margin") (SETQ right (IMIN (BITMAPWIDTH SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))) (PROG (GC HEIGHT WIDTH DTY DLX STY SLX) (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DESTDD)) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTBITMAP) (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (IDIFFERENCE (BITMAPWIDTH SOURCEBITMAP) top)) (SETQ SLX left) (\XBITBLTSUB GC SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE)) (RETURN T]) (\XBITBLTSUB [LAMBDA (GC SourceBitMap SLX STY DestinationDrawable DLX DTY WIDTH HEIGHT SourceType Operation Texture WindowXOffset WindowYOffset) (* ; "Edited 17-Jul-91 08:31 by matsuda") (CL:SETF (XLIB:GCONTEXT-FUNCTION GC) (SELECTQ SourceType (INVERT (SELECTQ SourceType (PAINT CL:BOOLE-ORC1) (INVERT CL:BOOLE-EQV) (ERASE CL:BOOLE-AND) CL:BOOLE-C1)) (SELECTQ Operation (PAINT CL:BOOLE-IOR) (INVERT CL:BOOLE-XOR) (ERASE CL:BOOLE-ANDC1) CL:BOOLE-1))) (SELECTQ (TYPENAME SourceBitMap) (BITMAP [PROG (XIMAGE) (SETQ XIMAGE (XIMAGEFROMBITMAP SourceBitMap)) (COND ((EQ (BITSPERPIXEL SourceBitMap) 1) (XLIB:PUT-IMAGE DestinationDrawable GC XIMAGE :SRC-X SLX :SRC-Y STY :X DLX :Y DTY :HEIGHT HEIGHT :WIDTH WIDTH :BITMAP-P T)) (T (XLIB:PUT-IMAGE DestinationDrawable GC XIMAGE :SRC-X SLX :SRC-Y STY :X DLX :Y DTY :HEIGHT HEIGHT :WIDTH WIDTH]) ((XLIB:WINDOW XLIB:PIXMAP) (XLIB:COPY-AREA SourceBitMap GC SLX STY WIDTH HEIGHT DestinationDrawable DLX DTY)) NIL]) (\XBLTSHADE.PIXMAP [LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (DECLARE (LOCALVARS . T)) (* ; "Edited 6-Mar-91 17:09 by matsuda") (PROG (left bottom top right PIXMAP) (SETQ left 0) (SETQ bottom 0) (SETQ top (PIXMAPHEIGHT DESTINATIONBITMAP)) (SETQ right (PIXMAPWIDTH DESTINATIONBITMAP)) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) (LITATOM (* ; "includes NIL case") (COND ((NULL TEXTURE) WHITESHADE) (T (\ILLEGAL.ARG TEXTURE)))) ((SMALLP FIXP) (LOGAND TEXTURE BLACKSHADE)) (BITMAP TEXTURE) (\ILLEGAL.ARG TEXTURE))) (SETQ PIXMAP (PIXMAPFROMTEXTURE TEXTURE)) (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) (SELECTQ OPERATION (REPLACE CL:BOOLE-1) (PAINT CL:BOOLE-IOR) (INVERT CL:BOOLE-XOR) (ERASE CL:BOOLE-ANDC1) CL:BOOLE-1)) (CL:SETF (XLIB:GCONTEXT-TILE XLIB::*GC*) PIXMAP) (CL:SETF (XLIB:GCONTEXT-FILL-STYLE XLIB::*GC*) :TILED) (PROG (Y WIDTH HEIGHT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTINATIONBITMAP) top)) (XLIB:DRAW-RECTANGLE DESTINATIONBITMAP XLIB::*GC* left Y WIDTH HEIGHT :FILL-P T)) (RETURN T]) (\XBITBLT.PIXMAP [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (DECLARE (LOCALVARS . T)) (* ; "Edited 17-Jul-91 08:46 by matsuda") (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS) (SETQ top (PIXMAPHEIGHT DESTBITMAP)) (SETQ left 0) (SETQ bottom 0) (SETQ SOURCENBITS (BITSPERPIXEL SOURCEBITMAP)) (SETQ right (PIXMAPWIDTH DESTBITMAP)) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (* ; "Clip and translate coordinates.") (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) [PROGN (* ; "compute left margin") (SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx))) (* ; "compute bottom margin") (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody))) (* ; "compute right margin") (SETQ right (IMIN (BITMAPWIDTH SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SELECTQ SOURCETYPE (MERGE (\ILLEGAL.ARG TEXTURE)) NIL) (COND ((OR (XLIB:DRAWABLE-P SOURCEBITMAP) (EQ SOURCENBITS 1)) (PROG (HEIGHT WIDTH DTY DLX STY SLX) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTBITMAP) (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (\SFInvert SOURCEBITMAP top)) (SETQ SLX left) (\XBITBLTSUB XLIB::*GC* SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE))) (T (ERROR "Source bitmap should not color bitmaps." SOURCEBITMAP))) (RETURN T]) (\DRAWPOINT.XDISPLAY [LAMBDA (DISPLAYSTREAM X Y BRUSH OPERATION) (* ; "Edited 17-Jul-91 10:43 by matsuda") (PROG ((BRUSHBM (XPIXMAPFROMBRUSH BRUSH))) (RETURN (BITBLT BRUSHBM 0 0 DISPLAYSTREAM [IDIFFERENCE X (HALF (SUB1 (BITMAPWIDTH BRUSHBM] [IDIFFERENCE Y (HALF (SUB1 (BITMAPHEIGHT BRUSHBM] NIL NIL NIL (SELECTQ (OR OPERATION (DSPOPERATION NIL DISPLAYSTREAM)) (REPLACE 'PAINT) OPERATION]) (\DRAWLINE.XDISPLAY [LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 16-Jul-91 13:20 by matsuda") [COND [(OR DASHING (BRUSHP WIDTH)) (LET ((BRUSH (INSURE.BRUSH WIDTH))) (if COLOR then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR)) (\XLINEWITHBRUSH X1 Y1 X2 Y2 BRUSH (\GOOD.DASHLST DASHING BRUSH) DISPLAYSTREAM (SELECTQ OPERATION (NIL (ffetch DDOPERATION of (fetch IMAGEDATA of DISPLAYSTREAM ))) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION] (T (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)) X Y DRAWABLE GC) (SETQ DRAWABLE (fetch (\DISPLAYDATA DDDestination) of DD)) (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DD)) (SETQ X1 (\DSPTRANSFORMX (OR (FIXP X1) (FIXR X1)) DD)) (SETQ Y1 (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DRAWABLE) (\DSPTRANSFORMY (OR (FIXP Y1) (FIXR Y1)) DD))) (SETQ X (\DSPTRANSFORMX (OR (FIXP X2) (FIXR X2)) DD)) (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DRAWABLE) (\DSPTRANSFORMY (OR (FIXP Y2) (FIXR Y2)) DD))) (SETQ OPERATION (SELECTQ OPERATION (NIL (ffetch DDOPERATION of DD)) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION))) (CL:SETF (XLIB:GCONTEXT-FUNCTION GC) (SELECTQ OPERATION (REPLACE CL:BOOLE-1) (PAINT CL:BOOLE-IOR) (INVERT CL:BOOLE-XOR) (ERASE CL:BOOLE-ANDC1) CL:BOOLE-1)) [CL:SETF (XLIB:GCONTEXT-LINE-WIDTH GC) (COND ((NULL WIDTH) 1) ((OR (FIXP WIDTH) (FIXR WIDTH] (CL:SETF (XLIB:GCONTEXT-JOIN-STYLE GC) :ROUND) (CL:SETF (XLIB:GCONTEXT-CAP-STYLE GC) :ROUND) (XLIB:DRAW-LINE DRAWABLE GC X1 Y1 X Y] (MOVETO X2 Y2 DISPLAYSTREAM]) (\XLINEWITHBRUSH [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST DISPLAYSTREAM OPERATION) (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Jul-91 13:38 by matsuda") (PROG (DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL (DASHON T) (DASHTAIL DASHLST) (DASHCNT (CAR DASHLST)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))) (* ;  "arrange things so that dx is positive.") (COND ((IGREATERP X1 X2) (* ; "switch points") (swap X1 X2) (swap Y1 Y2))) (SETQ DX (ADD1 (IDIFFERENCE X2 X1))) [SETQ DY (ADD1 (COND ((IGREATERP Y2 Y1) (SETQ YINC 1) (IDIFFERENCE Y2 Y1)) (T (SETQ YINC -1) (IDIFFERENCE Y1 Y2] [SETQ CDL (HALF (COND ((IGREATERP DX DY) (* ;  "set up the bucket so that the ends will be the same.") (IREMAINDER DX DY)) (T (IREMAINDER DY DX] [COND [USERFN (* ;  "if user function is being called, don't bother bringing window to top uninterruptably.") (COND ((IGEQ DX DY) (* ; "X is the fastest mover.") (until (IGREATERP X1 X2) do (* ; "main loop") (COND (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ((NOT (IGREATERP DX (add CDL DY))) (add Y1 YINC) (COND ((COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX] (add X1 1))) (T (* ; "Y is the fastest mover.") (until (COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) do (* ; "main loop") (COND (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (COND ((IGREATERP (SETQ X1 (ADD1 X1)) X2) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY] (add Y1 YINC] (T (* ;  "when we put the points down make it uninterruptable") (COND [(IGEQ DX DY) (* ; "X is the fastest mover.") (until (IGREATERP X1 X2) do (* ; "main loop") (COND (DASHON (DRAWPOINT X1 Y1 BRUSH DISPLAYSTREAM OPERATION))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (SETQ Y1 (IPLUS Y1 YINC)) (COND ((COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX] (SETQ X1 (ADD1 X1] (T (* ; "Y is the fastest mover.") (until (COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) do (* ; "main loop") (COND (DASHON (DRAWPOINT X1 Y1 BRUSH DISPLAYSTREAM OPERATION))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (COND ((IGREATERP (SETQ X1 (ADD1 X1)) X2) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY] (SETQ Y1 (IPLUS Y1 YINC] (RETURN NIL]) (\DRAWCIRCLE.XDISPLAY [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING) (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Jul-91 14:59 by matsuda") (COND ((OR (NOT (NUMBERP RADIUS)) (ILESSP (SETQ RADIUS (FIXR RADIUS)) 0)) (\ILLEGAL.ARG RADIUS)) ((EQ RADIUS 0) NIL) (DASHING (DRAWCURVE (CDR (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS 0 360)) T BRUSH DASHING DISPLAYSTREAM)) (T (PROG (X Y D DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION HEIGHTMINUS1 CX CY BBT COLOR COLORBRUSHBASE NBITS DISPLAYDATA USERFN) (SETQ X 0) (SETQ Y RADIUS) (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (SETQ USERFN (AND (LITATOM BRUSH) BRUSH)) (SETQ CX CENTERX) (SETQ CY CENTERY) [COND ((EQ RADIUS 1) (COND (USERFN (APPLY* USERFN CX CY DISPLAYSTREAM)) (T (DRAWPOINT CX CY BRUSH DISPLAYSTREAM))) (RETURN)) (T (COND (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS) DISPLAYSTREAM) (APPLY* USERFN CX (IDIFFERENCE CY RADIUS) DISPLAYSTREAM)) (T (DRAWPOINT CX (IPLUS CY RADIUS) BRUSH DISPLAYSTREAM) (DRAWPOINT CX (IDIFFERENCE CY RADIUS) BRUSH DISPLAYSTREAM] LP [COND [(IGREATERP 0 D) (SETQ X (ADD1 X)) (COND ((IGREATERP (UNFOLD (IPLUS D Y) 2) 1) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (IPLUS D (UNFOLD X 2) 1] ((OR (EQ 0 D) (IGREATERP X D)) (SETQ X (ADD1 X)) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) 3)) (SETQ Y (SUB1 Y] (COND [(EQ Y 0) (COND (USERFN (APPLY* USERFN (IPLUS CX X) CY DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) CY DISPLAYSTREAM)) (T (DRAWPOINT (IPLUS CX X) CY BRUSH DISPLAYSTREAM) (DRAWPOINT (IDIFFERENCE CX X) CY BRUSH DISPLAYSTREAM] (T (COND (USERFN (APPLY* USERFN (IPLUS CX X) (IPLUS CY Y) DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) (IPLUS CY Y) DISPLAYSTREAM) (APPLY* USERFN (IPLUS CX X) (IDIFFERENCE CY Y) DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) (IDIFFERENCE CY Y) DISPLAYSTREAM)) (T (DRAWPOINT (IPLUS CX X) (IPLUS CY Y) BRUSH DISPLAYSTREAM) (DRAWPOINT (IDIFFERENCE CX X) (IPLUS CY Y) BRUSH DISPLAYSTREAM) (DRAWPOINT (IPLUS CX X) (IDIFFERENCE CY Y) BRUSH DISPLAYSTREAM) (DRAWPOINT (IDIFFERENCE CX X) (IDIFFERENCE CY Y) BRUSH DISPLAYSTREAM))) (GO LP))) (MOVETO CENTERX CENTERY DISPLAYSTREAM) (RETURN NIL]) (\DRAWCURVE.XDISPLAY [LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 16-Jul-91 17:04 by matsuda") (PROG ((DASHLST (\GOOD.DASHLST DASHING BRUSH))) (SELECTQ (LENGTH KNOTS) (0 (* ;  "No knots => empty curve rather than error?") NIL) (1 (* ;  "only one knot, put down a brush shape") (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (\DRAWPOINT.DISPLAY DISPLAYSTREAM (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) BRUSH)) (2 (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (OR (type? POSITION (CADR KNOTS)) (ERROR "bad knot" (CADR KNOTS))) (\XLINEWITHBRUSH (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) (fetch XCOORD of (CADR KNOTS)) (fetch YCOORD of (CADR KNOTS)) BRUSH DASHLST DISPLAYSTREAM)) (\XCURVE2 (PARAMETRICSPLINE KNOTS CLOSED) BRUSH DASHLST DISPLAYSTREAM)) (RETURN DISPLAYSTREAM]) (\XCURVE2 [LAMBDA (SPLINE BRUSH DASHLST DISPLAYSTREAM) (DECLARE (SPECVARS . T)) (* ; "Edited 16-Jul-91 17:16 by matsuda") (PROG (BRUSHBM DestinationBitMap OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS \CURX \CURY \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T) (DASHTAIL DASHLST) (DASHCNT (CAR DASHLST)) NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX DY DDY DDDY (XPOLY (create POLYNOMIAL)) (X/PRIME/POLY (create POLYNOMIAL)) (YPOLY (create POLYNOMIAL)) (Y/PRIME/POLY (create POLYNOMIAL)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH))) (SETQ BRUSHBM (\GETBRUSH BRUSH)) (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE) 1) (ELT (fetch (SPLINE SPLINEY) of SPLINE) 1)) [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) when (PROGN (* ;;  "Loop thru the segments of the spline curve, drawing each in turn.") (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) KNOT)) (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE) KNOT)) (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE) (ADD1 KNOT))) (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE) (ADD1 KNOT))) (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE) KNOT)) (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE) KNOT)) (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE) KNOT)) (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE) KNOT)) (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE) KNOT)) (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE) KNOT)) (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0)) (IABS (IDIFFERENCE Y1 Y0))) 3) 2)) (NOT (ZEROP NPOINTS))) do [COND ((ILEQ NPOINTS 64) (SETQ NSEGS 1) (SETQ POINTSPERSEG NPOINTS)) (T (SETQ NSEGS (FOLDLO NPOINTS 64)) (SETQ POINTSPERSEG 64) (SETQ NPOINTS (UNFOLD NSEGS 64] (SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (SETQ D2 (FTIMES D1 D1)) (SETQ D3 (FTIMES D2 D1)) (SETQ D3X (FTIMES D3 DDDX)) (SETQ D3Y (FTIMES D3 DDDY)) (COND [(EQ NSEGS 1) [SETQ DX (FPLUS (FTIMES D1 DX) (FTIMES DDX D2 0.5) (FTIMES DDDX D3 (CONSTANT (FQUOTIENT 1.0 6.0] (SETQ D2X (FPLUS (FTIMES D2 DDX) (FTIMES D3 DDDX))) [SETQ DY (FPLUS (FTIMES D1 DY) (FTIMES D2 DDY 0.5) (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] (SETQ D2Y (FPLUS (FTIMES D2 DDY) (FTIMES D3 DDDY))) (COND (USERFN (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DISPLAYDATA NIL NIL USERFN DISPLAYSTREAM)) (T (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DISPLAYDATA NIL NIL NIL DISPLAYSTREAM] (T (SETQ PERSEG (FQUOTIENT 1.0 NSEGS)) (LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0) (LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0) (bind (TT _ 0.0) (DDDX/PER/SEG _ (FTIMES DDDX PERSEG)) (DDDY/PER/SEG _ (FTIMES DDDY PERSEG)) [D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0] [D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I from 0 to (SUB1 NSEGS) do (SETQ TT (FPLUS TT PERSEG)) (SETQ X1 (POLYEVAL TT XPOLY 3)) (SETQ Y1 (POLYEVAL TT YPOLY 3)) (SETQ DX (FPLUS (FTIMES D1 DX) (FTIMES D2 DDX 0.5) D3XFACTOR)) (SETQ D2X (FPLUS (FTIMES D2 DDX) (FTIMES D3 DDDX))) (SETQ DY (FPLUS (FTIMES D1 DY) (FTIMES D2 DDY 0.5) D3YFACTOR)) (SETQ D2Y (FPLUS (FTIMES D2 DDY) (FTIMES D3 DDDY))) (COND (USERFN (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM DISPLAYDATA NIL NIL USERFN DISPLAYSTREAM) ) (T (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM DISPLAYDATA NIL NIL NIL DISPLAYSTREAM))) (SETQ X0 X1) (SETQ Y0 Y1) (SETQ DDX (FPLUS DDX DDDX/PER/SEG)) (SETQ DDY (FPLUS DDY DDDY/PER/SEG)) (SETQ DX (POLYEVAL TT X/PRIME/POLY 2)) (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2] (COND (USERFN (\XCURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA NIL T USERFN DISPLAYSTREAM)) (T (\XCURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA NIL T NIL DISPLAYSTREAM]) (\XCURVE [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DISPLAYDATA BBT ENDING USERFN DISPLAYSTREAM) (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Jul-91 16:57 by matsuda") (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY) [COND ((NEQ N 0) (SETQ OLDX X0) (SETQ OLDY Y0) (\XCURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM) (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49))) (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49))) (SETQ DX (\CONVERTTOFRACTION DX)) (SETQ DY (\CONVERTTOFRACTION DY)) (SETQ DDX (\CONVERTTOFRACTION DDX)) (SETQ DDY (\CONVERTTOFRACTION DDY)) (SETQ DDDX (\CONVERTTOFRACTION DDDX)) (SETQ DDDY (\CONVERTTOFRACTION DDDY)) [for I from 1 to N do (\BOXIPLUS X DX) (\BOXIPLUS DX DDX) (\BOXIPLUS DDX DDDX) (\BOXIPLUS Y DY) (\BOXIPLUS DY DDY) (\BOXIPLUS DDY DDDY) (SETQ OOLDX OLDX) (SETQ OOLDY OLDY) (SETQ DELTAX (IDIFFERENCE (SETQ OLDX ( \GETINTEGERPART X)) OOLDX)) (SETQ DELTAY (IDIFFERENCE (SETQ OLDY ( \GETINTEGERPART Y)) OOLDY)) (SETQ DELTA (IMAX (IABS DELTAX) (IABS DELTAY))) (COND ((EQ DELTA 1) (\XCURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM) )) (COND ((IGREATERP DELTA 1) (SETQ DELTAX (\CONVERTTOFRACTION (FQUOTIENT DELTAX DELTA ))) (SETQ DELTAY (\CONVERTTOFRACTION (FQUOTIENT DELTAY DELTA ))) (SETQ TX (\CONVERTTOFRACTION OOLDX)) (SETQ TY (\CONVERTTOFRACTION OOLDY)) (for I from 0 to DELTA do (\XCURVESMOOTH (\GETINTEGERPART TX) (\GETINTEGERPART TY) USERFN DISPLAYSTREAM) (\BOXIPLUS TX DELTAX) (\BOXIPLUS TY DELTAY] (COND (USERFN (\XCURVESMOOTH X1 Y1 USERFN DISPLAYSTREAM)) (T (\XCURVESMOOTH X1 Y1 NIL DISPLAYSTREAM))) (AND DISPLAYSTREAM (MOVETO X1 Y1 DISPLAYSTREAM] (COND (ENDING (\XCURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) (IPLUS \CURY \CURY (IMINUS \OLDY)) USERFN DISPLAYSTREAM) (\XCURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) (IPLUS \CURY \CURY (IMINUS \OLDY)) USERFN DISPLAYSTREAM))) (RETURN NIL]) ) (DEFINEQ (BITBLT [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) (* ; "Edited 17-Jul-91 08:49 by matsuda") (DECLARE (LOCALVARS . T)) (* ;; "IRM defined defaults") (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) (COND [(EQ SOURCETYPE 'TEXTURE) (COND ((type? BITMAP DESTINATION) (\BLTSHADE.BITMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)) ((XLIB:DRAWABLE-P DESTINATION) (\XBLTSHADE.PIXMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)) (T (PROG ((STREAM (\OUTSTREAMARG DESTINATION))) (RETURN (IMAGEOP 'IMBLTSHADE STREAM TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION] (T (PROG (SOURCEDD SOURCEBM CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) [COND [(OR (type? BITMAP SOURCE) (XLIB:DRAWABLE-P SOURCE)) (OR SOURCELEFT (SETQ SOURCELEFT 0)) (OR SOURCEBOTTOM (SETQ SOURCEBOTTOM 0)) (SETQ SOURCEBM SOURCE) (SETQ CLIPPEDSOURCELEFT SOURCELEFT) (SETQ CLIPPEDSOURCEBOTTOM SOURCEBOTTOM) (* ;  "limit the WIDTH and HEIGHT to the source size.") [SETQ WIDTH (COND (WIDTH (IMIN WIDTH (IDIFFERENCE (BITMAPWIDTH SOURCE) SOURCELEFT))) (T (BITMAPWIDTH SOURCE] (SETQ HEIGHT (COND (HEIGHT (IMIN HEIGHT (IDIFFERENCE (BITMAPHEIGHT SOURCE) SOURCEBOTTOM))) (T (BITMAPHEIGHT SOURCE] ((SETQ SOURCEDD (\GETDISPLAYDATA SOURCE)) [OR SOURCELEFT (SETQ SOURCELEFT (fetch (REGION LEFT) of (ffetch (\DISPLAYDATA DDClippingRegion) of SOURCEDD] [OR SOURCEBOTTOM (SETQ SOURCEBOTTOM (fetch (REGION BOTTOM) of (ffetch (\DISPLAYDATA DDClippingRegion ) of SOURCEDD ] (* ;  "do transformations coming out of source") (SETQ SOURCEBM (fetch (\DISPLAYDATA DDDestination) of SOURCEDD)) (SETQ CLIPPEDSOURCELEFT (IMAX (SETQ SOURCELEFT (\DSPTRANSFORMX SOURCELEFT SOURCEDD)) (fetch (\DISPLAYDATA DDClippingLeft) of SOURCEDD))) (SETQ CLIPPEDSOURCEBOTTOM (IMAX (SETQ SOURCEBOTTOM (\DSPTRANSFORMY SOURCEBOTTOM SOURCEDD)) (fetch (\DISPLAYDATA DDClippingBottom) of SOURCEDD))) (* ;  "limit the WIDTH and HEIGHT by the source dimensions.") [SETQ WIDTH (COND (WIDTH (IMIN WIDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of SOURCEDD) CLIPPEDSOURCELEFT))) (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of SOURCEDD) CLIPPEDSOURCELEFT] [SETQ HEIGHT (COND (HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop ) of SOURCEDD) CLIPPEDSOURCEBOTTOM))) (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop) of SOURCEDD) CLIPPEDSOURCEBOTTOM] (* ;  "if texture is not given, use the display stream's.") (OR TEXTURE (SETQ TEXTURE (ffetch (\DISPLAYDATA DDTexture) of SOURCEDD] (COND ((OR (IGEQ 0 WIDTH) (IGEQ 0 HEIGHT)) (* ;  "if either width or height is 0, don't do anything.") (RETURN))) (RETURN (COND [(type? BITMAP DESTINATION) (COND ((WINDOWP SOURCE) (* ;; "bring source window to the top. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE) (\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM))) (T (\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM] ((XLIB:DRAWABLE-P DESTINATION) (\XBITBLT.PIXMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)) (T (PROG (STREAM) (SETQ STREAM (\OUTSTREAMARG DESTINATION)) (COND ((AND (NEQ SOURCE DESTINATION) (WINDOWP SOURCE)) (* ;; "both source and destination are windows, see if they overlap and use an intermediate bitmap. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") [COND ((WINDOWP DESTINATION) (COND ((WOVERLAPP SOURCE DESTINATION) (RETURN (PROG (SCRATCHBM) (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE) (BITBLT SOURCEBM SOURCELEFT SOURCEBOTTOM (SETQ SCRATCHBM (BITMAPCREATE WIDTH HEIGHT)) 0 0 WIDTH HEIGHT 'INPUT 'REPLACE)) (RETURN (BITBLT SCRATCHBM 0 0 STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION] (* ;  "bring the source to the top. this should be done uninterruptably but is better than nothing.") (TOTOPW SOURCE))) (IMAGEOP 'IMBITBLT STREAM SOURCEBM SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM]) ) (DEFINEQ (XCREATEWFROMPIXMAP [LAMBDA (PIXMAP SCREEN) (* ; "Edited 7-Mar-91 16:39 by matsuda") (PROG (WINDOW WIDTH HEIGHT) (SETQ WINDOW (XCREATEW (create SCREENREGION SCREEN _ (\INSURESCREEN SCREEN) LEFT _ 0 BOTTOM _ 0 WIDTH _ (SETQ WIDTH (PIXMAPWIDTH PIXMAP)) HEIGHT _ (SETQ HEIGHT (PIXMAPHEIGHT PIXMAP))) NIL 0 T)) (WINDOWPROP WINDOW 'MINSIZE (CONS (IMIN MinWindowWidth WIDTH) (IMIN MinWindowWidth HEIGHT))) (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) CL:BOOLE-1) (XLIB:COPY-AREA PIXMAP XLIB::*GC* 0 0 WIDTH HEIGHT (fetch (WINDOW SAVE) of WINDOW) 0 0) (RETURN WINDOW]) (PIXMAPCREATE [LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* ; "Edited 6-Mar-91 17:25 by matsuda") (PROG NIL (SETQ BITSPERPIXEL (\INSUREBITSPERPIXEL BITSPERPIXEL)) (RETURN (XLIB:CREATE-PIXMAP :WIDTH WIDTH :HEIGHT HEIGHT :DEPTH BITSPERPIXEL :DRAWABLE XLIB::*ROOT*]) (PIXMAPWIDTH [LAMBDA (PIXMAP) (* ; "Edited 6-Mar-91 16:34 by matsuda") (COND ((XLIB:DRAWABLE-P PIXMAP) (XLIB:DRAWABLE-WIDTH PIXMAP)) ((type? WINDOW PIXMAP) (WINDOWPROP PIXMAP 'WIDTH)) (T (\ILLEGAL.ARG PIXMAP]) (PIXMAPHEIGHT [LAMBDA (PIXMAP) (* ; "Edited 6-Mar-91 16:37 by matsuda") (COND ((XLIB:DRAWABLE-P PIXMAP) (XLIB:DRAWABLE-HEIGHT PIXMAP)) ((type? WINDOW PIXMAP) (WINDOWPROP PIXMAP 'HEIGHT)) (T (\ILLEGAL.ARG PIXMAP]) ) (DEFINEQ (XCREATEW [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG) (* ; "Edited 10-Apr-91 14:02 by matsuda") (* ;; "creates and returns a window.") (PROG (SCREEN REG DSP DISPLAYDATA TITLEHEIGHT WINDOW WBORDER) (SETQ WBORDER (COND ((NUMBERP BORDERSIZE) (ABS BORDERSIZE)) ((NUMBERP WBorder) (ABS WBorder)) (T 2))) (COND ((type? REGION REGION) (SETQ SCREEN \XSCREEN) (* ;  "Protect against user smashing REGION later on.") (SETQ REG (COPY REGION))) [(type? SCREENREGION REGION) (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)) (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION] (T (ERROR "Not a region" REG))) [COND ((NULL DSP) (* ;  "Don't have a DSP yet. User passed some kind of region.") (SETQ DSP (XDSPCREATE (fetch (XSCREEN SCDESTINATION) of SCREEN))) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DSP] (COND ((NOT (IGREATERP (IMIN (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG)) (UNFOLD WBORDER 2))) (ERROR "Region too small to use as a window" REG))) (SETQ WINDOW (create WINDOW DSP _ DSP REG _ REG SAVE _ NIL WTITLE _ TITLE WBORDER _ WBORDER NEXTW _ 'CLOSED SCREEN _ SCREEN BUTTONEVENTFN _ NIL)) (replace (\DISPLAYDATA XWINDOWHINT) of DISPLAYDATA with WINDOW) (XSHOWWFRAME WINDOW) (DSPDESTINATION (fetch (WINDOW SAVE) of WINDOW) DSP) (ADVISEXWDS WINDOW) (* ;  "make the display stream and window agree about dimensions.") (MOVETOUPPERLEFT WINDOW) (AND TITLE (XLIB:SET-STANDARD-PROPERTIES (fetch (WINDOW SAVE) of WINDOW) :NAME TITLE)) (COND ((NOT NOOPENFLG) (XOPENW WINDOW))) (RETURN WINDOW]) (ADVISEXWDS [LAMBDA (WINDOW OLDREG MOVEONLYFLG) (DECLARE (LOCALVARS . T)) (* ; "Edited 25-Feb-91 18:26 by matsuda") (PROG (R D WBORDERSIZE CLIPREG TWICEBORDER PROC OFFSET) (SETQ R (fetch (WINDOW REG) of WINDOW)) (SETQ D (fetch (WINDOW DSP) of WINDOW)) (SETQ WBORDERSIZE (fetch (WINDOW WBORDER) of WINDOW)) (SETQ TWICEBORDER (UNFOLD WBORDERSIZE 2)) (COND (OLDREG (OR MOVEONLYFLG (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (XSCREEN SCTITLEDS) of (fetch (WINDOW SCREEN ) of WINDOW] (T 0] D))) (T (SETQ OFFSET (IMAX (FOLDHI WBORDERSIZE 2) (IDIFFERENCE WBORDERSIZE 2))) (DSPXOFFSET OFFSET D) (DSPYOFFSET OFFSET D) (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (XSCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] D))) [COND ((NULL MOVEONLYFLG) (* ;  "if the previous right margin was the default, change it.") (AND (OR (NOT OLDREG) (EQ (DSPRIGHTMARGIN NIL D) (IDIFFERENCE (fetch (REGION WIDTH) of OLDREG) TWICEBORDER))) (DSPRIGHTMARGIN (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) D)) (COND ((AND (SETQ PROC (WINDOWPROP WINDOW 'PROCESS)) (EQ D (PROCESS.TTY PROC))) (* ;  "if the window changing is a tty, set its linelength.") [PROCESS.EVAL PROC (LIST (FUNCTION PAGEHEIGHT) (IQUOTIENT (fetch (REGION HEIGHT) of (SETQ CLIPREG (DSPCLIPPINGREGION NIL D))) (IMINUS (DSPLINEFEED NIL D] (PROCESS.EVAL PROC '(SETLINELENGTH)) (IF NIL THEN (* ; "try it without this.") (COND ((EQ (PROCESSPROP PROC 'NAME) 'EXEC) (* ;; "in the exec process, make sure the current position is inside the new shape. reuse variables R and TWICEBORDER to save binding.") (COND ((ILESSP (SETQ R (DSPYPOSITION NIL D)) (SETQ TWICEBORDER (fetch (REGION BOTTOM) of CLIPREG ))) (DSPYPOSITION TWICEBORDER D)) ((IGREATERP R (SETQ TWICEBORDER (IPLUS (fetch (REGION HEIGHT) of CLIPREG) TWICEBORDER))) (DSPYPOSITION (IDIFFERENCE TWICEBORDER (FONTPROP D 'ASCENT)) D] (UPDATE/SCROLL/REG WINDOW)) WINDOW]) (XOPENW [LAMBDA (WINDOW) (* ; "Edited 31-Jan-91 15:28 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) (* ;  "used to bring the window to top but doesn't since TOTOPW has been documented.") NIL) (T (PROG [(USEROPENFN (WINDOWPROP WINDOW 'OPENFN] (COND ((\USERFNISDON'T USEROPENFN) (* ; "one of the OPENFNs is DON'T") NIL) (T (* ;  "open it by putting it on top and swapping its bits in") (* \OPENW1 WINDOW) (* ;  "call the openfns after the window has been opened.") (\XOPENW1 WINDOW) (DOUSERFNS USEROPENFN WINDOW) (RETURN WINDOW]) (\XOPENW1 [LAMBDA (WINDOW) (* ; "Edited 1-Feb-91 15:50 by matsuda") (if (EQ (fetch (WINDOW NEXTW) of WINDOW) 'CLOSED) then (PROG ((BASEW (WINDOWPROP WINDOW 'XBASEW)) XWIN REG BORDER XTITLEW TOP (SCREEN (fetch (WINDOW SCREEN) of WINDOW) ) DD) (if BASEW then (XLIB:MAP-WINDOW BASEW) else (WINDOWPROP WINDOW 'XBASEW (SETQ BASEW (\XCREATEBASEW WINDOW))) [AND (WINDOWPROP WINDOW 'TITLE) (SETQ XTITLEW (WINDOWPROP WINDOW 'XTITLEW] (SETQ XWIN (fetch (WINDOW SAVE) of WINDOW)) (SETQ BORDER (XLIB:DRAWABLE-BORDER-WIDTH XWIN)) (SETQ TOP 0) [COND (XTITLEW (XLIB:REPARENT-WINDOW XTITLEW BASEW 0 0) (SETQ TOP (XLIB:DRAWABLE-HEIGHT XTITLEW] (XLIB:REPARENT-WINDOW XWIN BASEW 0 TOP) (XLIB:MAP-SUBWINDOWS BASEW) (XLIB:MAP-WINDOW BASEW)) (UNINTERRUPTABLY (XLIB:MAP-WINDOW (fetch (WINDOW SAVE) of WINDOW)) (replace (WINDOW NEXTW) of WINDOW with (fetch (XSCREEN SCTOPW) of SCREEN)) (replace (XSCREEN SCTOPW) of SCREEN with WINDOW))]) (XCLOSEW [LAMBDA (WINDOW) (* ; "Edited 31-Jan-91 16:12 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) (COND ((\OKTOCLOSEW WINDOW) (AND (OPENWP WINDOW) (\XCLOSEW1 WINDOW)) T]) (\XCLOSEW1 [LAMBDA (WINDOW) (* ; "Edited 1-Feb-91 15:07 by matsuda") (LET (SCREEN NEXTW SAVE) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (SETQ NEXTW (fetch (XSCREEN SCTOPW) of SCREEN)) (COND ((NULL NEXTW) NIL) ((EQ NEXTW WINDOW) (UNINTERRUPTABLY (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW)) (replace (XSCREEN SCTOPW) of SCREEN with (fetch (WINDOW NEXTW) of NEXTW)) (replace (WINDOW NEXTW) of WINDOW with 'CLOSED)) T) (T (PROG NIL (SETQ SAVE NEXTW) (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE)) LOOP (COND (NEXTW (COND [(EQ NEXTW WINDOW) (UNINTERRUPTABLY (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW)) (replace (WINDOW NEXTW) of SAVE with (fetch (WINDOW NEXTW) of NEXTW)) (replace (WINDOW NEXTW) of NEXTW with 'CLOSED))] (T (SETQ SAVE NEXTW) (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE)) (GO LOOP]) (\XSFFixClippingRegion [LAMBDA (DISPLAYDATA) (* ; "Edited 25-Feb-91 18:43 by matsuda") (* ;; "compute the top, bottom, left and right edges of the clipping region in destination coordinates to save computation every BltChar and coordinate transformation taking into account the size of the bit map as well as the clipping region.") (PROG ((CLIPREG (ffetch (\DISPLAYDATA DDClippingRegion) of DISPLAYDATA)) (BM (ffetch (\DISPLAYDATA DDDestination) of DISPLAYDATA)) (GC (ffetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA))) (freplace (\DISPLAYDATA DDClippingRight) of DISPLAYDATA with (IMAX 0 (\DSPTRANSFORMX (IPLUS (ffetch (REGION LEFT) of CLIPREG) (ffetch (REGION WIDTH) of CLIPREG)) DISPLAYDATA))) (freplace (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA with (IMIN (IMAX (\DSPTRANSFORMX (ffetch (REGION LEFT) of CLIPREG) DISPLAYDATA) 0) MAX.SMALL.INTEGER)) (freplace (\DISPLAYDATA DDClippingTop) of DISPLAYDATA with (IMAX 0 (\DSPTRANSFORMY (IPLUS (ffetch (REGION BOTTOM) of CLIPREG) (ffetch (REGION HEIGHT) of CLIPREG)) DISPLAYDATA))) (freplace (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA with (IMIN (IMAX (\DSPTRANSFORMY (ffetch (REGION BOTTOM) of CLIPREG) DISPLAYDATA) 0) MAX.SMALL.INTEGER)) (CL:SETF (XLIB:GCONTEXT-CLIP-MASK GC) (LIST (fetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA) (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT BM) (fetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA)) (fetch (REGION WIDTH) of CLIPREG) (fetch (REGION HEIGHT) of CLIPREG]) (XSHOWWFRAME [LAMBDA (WIN) (* ; "Edited 27-Feb-91 17:38 by matsuda") (* ;; "Displays the border and title in the save image of a window") [PROG ((TITLE (fetch (WINDOW WTITLE) of WIN)) (BORDER (fetch (WINDOW WBORDER) of WIN)) (SAVEIMAGE (fetch (WINDOW SAVE) of WIN)) (SCREEN (fetch (WINDOW SCREEN) of WIN)) (REG (fetch (WINDOW REG) of WIN)) BLACKPART (TITLE-H 0)) (* ; "make most of the border black") (SETQ BLACKPART (IMAX (FOLDHI BORDER 2) (IDIFFERENCE BORDER 2))) (XSHOWWTITLE TITLE SAVEIMAGE BORDER NIL WIN) [AND TITLE (SETQ TITLE-H (XLIB:DRAWABLE-HEIGHT (WINDOWPROP WIN 'XTITLEW] (if SAVEIMAGE then (CL:SETF (XLIB:DRAWABLE-Y SAVEIMAGE) TITLE-H) (CL:SETF (XLIB:DRAWABLE-X SAVEIMAGE) 0) (CL:SETF (XLIB:DRAWABLE-WIDTH SAVEIMAGE) (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES BLACKPART 2))) [CL:SETF (XLIB:DRAWABLE-HEIGHT SAVEIMAGE) (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (IPLUS TITLE-H (ITIMES BLACKPART 2] else (replace SAVE of WIN with (SETQ SAVEIMAGE (XLIB:CREATE-WINDOW :PARENT (fetch (XSCREEN SCDESTINATION) of SCREEN) :X (fetch (REGION LEFT) of REG) :Y (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of SCREEN) (IDIFFERENCE (fetch (REGION TOP) of REG) (IPLUS TITLE-H BLACKPART))) :WIDTH (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES BLACKPART 2)) :HEIGHT (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (IPLUS TITLE-H (ITIMES BLACKPART 2))) :BORDER-WIDTH BLACKPART :BACKGROUND XLIB::*WHITE* :BIT-GRAVITY :NORTH-WEST :BACKING-STORE :ALWAYS] WIN]) (XSHOWWTITLE [LAMBDA (TITLE BM BORDER CENTERFLG WINDOW) (* ; "Edited 27-Feb-91 16:51 by matsuda") (PROG ((XTITLEW (WINDOWPROP WINDOW 'XTITLEW)) (XBASEW (WINDOWPROP WINDOW 'XBASEW)) FONT HEIGHT ASCENT (REG (fetch (WINDOW REG) of WINDOW))) (if TITLE then (SETQ HEIGHT (IPLUS (SETQ ASCENT (XLIB:FONT-ASCENT XLIB::*DEFAULTFONT*)) (XLIB:FONT-DESCENT XLIB::*DEFAULTFONT*))) (if XTITLEW then (CL:SETF (XLIB:DRAWABLE-WIDTH XTITLEW) (fetch (REGION WIDTH) of REG)) else (SETQ XTITLEW (XLIB:CREATE-WINDOW :PARENT (OR XBASEW XLIB::*ROOT*) :X 0 :Y 0 :WIDTH (IPLUS (fetch (REGION WIDTH) of REG) (IMAX (ITIMES (- BORDER 2) 2) 0)) :HEIGHT (IPLUS HEIGHT 2) :BORDER-WIDTH 0 :BACKGROUND XLIB::*BLACK* :BACKING-STORE :ALWAYS :BIT-GRAVITY :NORTH-WEST)) ) (if XBASEW then (XLIB:MAP-WINDOW XTITLEW)) (CL:SETF (XLIB:GCONTEXT-FONT XLIB::*GC*) XLIB::*DEFAULTFONT*) (CL:SETF (XLIB:GCONTEXT-FOREGROUND XLIB::*GC*) XLIB::*WHITE*) (CL:SETF (XLIB:GCONTEXT-BACKGROUND XLIB::*GC*) XLIB::*BLACK*) (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) CL:BOOLE-1) (XLIB:CLEAR-AREA XTITLEW) (XLIB:DRAW-IMAGE-GLYPHS XTITLEW XLIB::*GC* BORDER (ADD1 ASCENT) TITLE) else (AND XTITLEW (XLIB:DESTROY-WINDOW XTITLEW)) (SETQ XTITLEW NIL)) (WINDOWPROP WINDOW 'XTITLEW XTITLEW) (RETURN XTITLEW]) (\XCREATEBASEW [LAMBDA (WINDOW) (* ; "Edited 11-Jul-91 14:07 by matsuda") (PROG ((XWIN (fetch (WINDOW SAVE) of WINDOW)) (XTITLEW (WINDOWPROP WINDOW 'XTITLEW)) (REG (fetch (WINDOW REG) WINDOW)) (XCURSOR (XCURSORFROMCURSOR DEFAULTCURSOR)) WIDTH HEIGHT XBORDER BASEW TITLE) [SETQ WIDTH (IPLUS (XLIB:DRAWABLE-WIDTH XWIN) (SETQ XBORDER (ITIMES (XLIB:DRAWABLE-BORDER-WIDTH XWIN) 2] (SETQ HEIGHT (IPLUS (XLIB:DRAWABLE-HEIGHT XWIN) XBORDER)) [COND (XTITLEW (SETQ HEIGHT (IPLUS HEIGHT (XLIB:DRAWABLE-HEIGHT XTITLEW] (SETQ BASEW (XLIB:CREATE-WINDOW :PARENT XLIB::*ROOT* :X (fetch (REGION LEFT) of REG) :Y (fetch (REGION TOP) of REG) :WIDTH WIDTH :HEIGHT HEIGHT :BORDER-WIDTH 0 :BACKGROUND XLIB::*WHITE* :GRAVITY :NORTH-WEST :CURSOR XCURSOR :EVENT-MASK (XLIB:MAKE-EVENT-MASK :STRUCTURE-NOTIFY :KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE :POINTER-MOTION :ENTER-WINDOW :LEAVE-WINDOW))) (WINDOWPROP WINDOW 'XCURSOR XCURSOR) (AND (SETQ TITLE (WINDOWPROP WINDOW 'TITLE)) (XLIB:SET-STANDARD-PROPERTIES BASEW :NAME TITLE :INPUT :ON)) (RETURN BASEW]) (\DSPCLIPPINGREGION.XDISPLAY [LAMBDA (DISPLAYSTREAM REGION) (* ; "Edited 1-Feb-91 10:01 by matsuda") (* ;; "sets the clipping region of a display stream.") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (ffetch DDClippingRegion of DD) [COND (REGION (OR (type? REGION REGION) (ERROR REGION " is not a REGION.")) (UNINTERRUPTABLY (freplace DDClippingRegion of DD with REGION) (\XSFFixClippingRegion DD) (\INVALIDATEDISPLAYCACHE DD))])]) ) (DEFINEQ (\XDSPPRINTCHAR [LAMBDA (STREAM CHARCODE) (* ; "Edited 15-Feb-91 17:37 by matsuda") (PROG ((DD (ffetch (STREAM IMAGEDATA) of STREAM))) (* \CHECKCARET STREAM) (\MAYBE-DRIBBLE-CHAR STREAM CHARCODE) (* ; "if dribbling, dribble.") (SELECTC (ffetch (TERMCODE CCECHO) of (\SYNCODE \PRIMTERMSA CHARCODE)) (REAL.CCE (* ;; "All fat characters are defined as REAL according to \SYNCODE, so we don't have worry about any of the special cases") [COND ((IGREATERP CHARCODE (CONSTANT (IMAX (CHARCODE EOL) (CHARCODE CR) (CHARCODE LF) ERASECHARCODE))) (* ;  "This is for sure a printing character; take the fast way out.") (\XBLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)) (T (* ; "Take the slow check.") (SELECTC CHARCODE ((CHARCODE (EOL CR LF)) (\XDSPPRINTCR/LF CHARCODE STREAM) (freplace (STREAM CHARPOSITION) of STREAM with 0)) (ERASECHARCODE (DSPBACKUP (CHARWIDTH (CHARCODE A) STREAM) STREAM) (* ;  "line buffering routines have already taken care of backing up the position") 0) (PROGN (\XBLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1]) (INDICATE.CCE (* ;  "Make sure that all the chars in the indicate-string fit on the line or wrap-around together.") (PROG (STR) (SETQ STR (\INDICATESTRING CHARCODE)) (* ; "This isn't right for rotated fonts. But then there should probably be a separate rotated outcharfn") [COND ((IGREATERP (\STRINGWIDTH.DISPLAY STREAM STR) (IDIFFERENCE (ffetch (\DISPLAYDATA DDRightMargin) of DD) (ffetch (\DISPLAYDATA DDXPOSITION) of DD))) (\XDSPPRINTCR/LF (CHARCODE EOL) STREAM) (freplace (STREAM CHARPOSITION) of STREAM with (NCHARS STR))) (T (add (ffetch (STREAM CHARPOSITION) of STREAM) (NCHARS STR] (for I from 1 do (\XBLTCHAR (OR (NTHCHARCODE STR I) (RETURN)) STREAM DD)))) (SIMULATE.CCE (SELCHARQ CHARCODE ((EOL CR LF) (\XDSPPRINTCR/LF CHARCODE STREAM) (freplace (STREAM CHARPOSITION) of STREAM with 0)) (ESCAPE (\XBLTCHAR (CHARCODE $) STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)) (BELL (* ;  "make switching of bits uninterruptable but allow interrupts between flashes.") (SELECTC \MACHINETYPE ((LIST \DANDELION \DAYBREAK \MAIKO) [PLAYTUNE '((880 . 2500]) (FLASHWINDOW (WFROMDS STREAM)))) (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) STREAM))) (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) (COND ((IGREATERP (\DISPLAYSTREAMINCRXPOSITION (SETQ TABWIDTH (IDIFFERENCE TABWIDTH (MOD (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (\DISPLAYDATA DDLeftMargin) of DD)) TABWIDTH))) DD) (ffetch (\DISPLAYDATA DDRightMargin) of DD)) (* ;  "tab was past rightmargin, force cr.") (\XDSPPRINTCR/LF (CHARCODE EOL) STREAM))) (* ;  "return the number of spaces taken.") (add (ffetch (STREAM CHARPOSITION) of STREAM) (IQUOTIENT TABWIDTH SPACEWIDTH)))) (PROGN (* ;  "this case was copied from \DSCCOUT.") (\XBLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)))) (IGNORE.CCE) (SHOULDNT]) (\XBLTCHAR [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (DECLARE (LOCALVARS . T)) (* ; "Edited 1-Oct-91 13:38 by jn") (PROG (LOCAL1 RIGHT LEFT CURX CURY CHAR8CODE DESTINATION) (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) CRLP [COND ((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA) (\CHARSET CHARCODE))) (\CHANGECHARSET.XDISPLAY DISPLAYDATA (\CHARSET CHARCODE] (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA)) (SETQ RIGHT (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA))) [COND ((IGREATERP RIGHT (ffetch (\DISPLAYDATA DDRightMargin) of DISPLAYDATA)) (* ;  "would go past right margin, force a cr") (COND ((IGREATERP CURX (ffetch (\DISPLAYDATA DDLeftMargin) of DISPLAYDATA)) (* ;  "don't bother CR if position is at left margin anyway. This also serves to break the loop.") (\XDSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (* ;  "reuse the code in the test of this conditional rather than repeat it here.") (GO CRLP] (* ;  "update the display stream x position.") (freplace (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA with (IPLUS CURX ( \DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA))) (* ;  "transforms an x coordinate into the destination coordinate.") (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA)) (SETQ CURX (IPLUS CURX LOCAL1)) (SETQ CURY (IPLUS (ffetch (\DISPLAYDATA DDYPOSITION) of DISPLAYDATA) (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA))) (XLIB:DRAW-IMAGE-GLYPH (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DISPLAYDATA)) (fetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA) CURX (IDIFFERENCE (\GETWINDOWHEIGHT (* ;  "No roundtrip needed BUT: we have to remember to keep the height in sync with reality. /jarl") (WFROMDS DISPLAYSTREAM)) CURY) CHAR8CODE) (RETURN T]) (\XDSPPRINTCR/LF [LAMBDA (CHARCODE DISPLAY-STREAM) (* ; "Edited 28-Feb-91 12:05 by matsuda") (COND ((EQ DISPLAY-STREAM (TTYDISPLAYSTREAM)) (\STOPSCROLL?) (* ;  "\STOPSCROLL may have turned on the caret.") (* \CHECKCARET DISPLAY-STREAM) )) (PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch (STREAM IMAGEDATA) of DISPLAY-STREAM)) ) (COND ((EQ CHARCODE (CHARCODE EOL)) (* ; "on LF, no change in X") (COND ((SETQ Y (fetch (\DISPLAYDATA DDEOLFN) of DD)) (* ; "call the eol function for ds.") (APPLY* Y DISPLAY-STREAM))) (DSPXPOSITION (ffetch (\DISPLAYDATA DDLeftMargin) of DD) DISPLAY-STREAM))) (SETQ Y (IPLUS (ffetch (\DISPLAYDATA DDYPOSITION) of DD) (ffetch (\DISPLAYDATA DDLINEFEED) of DD))) [COND ((AND (fetch (\DISPLAYDATA DDScroll) of DD) (IGREATERP (SETQ AMOUNT/BELOW (IDIFFERENCE (IPLUS (SETQ BTM (fetch (\DISPLAYDATA DDClippingBottom ) of DD)) (fetch (FONTDESCRIPTOR \SFDescent) of (fetch (\DISPLAYDATA DDFONT) of DD))) (\DSPTRANSFORMY Y DD))) 0)) (* ;; "automatically scroll up enough to make the entire next character visible. Descent check is so that the bottoms of characters will be printed also.") [PROG (LFT WDTH BKGRND DBITMAP HGHT H) (SETQ LFT (fetch (\DISPLAYDATA DDClippingLeft) of DD)) (SETQ DBITMAP (fetch (\DISPLAYDATA DDDestination) of DD)) (SETQ HGHT (IDIFFERENCE (ffetch (\DISPLAYDATA DDClippingTop) of DD) BTM)) (SETQ WDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of DD) LFT)) (SETQ BKGRND (ffetch (\DISPLAYDATA DDTexture) of DD)) (COND ((IGREATERP AMOUNT/BELOW HGHT) (* ;  "scrolling more than the window size, use different method.") (* ;  "clear the window with background.") (BLTSHADE BKGRND DISPLAY-STREAM LFT BTM WDTH HGHT 'REPLACE)) (T (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) CL:BOOLE-1) (XLIB:COPY-AREA DBITMAP XLIB::*GC* LFT [IDIFFERENCE (SETQ H ( XLIB:DRAWABLE-HEIGHT DBITMAP)) (IPLUS BTM (SETQ HGHT (IDIFFERENCE HGHT AMOUNT/BELOW] WDTH HGHT DBITMAP LFT (IDIFFERENCE H (IPLUS (IPLUS BTM AMOUNT/BELOW) HGHT))) (BLTSHADE BKGRND DISPLAY-STREAM LFT BTM WDTH AMOUNT/BELOW 'REPLACE] (SETQ Y (IPLUS Y AMOUNT/BELOW] (DSPYPOSITION Y DISPLAY-STREAM]) ) (DEFINEQ (OPENWINDOWS [LAMBDA (SCREEN) (* ; "Edited 15-Feb-91 16:24 by matsuda") (* ;; "returns a list of all open windows") (PROG (WINDOW WINDOWS) (COND ((EQ SCREEN T) (* ; "Return all open windows.") (SETQ WINDOWS (for SCREEN in \SCREENS join (OPENWINDOWS SCREEN))) (RETURN WINDOWS))) (SETQ SCREEN (\INSURESCREEN SCREEN)) [SETQ WINDOW (COND ((type? SCREEN SCREEN) (fetch (SCREEN SCTOPW) of SCREEN)) ((type? XSCREEN SCREEN) (fetch (XSCREEN SCTOPW) of SCREEN] (while WINDOW do (SETQ WINDOWS (CONS WINDOW WINDOWS)) (SETQ WINDOW (fetch (WINDOW NEXTW) of WINDOW))) (SETQ WINDOWS (DREVERSE WINDOWS)) (RETURN WINDOWS]) (\INSURESCREEN [LAMBDA (SCREEN) (* ; "Edited 15-Feb-91 16:22 by matsuda") (COND ((type? SCREEN SCREEN) SCREEN) ((type? XSCREEN SCREEN) SCREEN) ((NULL SCREEN) \CURSORSCREEN) (T (\ILLEGAL.ARG SCREEN]) (DSPSOURCETYPE [LAMBDA (SOURCETYPE DISPLAYSTREAM) (* ; "Edited 15-Feb-91 13:02 by matsuda") (* ;; "sets the operation field of a display stream") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)) PBT) (RETURN (PROG1 (fetch DDSOURCETYPE of DD) [COND (SOURCETYPE (OR (FMEMB SOURCETYPE '(INPUT INVERT)) (LISPERROR "ILLEGAL ARG" SOURCETYPE)) (UNINTERRUPTABLY (freplace DDSOURCETYPE of DD with SOURCETYPE) (* ;  "update other fields that depend on operation.") [COND ((type? PILOTBBT (SETQ PBT (fetch DDPILOTBBT of DD))) (\SETPBTFUNCTION PBT SOURCETYPE (fetch DDOPERATION of DD))) ((XLIB:GCONTEXT-P PBT) (\SETGCFUNCTION PBT SOURCETYPE (fetch DDOPERATION of DD])])]) (PUTWINDOWPROP [LAMBDA (WINDOW PROP VALUE) (* ; "Edited 27-Feb-91 16:46 by matsuda") [OR (type? WINDOW WINDOW) (COND ((DISPLAYSTREAMP (\OUTSTREAMARG WINDOW)) (SETQ WINDOW (WFROMDS WINDOW))) (T (\ILLEGAL.ARG WINDOW] (SELECTQ PROP (RIGHTBUTTONFN (PROG1 (fetch (WINDOW RIGHTBUTTONFN) of WINDOW) (replace (WINDOW RIGHTBUTTONFN) of WINDOW with VALUE))) (BUTTONEVENTFN (PROG1 (fetch (WINDOW BUTTONEVENTFN) of WINDOW) (replace (WINDOW BUTTONEVENTFN) of WINDOW with VALUE))) (CLOSEFN (PROG1 (fetch (WINDOW CLOSEFN) of WINDOW) (replace (WINDOW CLOSEFN) of WINDOW with VALUE))) (MOVEFN (PROG1 (fetch (WINDOW MOVEFN) of WINDOW) (replace (WINDOW MOVEFN) of WINDOW with VALUE))) (CURSORINFN (PROG1 (fetch (WINDOW CURSORINFN) of WINDOW) (replace (WINDOW CURSORINFN) of WINDOW with VALUE))) (CURSOROUTFN (PROG1 (fetch (WINDOW CURSOROUTFN) of WINDOW) (replace (WINDOW CURSOROUTFN) of WINDOW with VALUE))) (CURSORMOVEDFN (PROG1 (fetch (WINDOW CURSORMOVEDFN) of WINDOW) (replace (WINDOW CURSORMOVEDFN) of WINDOW with VALUE))) (DSP (ERROR "Can't change DSP of a window" WINDOW)) (SCREEN (ERROR "Can't change SCREEN of a window" WINDOW)) (RESHAPEFN (PROG1 (fetch (WINDOW RESHAPEFN) of WINDOW) (replace (WINDOW RESHAPEFN) of WINDOW with VALUE))) (REPAINTFN (PROG1 (fetch (WINDOW REPAINTFN) of WINDOW) (replace (WINDOW REPAINTFN) of WINDOW with VALUE))) (EXTENT (PROG1 (fetch (WINDOW EXTENT) of WINDOW) (OR (NULL VALUE) (REGIONP VALUE) (\ILLEGAL.ARG VALUE)) (replace (WINDOW EXTENT) of WINDOW with VALUE))) (SCROLLFN (PROG1 (fetch (WINDOW SCROLLFN) of WINDOW) (replace (WINDOW SCROLLFN) of WINDOW with VALUE) (UPDATE/SCROLL/REG WINDOW))) (IMAGECOVERED (ERROR "Not implemented to change IMAGECOVERED property." WINDOW)) (HEIGHT (ERROR "Not implemented to change HEIGHT as property." WINDOW)) (WIDTH (ERROR "Not implemented to change WIDTH as property." WINDOW)) (REGION [PROG (CURREGION) (SETQ CURREGION (WINDOWPROP WINDOW 'REGION)) (COND ((NOT (REGIONP VALUE)) (\ILLEGAL.ARG VALUE))) (* ;; "there is no check for where the new region is nor how big it is; this is left to MOVEW and RESHAPEW.") (COND ((AND (EQ (fetch (REGION WIDTH) of CURREGION) (fetch (REGION WIDTH) of VALUE)) (EQ (fetch (REGION HEIGHT) of CURREGION) (fetch (REGION HEIGHT) of VALUE))) (* ;  "width and height are the same, move the window") (MOVEW WINDOW (fetch (REGION LEFT) of VALUE) (fetch (REGION BOTTOM) of VALUE))) (T (* ; "dimensions changed, reshape it.") (SHAPEW WINDOW VALUE]) (NEWREGIONFN (PROG1 (fetch (WINDOW NEWREGIONFN) of WINDOW) (replace (WINDOW NEWREGIONFN) of WINDOW with VALUE))) (TITLE (PROG1 (fetch (WINDOW WTITLE) of WINDOW) (COND ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (RESHOWTITLE VALUE WINDOW)) ((type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (replace (WINDOW WTITLE) of WINDOW with VALUE) (XSHOWWTITLE VALUE NIL (fetch (WINDOW WBORDER) of WINDOW) NIL WINDOW))))) (BORDER (PROG1 (fetch (WINDOW WBORDER) of WINDOW) (COND ((NUMBERP VALUE) (RESHOWBORDER VALUE WINDOW)) (T (\ILLEGAL.ARG VALUE))))) (PROCESS (PROG1 (fetch (WINDOW PROCESS) of WINDOW) (replace (WINDOW PROCESS) of WINDOW with VALUE))) (WINDOWENTRYFN (PROG1 (fetch (WINDOW WINDOWENTRYFN) of WINDOW) (replace (WINDOW WINDOWENTRYFN) of WINDOW with VALUE))) (PROG (OLDDATA OLDVALUE) (SETQ OLDDATA (fetch (WINDOW USERDATA) of WINDOW)) (RETURN (PROG1 (COND (OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP)) [COND (VALUE (LISTPUT OLDDATA PROP VALUE)) (OLDVALUE (* Remove the property) (COND ((EQ (CAR OLDDATA) PROP) (replace (WINDOW USERDATA) of WINDOW with (CDDR OLDDATA))) (T (for TAIL on (CDR OLDDATA) by (CDDR TAIL) when (EQ (CADR TAIL) PROP) do (FRPLACD TAIL (CDDDR TAIL)) (RETURN] OLDVALUE) (VALUE (replace (WINDOW USERDATA) of WINDOW with (LIST PROP VALUE)) (* know old value is NIL) NIL)) (COND ((AND (fetch (WINDOW WTITLE) of WINDOW) (EQ PROP 'WINDOWTITLESHADE)) (* change windowtitleshade.) (RESHOWTITLE (fetch (WINDOW WTITLE) of WINDOW) WINDOW T))))]) (RESHOWBORDER [LAMBDA (BORDER WINDOW) (* ; "Edited 27-Feb-91 17:15 by matsuda") (* ;; "updates a windows display with a new border") (* ;  "if the border is the same, don't change anything.") (OR (EQ BORDER (fetch (WINDOW WBORDER) of WINDOW)) (COND ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (\RESHOWBORDER1 BORDER (fetch (WINDOW WBORDER) of WINDOW) WINDOW)) ((type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (\XRESHOWBORDER1 BORDER (fetch (WINDOW WBORDER) of WINDOW) WINDOW]) (\XRESHOWBORDER1 [LAMBDA (NEWBORDER OLDBORDER WINDOW) (* ; "Edited 27-Feb-91 17:45 by matsuda") (PROG ((REGION (fetch (WINDOW REG) of WINDOW)) (OLDSAVE (fetch (WINDOW SAVE) of WINDOW)) DELTA NUWIDTH NUHEIGHT XBASEW) (SETQ DELTA (IDIFFERENCE NEWBORDER OLDBORDER)) (SETQ NUWIDTH (IPLUS (fetch (REGION WIDTH) of REGION) (ITIMES DELTA 2))) [SETQ NUHEIGHT (IDIFFERENCE (IPLUS (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) (ITIMES NEWBORDER 2)) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (XSCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] (replace (WINDOW WBORDER) of WINDOW with NEWBORDER) (CL:SETF (XLIB:DRAWABLE-BORDER-WIDTH OLDSAVE) (IMAX (FOLDHI NEWBORDER 2) (IDIFFERENCE NEWBORDER 2))) (replace (WINDOW REG) of WINDOW with (create REGION LEFT _ (IDIFFERENCE (fetch (REGION LEFT) of REGION) DELTA) BOTTOM _ (IDIFFERENCE (fetch (REGION BOTTOM ) of REGION) DELTA) WIDTH _ NUWIDTH HEIGHT _ NUHEIGHT)) (SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) (if (SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) then (CL:SETF (XLIB:DRAWABLE-WIDTH XBASEW) NUWIDTH) (CL:SETF (XLIB:DRAWABLE-HEIGHT XBASEW) NUHEIGHT)) (UPDATE/SCROLL/REG WINDOW) (XSHOWWFRAME WINDOW]) (\GETWINDOWHEIGHT [LAMBDA (WINDOW) (* ; "Edited 27-Feb-91 16:24 by matsuda") (* ;; "calculate the height from the REGION in case user has changed the clipping region. This won't work if the height of the title display stream has changed.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (DIFFERENCE (fetch (REGION HEIGHT) of (fetch (WINDOW REG) of WINDOW)) (DIFFERENCE (ITIMES 2 (fetch (WINDOW WBORDER) of WINDOW)) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (COND ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW )) (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW))) ((TYPE? XSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (fetch (XSCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0]) ) (DEFINEQ (XWHICHW [LAMBDA NIL (* ; "Edited 10-Apr-91 14:11 by matsuda") XLASTWINDOW]) ) (DEFINEQ (TOTOPW [LAMBDA (WINDOW NOCALLTOTOPFNFLG) (* ; "Edited 2-Oct-91 15:13 by jn") (* ;; "user entry to bring a window to the top. Unless NOCALLTOTOPFNFLG is non-NIL, it will call the windows TOTOPFN") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND [(type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (XLIB:CIRCULATE-WINDOW-UP (WINDOWPROP WINDOW 'XBASEW] ((EQ WINDOW (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WINDOW))) (PROGN (* (SETQ \TOPWDS (fetch  (WINDOW DSP) of WINDOW))) NIL)) ((OPENWP WINDOW) (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW)) (\INTERNALTOTOPW WINDOW)) ((OPENW WINDOW) (* ;  "if it is not open, open it and then call the TOTOPFN") (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW))) (T (* ;  "window won't open probably because of DON'T OPENFN") (ERROR "Window won't open; Can't be brought to top." WINDOW))) WINDOW]) ) (DEFINEQ (XSHAPEW1 [LAMBDA (WINDOW REGION) (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Feb-91 16:14 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (OR (REGIONP REGION) (\ILLEGAL.ARG REGION)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (OLDCLIPREG (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) (WBORDER (fetch (WINDOW WBORDER) of WINDOW)) SCREEN NUSAV NOWOPEN?) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (UNINTERRUPTABLY (* ; "Save window image") (replace (WINDOW REG) of WINDOW with REGION) (ADVISEXWDS WINDOW OLDREGION) (XSHOWWFRAME WINDOW)) (* ; " (DOUSERFNS2 (OR (fetch (WINDOW RESHAPEFN) of WINDOW) (FUNCTION RESHAPEBYREPAINTFN)) WINDOW NUSAV (create REGION LEFT _ WBORDER BOTTOM _ WBORDER WIDTH _ (fetch (REGION WIDTH) of OLDCLIPREG) HEIGHT _ (fetch (REGION HEIGHT) of OLDCLIPREG)) OLDREGION)") (RETURN WINDOW]) (XMOVEW [LAMBDA (WINDOW POSorX Y) (* ; "Edited 7-Mar-91 14:24 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW)) POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW) (COND ([COND ((LISTP USERMOVEFN) (FMEMB 'DON'T USERMOVEFN)) (T (EQ USERMOVEFN 'DON'T] (PROMPTPRINT "This window cannot be moved.") (RETURN))) (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) (COND [(AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (T (\ILLEGAL.ARG POSorX))) [COND ((AND (LISTP USERMOVEFN) (NOT (FMEMB (CAR USERMOVEFN) LAMBDASPLST))) (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN 'DON'T)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] 'DON'T) (RETURN))) (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (fetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY [COND ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) (XLIB:WITH-STATE (XBASEW) (CL:SETF (XLIB:DRAWABLE-Y XBASEW) (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of \XSCREEN) (fetch (REGION TOP) of NEWREGION))) (CL:SETF (XLIB:DRAWABLE-X XBASEW) (fetch (REGION LEFT) of NEWREGION] (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEXWDS WINDOW OLDREGION T)) (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW))) (RETURN POS]) (XMOVEW1 [LAMBDA (WINDOW POSorX Y) (* ; "Edited 16-Feb-91 18:04 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT POS NEWREGION REG) (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) [AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (ffetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEXWDS WINDOW OLDREGION T)) (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW]) (XMOVEORRESIZED.WINDOW [LAMBDA (WINDOW X Y WIDTH HEIGHT) (* ; "Edited 11-Apr-91 09:37 by matsuda") (PROG ((NEXTW (fetch (XSCREEN SCTOPW) of \XSCREEN)) XBASEW OLDREG NEWREG) LOOP (COND (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW)) (COND [(EQ WINDOW XBASEW) (SETQ OLDREG (fetch (WINDOW REG) NEXTW)) (SETQ NEWREG (create REGION LEFT _ X BOTTOM _ (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of \XSCREEN) (IPLUS Y HEIGHT)) WIDTH _ WIDTH HEIGHT _ HEIGHT)) (COND ((AND (EQ (fetch (REGION WIDTH) of OLDREG) WIDTH) (EQ (fetch (REGION HEIGHT) of OLDREG) HEIGHT)) (XMOVEW1 NEXTW (fetch (REGION LEFT) of NEWREG) (fetch (REGION BOTTOM) of NEWREG))) (T (XSHAPEW1 NEXTW NEWREG] (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW)) (GO LOOP]) (XMOVED.WINDOW [LAMBDA (WINDOW) (* ; "Edited 1-Feb-91 16:48 by matsuda") NIL]) ) (RPAQ? \XSCREEN NIL) (ADDTOVAR \DISPLAYSTREAMTYPES XDISPLAY) (ADDTOVAR IMAGESTREAMTYPES (XDISPLAY (OPENSTREAM NILL) (FONTCREATE \CREATEXDISPLAYFONT) (FONTSAVAILABLE NILL) (CREATECHARSET NILL))) (FILESLOAD XLLKEY XLLBITMAP XLLCURSOR XLLMOUSE XLLFONT XSERVER XWATCHER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA XLIB::SETUP-CLX) ) (PUTPROPS XMAS COPYRIGHT ("Venue" 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (11150 12401 (XLIB::SETUP-CLX 11160 . 12399)) (12402 80675 (\XDISPLAYINIT 12412 . 17445) (CREATEXSCREEN 17447 . 19460) (BITSPERPIXEL 19462 . 20487) (BITMAPHEIGHT 20489 . 20949) (BITMAPWIDTH 20951 . 21406) (DSPDESTINATION 21408 . 25038) (XDSPCREATE 25040 . 26540) (\DSPOPERATION.XDISPLAY 26542 . 27406) (\DSPRESET.XDISPLAY 27408 . 29848) (\BLTSHADE.XDISPLAY 29850 . 35267) (\BITBLT.XDISPLAY 35269 . 40602) (\XBITBLTSUB 40604 . 42083) (\XBLTSHADE.PIXMAP 42085 . 45581) (\XBITBLT.PIXMAP 45583 . 49709) (\DRAWPOINT.XDISPLAY 49711 . 50368) (\DRAWLINE.XDISPLAY 50370 . 53414) (\XLINEWITHBRUSH 53416 . 61792) (\DRAWCIRCLE.XDISPLAY 61794 . 66819) (\DRAWCURVE.XDISPLAY 66821 . 68378) (\XCURVE2 68380 . 75910) (\XCURVE 75912 . 80673)) (80676 91382 (BITBLT 80686 . 91380)) (91383 93367 (XCREATEWFROMPIXMAP 91393 . 92408) (PIXMAPCREATE 92410 . 92748) (PIXMAPWIDTH 92750 . 93055) (PIXMAPHEIGHT 93057 . 93365)) (93368 117849 (XCREATEW 93378 . 95995) (ADVISEXWDS 95997 . 102452) (XOPENW 102454 . 103586) (\XOPENW1 103588 . 105484) (XCLOSEW 105486 . 105815) (\XCLOSEW1 105817 . 107434) (\XSFFixClippingRegion 107436 . 109725) (XSHOWWFRAME 109727 . 112983) (XSHOWWTITLE 112985 . 115389) (\XCREATEBASEW 115391 . 117085) (\DSPCLIPPINGREGION.XDISPLAY 117087 . 117847)) (117850 133562 (\XDSPPRINTCHAR 117860 . 125664) ( \XBLTCHAR 125666 . 128836) (\XDSPPRINTCR/LF 128838 . 133560)) (133563 148886 (OPENWINDOWS 133573 . 134579) (\INSURESCREEN 134581 . 134893) (DSPSOURCETYPE 134895 . 136365) (PUTWINDOWPROP 136367 . 143483 ) (RESHOWBORDER 143485 . 144286) (\XRESHOWBORDER1 144288 . 147269) (\GETWINDOWHEIGHT 147271 . 148884)) (148887 149034 (XWHICHW 148897 . 149032)) (149035 150494 (TOTOPW 149045 . 150492)) (150495 159902 ( XSHAPEW1 150505 . 151645) (XMOVEW 151647 . 155883) (XMOVEW1 155885 . 158159) (XMOVEORRESIZED.WINDOW 158161 . 159765) (XMOVED.WINDOW 159767 . 159900))))) STOP \ No newline at end of file diff --git a/obsolete/sources/XMAS2 b/obsolete/sources/XMAS2 deleted file mode 100644 index 42ada05c..00000000 --- a/obsolete/sources/XMAS2 +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Oct-91 17:03:36" |{PELE:MV:ENVOS}SOURCES>XMAS2.;1| 62023 changes to%: (FNS XSHOWWFRAME) previous date%: "22-Oct-91 16:41:50" {DSK}nilsson>xmas-split>xmas2.;5) (* ; " Copyright (c) 1991 by Fuji Xerox Co., Ltd. All rights reserved. ") (PRETTYCOMPRINT XMAS2COMS) (RPAQQ XMAS2COMS ((RECORDS WINDOWOPS) (FNS CREATESCREEN DSPCREATE CREATEW.NEW OPENW.NEW CLOSEW.NEW MOVEW.NEW SHAPEW.NEW SHRINKW.NEW EXPANDW.NEW) (FNS CREATEW.XDISPLAY OPENW.XDISPLAY CLOSEW.XDISPLAY MOVEW.XDISPLAY SHAPEW.XDISPLAY SHRINKW.XDISPLAY EXPANDW.XDISPLAY TOTOPW.XDISPLAY BURYW.XDISPLAY) (FNS \XOPENW1 XSHOWWFRAME ADVISEXWDS XMOVEORRESIZED.WINDOW \XMOUSELEFT \XMOUSEMOVED \FINDWINDOW \XMOUSEENTERED XMOVEW \XCLOSEW1 XSHAPEW \XSHAPEW1 XCREATEWFROMPIXMAP XCLOSEMAINWINDOW \XINTERNALTOTOPW) (FNS ISXWINDOW?) (FNS INIT.XMAS2) (VARS XMAS2COMS))) (DECLARE%: EVAL@COMPILE (DATATYPE WINDOWOPS (CREATEW OPENW CLOSEW MOVEW SHAPEW SHRINKW EXPANDW) CREATEW _ (FUNCTION NILL) OPENW _ (FUNCTION NILL) CLOSEW _ (FUNCTION NILL) MOVEW _ (FUNCTION NILL) SHAPEW _ (FUNCTION NILL) SHRINKW _ (FUNCTION NILL) EXPANDW _ (FUNCTION NILL)) ) (/DECLAREDATATYPE 'WINDOWOPS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((WINDOWOPS 0 POINTER) (WINDOWOPS 2 POINTER) (WINDOWOPS 4 POINTER) (WINDOWOPS 6 POINTER) (WINDOWOPS 8 POINTER) (WINDOWOPS 10 POINTER) (WINDOWOPS 12 POINTER)) '14) (DEFINEQ (CREATESCREEN [LAMBDA (DESTINATION) (* ; "Edited 5-Sep-91 15:20 by matsuda") (* ;;; "destination is the framebuffer for the screen you want created.e.g. (SCREENBITMAP)") (PROG (TITLEDS SCREEN) (COND ((OR (NULL DESTINATION) (TYPE? BITMAP DESTINATION)) (SETQ TITLEDS (DSPCREATE DESTINATION)) (* ; "Create TITLEDS. ") (DSPOPERATION 'INVERT TITLEDS) (DSPFONT WINDOWTITLEFONT TITLEDS) (DSPRIGHTMARGIN MAX.SMALLP TITLEDS) (* ;  "Set right margin so title doesn't autoCR. ") (* ;; "now create SCREEN. ") (SETQ SCREEN (create SCREEN SCONOFF _ 'OFF SCDESTINATION _ DESTINATION SCWIDTH _ (BITMAPWIDTH DESTINATION) SCHEIGHT _ (BITMAPHEIGHT DESTINATION) SCTOPW _ NIL SCTITLEDS _ TITLEDS)) (RETURN SCREEN)) ((XLIB:DRAWABLE-P DESTINATION) (SETQ TITLEDS (XDSPCREATE DESTINATION)) (* ; "Create TITLEDS. ") (DSPOPERATION 'INVERT TITLEDS) (DSPFONT XWINDOWTITLEFONT TITLEDS) (DSPRIGHTMARGIN MAX.SMALLP TITLEDS) (* ;  "Set right margin so title doesn't autoCR. ") (* ;; "now create SCREEN. ") (SETQ SCREEN (create SCREEN SCONOFF _ 'OFF SCDESTINATION _ DESTINATION SCWIDTH _ (BITMAPWIDTH DESTINATION) SCHEIGHT _ (BITMAPHEIGHT DESTINATION) SCTOPW _ NIL SCTITLEDS _ TITLEDS)) (RETURN SCREEN]) (DSPCREATE [LAMBDA (DESTINATION) (* ; "Edited 5-Sep-91 15:34 by matsuda") (* ;; "Creates a stream-of-type-display on the DESTINATION bitmap or display device") (LET (DSTRM) (OR DESTINATION (SETQ DESTINATION ScreenBitMap)) (* ; "") (* ;  "(COND ((NULL DESTINATION)) (T (\DTEST DESTINATION 'BITMAP)))") (COND ((type? BITMAP DESTINATION) (SETQ DSTRM (create STREAM USERCLOSEABLE _ NIL OUTCHARFN _ (FUNCTION \DSPPRINTCHAR) IMAGEDATA _ (create \DISPLAYDATA) IMAGEOPS _ \DISPLAYIMAGEOPS DEVICE _ DisplayFDEV ACCESS _ 'OUTPUT)) (* ;  "initial x and y positions are 0 when the data is created.") (DSPFONT DEFAULTFONT DSTRM) (* ;  "dspfont can win since the (default) display imageops are filled in the stream") (DSPDESTINATION DESTINATION DSTRM) (* ;  "dspdestination calls \SFFixFont, which presumes there is a font present.") (DSPFONT DEFAULTFONT DSTRM) (* ;; "the reference to SCREENWIDTH here is for historic reasons: until 3-feb-86 the default right margin was always SCREENWIDTH. It should be the width of the destination and for any destination larger than the screen this is a serious bug and was fixed. The MAX of the right value and SCREENWIDTH was left in because existing code might be assumine a large right margin for small bitmaps and auto-CR in without it. rrb") (DSPRIGHTMARGIN (MAX SCREENWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION)) DSTRM) (DSPSOURCETYPE 'INPUT DSTRM) (DSPOPERATION 'REPLACE DSTRM) (* ;  "called to cause the updating of the bitblt table from the fields initialized earlier.") ) ((XLIB:DRAWABLE-P DESTINATION) (SETQ DSTRM (create STREAM USERCLOSEABLE _ NIL OUTCHARFN _ (FUNCTION \XDSPPRINTCHAR) IMAGEDATA _ (create \DISPLAYDATA) IMAGEOPS _ \XDISPLAYIMAGEOPS DEVICE _ XDisplayFDEV ACCESS _ 'OUTPUT)) (replace (\DISPLAYDATA DDPILOTBBT) of (fetch (STREAM IMAGEDATA) of DSTRM) with (SETQ GC (XLIB:CREATE-GCONTEXT :DRAWABLE DESTINATION))) (CL:SETF (XLIB:GCONTEXT-FOREGROUND GC) XLIB::*BLACK*) (* ; "temp foreground color ") (CL:SETF (XLIB:GCONTEXT-BACKGROUND GC) XLIB::*WHITE*) (* ; "temp background color") (DSPFONT XDEFAULTFONT DSTRM) (DSPDESTINATION DESTINATION DSTRM) (DSPRIGHTMARGIN (MAX SCREENWIDTH (XLIB:DRAWABLE-WIDTH DESTINATION)) DSTRM) (DSPSOURCETYPE 'INPUT DSTRM) (DSPOPERATION 'REPLACE DSTRM))) DSTRM]) (CREATEW.NEW [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG) (* ; "Edited 20-Oct-91 10:53 by jn") (* ;; "creates and returns a window.") (PROG (SCREEN) (COND ((AND (BOUNDP '\SCREEN) \SCREEN) (SETQ SCREEN \SCREEN)) ((type? SCREENREGION REGION) (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION))) (T (SETQ SCREEN \MAINSCREEN) (* ; "Default screen is \MAINSCREEN.") )) (RETURN (APPLY* (fetch (WINDOWOPS CREATEW) of (fetch (SCREEN SCDATA) of SCREEN)) REGION TITLE BORDERSIZE NOOPENFLG]) (OPENW.NEW [LAMBDA (WINDOW) (* ; "Edited 9-Sep-91 18:05 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS OPENW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW))) WINDOW]) (CLOSEW.NEW [LAMBDA (WINDOW) (* ; "Edited 9-Sep-91 18:01 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS CLOSEW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW)) ) WINDOW]) (MOVEW.NEW [LAMBDA (WINDOW POSorX Y) (* ; "Edited 10-Sep-91 15:55 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS MOVEW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW))) WINDOW POSorX Y]) (SHAPEW.NEW [LAMBDA (WINDOW NEWREGION) (* ; "Edited 13-Sep-91 14:09 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS SHAPEW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW)) ) WINDOW NEWREGION]) (SHRINKW.NEW [LAMBDA (WINDOW TOWHAT ICONPOSITION EXPANDFN) (* ; "Edited 13-Sep-91 16:39 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS SHRINKW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW) )) WINDOW TOWHAT ICONPOSITION EXPANDFN]) (EXPANDW.NEW [LAMBDA (ICONW) (* ; "Edited 13-Sep-91 16:07 by matsuda") (SETQ ICONW (\INSUREWINDOW ICONW)) (APPLY* (fetch (WINDOWOPS EXPANDW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of ICONW)) ) ICONW]) ) (DEFINEQ (CREATEW.XDISPLAY [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG) (* ; "Edited 9-Sep-91 17:03 by matsuda") (* ;; "creates and returns a window.") (PROG (SCREEN REG DSP DISPLAYDATA TITLEHEIGHT WINDOW WBORDER) (SETQ WBORDER (COND ((NUMBERP BORDERSIZE) (ABS BORDERSIZE)) ((NUMBERP WBorder) (ABS WBorder)) (T 2))) (COND ((type? REGION REGION) (SETQ SCREEN \XSCREEN) (* ;  "Protect against user smashing REGION later on.") (SETQ REG (COPY REGION))) [(type? SCREENREGION REGION) (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)) (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION] (T (ERROR "Not a region" REG))) [COND ((NULL DSP) (* ;  "Don't have a DSP yet. User passed some kind of region.") (SETQ DSP (DSPCREATE (fetch (SCREEN SCDESTINATION) of SCREEN))) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DSP] (COND ((NOT (IGREATERP (IMIN (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG)) (UNFOLD WBORDER 2))) (ERROR "Region too small to use as a window" REG))) (SETQ WINDOW (create WINDOW DSP _ DSP REG _ REG SAVE _ NIL WTITLE _ TITLE WBORDER _ WBORDER NEXTW _ 'CLOSED SCREEN _ SCREEN BUTTONEVENTFN _ NIL)) (replace (\DISPLAYDATA XWINDOWHINT) of DISPLAYDATA with WINDOW) (XSHOWWFRAME WINDOW) (DSPDESTINATION (fetch (WINDOW SAVE) of WINDOW) DSP) (ADVISEXWDS WINDOW) (* ;  "make the display stream and window agree about dimensions.") (MOVETOUPPERLEFT WINDOW) (COND ((NOT NOOPENFLG) (XOPENW WINDOW))) (RETURN WINDOW]) (OPENW.XDISPLAY [LAMBDA (WINDOW) (* ; "Edited 10-Sep-91 15:59 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) NIL) (T (PROG [(USEROPENFN (WINDOWPROP WINDOW 'OPENFN] (COND ((\USERFNISDON'T USEROPENFN) NIL) (T (\XOPENW1 WINDOW) (DOUSERFNS USEROPENFN WINDOW) (RETURN WINDOW]) (CLOSEW.XDISPLAY [LAMBDA (WINDOW) (* ; "Edited 9-Sep-91 17:44 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) (COND ((\OKTOCLOSEW WINDOW) (AND (OPENWP WINDOW) (\XCLOSEW1 WINDOW)) T]) (MOVEW.XDISPLAY [LAMBDA (WINDOW POSorX Y) (* ; "Edited 10-Sep-91 16:04 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW)) POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW) (COND ([COND ((LISTP USERMOVEFN) (FMEMB 'DON'T USERMOVEFN)) (T (EQ USERMOVEFN 'DON'T] (PROMPTPRINT "This window cannot be moved.") (RETURN))) (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) (COND [(AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (T (\ILLEGAL.ARG POSorX))) [COND ((AND (LISTP USERMOVEFN) (NOT (FMEMB (CAR USERMOVEFN) LAMBDASPLST))) (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN 'DON'T)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] 'DON'T) (RETURN))) (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (fetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY [COND ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) (XLIB:WITH-STATE (XBASEW) (CL:SETF (XLIB:DRAWABLE-Y XBASEW) (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) (fetch (REGION TOP) of NEWREGION))) (CL:SETF (XLIB:DRAWABLE-X XBASEW) (fetch (REGION LEFT) of NEWREGION] (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEXWDS WINDOW OLDREGION T)) (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW))) (RETURN POS]) (SHAPEW.XDISPLAY [LAMBDA (WINDOW NEWREGION) (* ; "Edited 13-Sep-91 14:11 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDSIZE (WINDOWPROP WINDOW 'REGION)) NEWSIZE) (COND ((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW)) (* ;  "don't allow the window to be reshaped.") (PROMPTPRINT "This window cannot be reshaped.") (RETURN NIL))) (SETQ NEWSIZE (MINIMUMWINDOWSIZE WINDOW)) [SETQ NEWSIZE (COND (NEWREGION (* ;  "An explicit new region was specified; make sure it's big enough.") (COND [(OR (LESSP (fetch (REGION WIDTH) of NEWREGION) (CAR NEWSIZE)) (LESSP (fetch (REGION HEIGHT) of NEWREGION) (CDR NEWSIZE))) (* ;  "given a region that is too small, so expand the width and height to at least the minima.") (CREATEREGION (fetch (REGION LEFT) of NEWREGION) (fetch (REGION BOTTOM) of NEWREGION) (IMAX (CAR NEWSIZE) (fetch (REGION WIDTH) of NEWREGION)) (IMAX (CDR NEWSIZE) (fetch (REGION HEIGHT) of NEWREGION] (T NEWREGION))) (T (ERROR "NEWREGION must be specified."] (RETURN (if (EQUAL NEWSIZE OLDSIZE) then (* ;; "if same size and place as before, do nothing") NIL elseif (AND (EQ (fetch (REGION WIDTH) of NEWSIZE) (fetch (REGION WIDTH) of OLDSIZE)) (EQ (fetch (REGION HEIGHT) of NEWSIZE) (fetch (REGION HEIGHT) of OLDSIZE))) then (* ;; "if same width and height, then optimize to a move") (MOVEW.XDISPLAY WINDOW (fetch (REGION LEFT) of NEWSIZE) (fetch (REGION BOTTOM) of NEWSIZE)) else (* ;; "do the shape, checking for a doshapefn") (APPLY* (OR (WINDOWPROP WINDOW 'DOSHAPEFN) '\XSHAPEW1) WINDOW (COPYALL NEWSIZE]) (SHRINKW.XDISPLAY [LAMBDA (WINDOW TOWHAT ICONPOSITION EXPANDFN) (* ; "Edited 11-Sep-91 15:59 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((NOT (OPENWP WINDOW)) NIL) ((WINDOWPROP WINDOW 'ICONFOR) NIL) ((EQ (DOUSERFNS (WINDOWPROP WINDOW 'SHRINKFN) WINDOW T) 'DON'T) NIL) (T (LET (TITLE ICONW FN ICONISBITMAP ICONISPIXMAP) [SETQ ICONW (COND ((type? BITMAP TOWHAT) [SETQ ICONISPIXMAP (PIXMAPFROMBITMAP TOWHAT (BITSPERPIXEL (fetch (SCREEN SCDESTINATION ) of (fetch (WINDOW SCREEN) of WINDOW] [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (XCREATEWFROMPIXMAP ICONISPIXMAP (fetch (WINDOW SCREEN) of WINDOW] (XLIB:FREE-PIXMAP ICONISPIXMAP) TOWHAT) ((XLIB:DRAWABLE-P TOWHAT) [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (XCREATEWFROMPIXMAP TOWHAT (fetch (WINDOW SCREEN) of WINDOW] TOWHAT) ((ISXWINDOW? TOWHAT) (WINDOWPROP WINDOW 'ICON TOWHAT) TOWHAT) ((STRINGP TOWHAT) [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (\DTEST (APPLY* DEFAULTICONFN WINDOW TOWHAT) 'WINDOW] TOWHAT) (T [SETQ TOWHAT (COND ((SETQ FN (WINDOWPROP WINDOW 'ICONFN)) (* ;  "User fn to create an icon. Can return cached value") (APPLY* FN WINDOW (WINDOWPROP WINDOW 'ICONWINDOW) (POSITIONP ICONPOSITION))) (T (WINDOWPROP WINDOW 'ICON] (COND ((ISXWINDOW? TOWHAT) TOWHAT) ((type? BITMAP TOWHAT) [SETQ ICONISPIXMAP (PIXMAPFROMBITMAP TOWHAT (BITSPERPIXEL (fetch (SCREEN SCDESTINATION ) of (fetch (WINDOW SCREEN) of WINDOW] (XCREATEWFROMPIXMAP ICONISPIXMAP (fetch (WINDOW SCREEN) of WINDOW)) (XLIB:FREE-PIXMAP ICONISPIXMAP)) ((XLIB:DRAWABLE-P TOWHAT) (XCREATEWFROMPIXMAP TOWHAT (fetch (WINDOW SCREEN) of WINDOW))) (T (\DTEST (APPLY* XDEFAULTICONFN WINDOW TOWHAT) 'WINDOW] (WINDOWPROP WINDOW 'ICONWINDOW ICONW) (WINDOWPROP ICONW 'ICONFOR WINDOW) (WINDOWADDFNPROP ICONW 'CLOSEFN (FUNCTION XCLOSEMAINWINDOW)) (* ; "(COND ((EQ (WINDOWPROP ICONW 'BUTTONEVENTFN) 'TOTOPW) (WINDOWPROP ICONW 'BUTTONEVENTFN (FUNCTION ICONBUTTONEVENTFN))))") (WINDOWADDFNPROP WINDOW 'OPENFN (FUNCTION CLOSEICONWINDOW)) (WINDOWADDFNPROP ICONW 'MOVEFN (FUNCTION \NOTENEWICONPOSITION)) (AND EXPANDFN (WINDOWADDFNPROP WINDOW 'EXPANDFN EXPANDFN)) (* ;  "(WINDOWPROP ICONW 'DOWINDOWCOMFN (FUNCTION DOICONWINDOWCOM))") [COND [(AND (NEQ ICONPOSITION 'SAME) (OR ICONISBITMAP (POSITIONP ICONPOSITION))) (MOVEW ICONW (COND ((POSITIONP ICONPOSITION) ICONPOSITION) ((PROG1 [POSITIONP (SETQ ICONPOSITION (WINDOWPROP WINDOW 'ICONPOSITION] (* ;  "leave it in its current location.") )) (T (SETQ ICONPOSITION (ICONPOSITION.FROM.WINDOW WINDOW (WINDOWPROP ICONW 'REGION] (T (SETQ ICONPOSITION (LET [(REG (WINDOWPROP ICONW 'REGION] (create POSITION XCOORD _ (fetch (REGION LEFT) of REG) YCOORD _ (fetch (REGION BOTTOM) of REG] (WINDOWPROP WINDOW 'ICONPOSITION ICONPOSITION)(* ; "(TOTOPW WINDOW T)") (\XCLOSEW1 WINDOW) (OPENW ICONW) ICONW]) (EXPANDW.XDISPLAY [LAMBDA (ICONW) (* ; "Edited 11-Sep-91 16:58 by matsuda") (PROG ((IW ICONW) MAINWINDOW USEREXPANDFN EXPANDREGION) [COND [(SETQ MAINWINDOW (WINDOWPROP IW 'ICONFOR] ((SETQ IW (WINDOWPROP IW 'ICONWINDOW)) (COND ((OPENWP (SETQ MAINWINDOW ICONW)) (RETURN ICONW] (COND ([AND MAINWINDOW (NULL (\USERFNISDON'T (SETQ USEREXPANDFN (WINDOWPROP MAINWINDOW 'EXPANDFN] (if (AND (WINDOWPROP MAINWINDOW 'EXPANDREGIONFN) (SETQ EXPANDREGION (APPLY* (WINDOWPROP MAINWINDOW 'EXPANDREGIONFN) MAINWINDOW))) then (\XSHAPEW1 MAINWINDOW EXPANDREGION) else (\XOPENW1 MAINWINDOW)) (\XCLOSEW1 IW) (WINDOWDELPROP MAINWINDOW 'OPENFN 'CLOSEICONWINDOW) (WINDOWDELPROP IW 'CLOSEFN 'CLOSEMAINWINDOW) (DOUSERFNS USEREXPANDFN MAINWINDOW) (RETURN (WINDOWPROP IW 'ICONFOR NIL]) (TOTOPW.XDISPLAY [LAMBDA (WINDOW NOCALLTOTOPFNFLG) (* ; "Edited 13-Sep-91 16:51 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW)) (\XINTERNALTOTOPW WINDOW)) ((OPENW WINDOW) (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW))) (T (* ;  "window won't open probably because of DON'T OPENFN") (ERROR "Window won't open; Can't be bring to top." WINDOW))) WINDOW]) (BURYW.XDISPLAY [LAMBDA (WINDOW) (* ; "Edited 13-Sep-91 18:02 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG [(BASEW (WINDOWPROP WINDOW 'XBASEW] (AND BASEW (XLIB::SET-WINDOW-PRIORITY :BELOW BASEW]) ) (DEFINEQ (\XOPENW1 [LAMBDA (WINDOW) (* ; "Edited 6-Sep-91 15:22 by matsuda") (if (EQ (fetch (WINDOW NEXTW) of WINDOW) 'CLOSED) then (PROG ((BASEW (WINDOWPROP WINDOW 'XBASEW)) XWIN REG BORDER XTITLEW TOP (SCREEN (fetch (WINDOW SCREEN) of WINDOW) ) DD) (if BASEW then (XLIB:MAP-WINDOW BASEW) else (WINDOWPROP WINDOW 'XBASEW (SETQ BASEW (\XCREATEBASEW WINDOW))) [AND (WINDOWPROP WINDOW 'TITLE) (SETQ XTITLEW (WINDOWPROP WINDOW 'XTITLEW] (SETQ XWIN (fetch (WINDOW SAVE) of WINDOW)) (SETQ BORDER (XLIB:DRAWABLE-BORDER-WIDTH XWIN)) (SETQ TOP 0) [COND (XTITLEW (XLIB:REPARENT-WINDOW XTITLEW BASEW 0 0) (SETQ TOP (XLIB:DRAWABLE-HEIGHT XTITLEW] (XLIB:REPARENT-WINDOW XWIN BASEW 0 TOP) (XLIB:MAP-SUBWINDOWS BASEW) (CL:SETF (XLIB:TRANSIENT-FOR BASEW) BASEW) (XLIB:MAP-WINDOW BASEW)) (UNINTERRUPTABLY (XLIB:MAP-WINDOW (fetch (WINDOW SAVE) of WINDOW)) (replace (WINDOW NEXTW) of WINDOW with (fetch (SCREEN SCTOPW) of SCREEN)) (replace (SCREEN SCTOPW) of SCREEN with WINDOW))]) (XSHOWWFRAME [LAMBDA (WIN) (* ; "Edited 22-Oct-91 17:03 by jn") (* ;; "Displays the border and title in the save image of a window ") [PROG ((TITLE (fetch (WINDOW WTITLE) of WIN)) (BORDER (fetch (WINDOW WBORDER) of WIN)) (SAVEIMAGE (fetch (WINDOW SAVE) of WIN)) (SCREEN (fetch (WINDOW SCREEN) of WIN)) (REG (fetch (WINDOW REG) of WIN)) BLACKPART FOOT (TITLE-H 0)) (* ; "make most of the border black") (SETQ BLACKPART (IMAX (FOLDHI BORDER 2) (IDIFFERENCE BORDER 2))) (XSHOWWTITLE TITLE SAVEIMAGE BORDER NIL WIN) [AND TITLE (SETQ TITLE-H (XLIB:DRAWABLE-HEIGHT (WINDOWPROP WIN 'XTITLEW] (if SAVEIMAGE then [XLIB:WITH-STATE (SAVEIMAGE) (CL:SETF (XLIB:DRAWABLE-Y SAVEIMAGE) TITLE-H) (CL:SETF (XLIB:DRAWABLE-X SAVEIMAGE) 0) (CL:SETF (XLIB:DRAWABLE-WIDTH SAVEIMAGE) (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES BLACKPART 2))) (CL:SETF (XLIB:DRAWABLE-HEIGHT SAVEIMAGE) (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (IPLUS TITLE-H (ITIMES BLACKPART 2] else (replace SAVE of WIN with (SETQ SAVEIMAGE (XLIB:CREATE-WINDOW :PARENT (fetch (SCREEN SCDESTINATION) of SCREEN) :X (fetch (REGION LEFT) of REG) :Y (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of SCREEN) (IDIFFERENCE (fetch (REGION TOP) of REG) (IPLUS TITLE-H BLACKPART))) :WIDTH (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES BLACKPART 2)) :HEIGHT (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (IPLUS TITLE-H (ITIMES BLACKPART 2))) :BORDER-WIDTH BLACKPART :BACKGROUND XLIB::*WHITE* :BIT-GRAVITY :NORTH-WEST :BACKING-STORE :ALWAYS] WIN]) (ADVISEXWDS [LAMBDA (WINDOW OLDREG MOVEONLYFLG) (DECLARE (LOCALVARS . T)) (* ; "Edited 5-Sep-91 16:23 by matsuda") (PROG (R D WBORDERSIZE CLIPREG TWICEBORDER PROC OFFSET) (SETQ R (fetch (WINDOW REG) of WINDOW)) (SETQ D (fetch (WINDOW DSP) of WINDOW)) (SETQ WBORDERSIZE (fetch (WINDOW WBORDER) of WINDOW)) (SETQ TWICEBORDER (UNFOLD WBORDERSIZE 2)) (COND (OLDREG (OR MOVEONLYFLG (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN ) of WINDOW] (T 0] D))) (T (SETQ OFFSET (IMAX (FOLDHI WBORDERSIZE 2) (IDIFFERENCE WBORDERSIZE 2))) (DSPXOFFSET OFFSET D) (DSPYOFFSET OFFSET D) (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] D))) [COND ((NULL MOVEONLYFLG) (* ;  "if the previous right margin was the default, change it.") (AND (OR (NOT OLDREG) (EQ (DSPRIGHTMARGIN NIL D) (IDIFFERENCE (fetch (REGION WIDTH) of OLDREG) TWICEBORDER))) (DSPRIGHTMARGIN (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) D)) (COND ((AND (SETQ PROC (WINDOWPROP WINDOW 'PROCESS)) (EQ D (PROCESS.TTY PROC))) (* ;  "if the window changing is a tty, set its linelength.") [PROCESS.EVAL PROC (LIST (FUNCTION PAGEHEIGHT) (IQUOTIENT (fetch (REGION HEIGHT) of (SETQ CLIPREG (DSPCLIPPINGREGION NIL D))) (IMINUS (DSPLINEFEED NIL D] (PROCESS.EVAL PROC '(SETLINELENGTH)) (IF NIL THEN (* ; "try it without this.") (COND ((EQ (PROCESSPROP PROC 'NAME) 'EXEC) (* ;; "in the exec process, make sure the current position is inside the new shape. reuse variables R and TWICEBORDER to save binding.") (COND ((ILESSP (SETQ R (DSPYPOSITION NIL D)) (SETQ TWICEBORDER (fetch (REGION BOTTOM) of CLIPREG ))) (DSPYPOSITION TWICEBORDER D)) ((IGREATERP R (SETQ TWICEBORDER (IPLUS (fetch (REGION HEIGHT) of CLIPREG) TWICEBORDER))) (DSPYPOSITION (IDIFFERENCE TWICEBORDER (FONTPROP D 'ASCENT)) D] (UPDATE/SCROLL/REG WINDOW)) WINDOW]) (XMOVEORRESIZED.WINDOW [LAMBDA (WINDOW X Y WIDTH HEIGHT) (* ; "Edited 5-Sep-91 16:57 by matsuda") (PROG ((NEXTW (fetch (SCREEN SCTOPW) of \XSCREEN)) XBASEW OLDREG NEWREG) LOOP (COND (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW)) (COND [(EQ WINDOW XBASEW) (SETQ OLDREG (fetch (WINDOW REG) NEXTW)) (SETQ NEWREG (create REGION LEFT _ X BOTTOM _ (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) (IPLUS Y HEIGHT)) WIDTH _ WIDTH HEIGHT _ HEIGHT)) (COND ((AND (EQ (fetch (REGION WIDTH) of OLDREG) WIDTH) (EQ (fetch (REGION HEIGHT) of OLDREG) HEIGHT)) (XMOVEW1 NEXTW (fetch (REGION LEFT) of NEWREG) (fetch (REGION BOTTOM) of NEWREG))) (T (XSHAPEW1 NEXTW NEWREG] (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW)) (GO LOOP]) (\XMOUSELEFT [LAMBDA (WINDOW X Y) (* ; "Edited 5-Sep-91 16:56 by matsuda") (SETQ XLASTMOUSEX X) (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) Y)) (COND ((EQ XLASTWINDOW (\FINDWINDOW WINDOW) XLASTWINDOW) (DOUSERFNS (fetch (WINDOW CURSORINFN) of XLASTWINDOW) XLASTWINDOW))) (SETQ XLASTWINDOW NIL]) (\XMOUSEMOVED [LAMBDA (WINDOW X Y) (* ; "Edited 5-Sep-91 16:55 by matsuda") (SETQ XLASTMOUSEX X) (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) Y)) (SETQ XLASTWINDOW (\FINDWINDOW WINDOW)) (DOUSERFNS (fetch (WINDOW CURSORMOVEDFN) of XLASTWINDOW) XLASTWINDOW]) (\FINDWINDOW [LAMBDA (WINDOW) (* ; "Edited 5-Sep-91 16:51 by matsuda") (PROG ((NEXTW (fetch (SCREEN SCTOPW) of \XSCREEN)) XBASEW) LOOP (COND (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW)) (COND ((EQ WINDOW XBASEW) (RETURN NEXTW)) (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW)) (GO LOOP]) (\XMOUSEENTERED [LAMBDA (WINDOW X Y) (* ; "Edited 5-Sep-91 17:13 by matsuda") (SETQ XLASTMOUSEX X) (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) Y)) (SETQ XLASTWINDOW (\FINDWINDOW WINDOW)) (DOUSERFNS (fetch (WINDOW CURSORINFN) of XLASTWINDOW) XLASTWINDOW]) (XMOVEW [LAMBDA (WINDOW POSorX Y) (* ; "Edited 7-Mar-91 14:24 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW)) POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW) (COND ([COND ((LISTP USERMOVEFN) (FMEMB 'DON'T USERMOVEFN)) (T (EQ USERMOVEFN 'DON'T] (PROMPTPRINT "This window cannot be moved.") (RETURN))) (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) (COND [(AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (T (\ILLEGAL.ARG POSorX))) [COND ((AND (LISTP USERMOVEFN) (NOT (FMEMB (CAR USERMOVEFN) LAMBDASPLST))) (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN 'DON'T)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] 'DON'T) (RETURN))) (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (fetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY [COND ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) (XLIB:WITH-STATE (XBASEW) (CL:SETF (XLIB:DRAWABLE-Y XBASEW) (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of \XSCREEN) (fetch (REGION TOP) of NEWREGION))) (CL:SETF (XLIB:DRAWABLE-X XBASEW) (fetch (REGION LEFT) of NEWREGION] (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEXWDS WINDOW OLDREGION T)) (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW))) (RETURN POS]) (\XCLOSEW1 [LAMBDA (WINDOW) (* ; "Edited 10-Sep-91 17:31 by matsuda") (LET (SCREEN NEXTW SAVE) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (SETQ NEXTW (fetch (SCREEN SCTOPW) of SCREEN)) (COND ((NULL NEXTW) NIL) ((EQ NEXTW WINDOW) (UNINTERRUPTABLY (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW)) (replace (SCREEN SCTOPW) of SCREEN with (fetch (WINDOW NEXTW) of NEXTW)) (replace (WINDOW NEXTW) of WINDOW with 'CLOSED)) T) (T (PROG NIL (SETQ SAVE NEXTW) (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE)) LOOP (COND (NEXTW (COND [(EQ NEXTW WINDOW) (UNINTERRUPTABLY (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW)) (replace (WINDOW NEXTW) of SAVE with (fetch (WINDOW NEXTW) of NEXTW)) (replace (WINDOW NEXTW) of NEXTW with 'CLOSED))] (T (SETQ SAVE NEXTW) (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE)) (GO LOOP]) (XSHAPEW [LAMBDA (WINDOW NEWREGION) (* ; "Edited 6-Sep-91 17:49 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDSIZE (WINDOWPROP WINDOW 'REGION)) NEWSIZE) (COND ((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW)) (* ;  "don't allow the window to be reshaped.") (PROMPTPRINT "This window cannot be reshaped.") (RETURN NIL))) (SETQ NEWSIZE (MINIMUMWINDOWSIZE WINDOW)) [SETQ NEWSIZE (COND (NEWREGION (* ;  "An explicit new region was specified; make sure it's big enough.") (COND [(OR (LESSP (fetch (REGION WIDTH) of NEWREGION) (CAR NEWSIZE)) (LESSP (fetch (REGION HEIGHT) of NEWREGION) (CDR NEWSIZE))) (* ;  "given a region that is too small, so expand the width and height to at least the minima.") (CREATEREGION (fetch (REGION LEFT) of NEWREGION) (fetch (REGION BOTTOM) of NEWREGION) (IMAX (CAR NEWSIZE) (fetch (REGION WIDTH) of NEWREGION)) (IMAX (CDR NEWSIZE) (fetch (REGION HEIGHT) of NEWREGION] (T NEWREGION))) (T (ERROR "NEWREGION must be specified."] (RETURN (if (EQUAL NEWSIZE OLDSIZE) then (* ;; "if same size and place as before, do nothing") NIL elseif (AND (EQ (fetch (REGION WIDTH) of NEWSIZE) (fetch (REGION WIDTH) of OLDSIZE)) (EQ (fetch (REGION HEIGHT) of NEWSIZE) (fetch (REGION HEIGHT) of OLDSIZE))) then (* ;; "if same width and height, then optimize to a move") (XMOVEW WINDOW (fetch (REGION LEFT) of NEWSIZE) (fetch (REGION BOTTOM) of NEWSIZE)) else (* ;; "do the shape, checking for a doshapefn") (APPLY* (OR (WINDOWPROP WINDOW 'DOSHAPEFN) '\XSHAPEW1) WINDOW (COPYALL NEWSIZE]) (\XSHAPEW1 [LAMBDA (WINDOW REGION) (* ; "Edited 6-Sep-91 18:05 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (OR (REGIONP REGION) (\ILLEGAL.ARG REGION)) (PROG [(XBASEW (WINDOWPROP WINDOW 'XBASEW] (IF XBASEW THEN (XLIB:WITH-STATE (XBASEW) (CL:SETF (XLIB:DRAWABLE-X XBASEW) (fetch (REGION LEFT) of REGION)) (CL:SETF (XLIB:DRAWABLE-Y XBASEW) (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT XLIB::*ROOT*) (fetch (REGION TOP) of REGION))) (CL:SETF (XLIB:DRAWABLE-WIDTH XBASEW) (fetch (REGION WIDTH) of REGION)) (CL:SETF (XLIB:DRAWABLE-HEIGHT XBASEW) (fetch (REGION HEIGHT) of REGION]) (XCREATEWFROMPIXMAP [LAMBDA (PIXMAP SCREEN) (* ; "Edited 13-Sep-91 14:33 by matsuda") (PROG (WINDOW WIDTH HEIGHT) (SETQ WINDOW (CREATEW (create SCREENREGION SCREEN _ (\INSURESCREEN SCREEN) LEFT _ 0 BOTTOM _ 0 WIDTH _ (SETQ WIDTH (PIXMAPWIDTH PIXMAP)) HEIGHT _ (SETQ HEIGHT (PIXMAPHEIGHT PIXMAP))) NIL 0 T)) (WINDOWPROP WINDOW 'MINSIZE (CONS (IMIN MinWindowWidth WIDTH) (IMIN MinWindowWidth HEIGHT))) (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) CL:BOOLE-1) (XLIB:COPY-AREA PIXMAP XLIB::*GC* 0 0 WIDTH HEIGHT (fetch (WINDOW SAVE) of WINDOW) 0 0) (RETURN WINDOW]) (XCLOSEMAINWINDOW [LAMBDA (ICONWIN) (* ; "Edited 11-Sep-91 11:22 by matsuda") (PROG [(MAINWIN (WINDOWPROP ICONWIN 'ICONFOR] [COND (MAINWIN (COND ((NULL (\OKTOCLOSEW MAINWIN)) (RETURN 'DON'T)) (T (AND (OPENWP MAINWIN) (\XCLOSEW1 MAINWIN] (WINDOWPROP ICONWIN 'ICONFOR NIL) (RETURN NIL]) (\XINTERNALTOTOPW [LAMBDA (WINDOW) (* ; "Edited 13-Sep-91 18:02 by matsuda") (PROG [(BASEW (WINDOWPROP WINDOW 'XBASEW] (AND BASEW (XLIB::SET-WINDOW-PRIORITY :ABOVE BASEW]) ) (DEFINEQ (ISXWINDOW? [LAMBDA (WINDOW) (* ; "Edited 11-Sep-91 10:56 by matsuda") (AND (TYPE? WINDOW WINDOW) (XLIB:DRAWABLE-P (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of WINDOW))) WINDOW]) ) (DEFINEQ (INIT.XMAS2 [LAMBDA NIL (* ; "Edited 20-Oct-91 10:55 by jn") (MOVD 'CREATEW 'CREATEW.DISPLAY) (MOVD 'CREATEW.NEW 'CREATEW) (MOVD 'CLOSEW 'CLOSEW.DISPLAY) (MOVD 'CLOSEW.NEW 'CLOSEW) (MOVD 'OPENW 'OPENW.DISPLAY) (MOVD 'OPENW.NEW 'OPENW) (MOVD 'MOVEW 'MOVEW.DISPLAY) (MOVD 'MOVEW.NEW 'MOVEW) (MOVD 'SHAPEW 'SHAPEW.DISPLAY) (MOVD 'SHAPEW.NEW 'SHAPEW) (MOVD 'SHRINKW 'SHRINKW.DISPLAY) (MOVD 'SHRINKW.NEW 'SHRINKW) (MOVD 'EXPANDW 'EXPANDW.DISPLAY) (MOVD 'EXPANDW.NEW 'EXPANDW) (SETQ \XSCREEN (CREATESCREEN XLIB::*ROOT*)) [replace (SCREEN SCDATA) of \XSCREEN with (SETQ \XDisplayWindowOps (CREATE WINDOWOPS CREATEW _ (FUNCTION CREATEW.XDISPLAY) OPENW _ (FUNCTION OPENW.XDISPLAY) CLOSEW _ (FUNCTION CLOSEW.XDISPLAY) MOVEW _ (FUNCTION MOVEW.XDISPLAY) SHAPEW _ (FUNCTION SHAPEW.XDISPLAY) SHRINKW _ (FUNCTION SHRINKW.XDISPLAY) EXPANDW _ (FUNCTION EXPANDW.XDISPLAY] [replace (SCREEN SCDATA) of \MAINSCREEN with (SETQ \DisplayWindowOps (CREATE WINDOWOPS CREATEW _ (FUNCTION CREATEW.DISPLAY) OPENW _ (FUNCTION OPENW.DISPLAY) CLOSEW _ (FUNCTION CLOSEW.DISPLAY) MOVEW _ (FUNCTION MOVEW.DISPLAY) SHAPEW _ (FUNCTION SHAPEW.DISPLAY) SHRINKW _ (FUNCTION SHRINKW.DISPLAY) EXPANDW _ (FUNCTION EXPANDW.DISPLAY] (CL:PUSH \XSCREEN \SCREENS]) ) (RPAQQ XMAS2COMS ((RECORDS WINDOWOPS) (FNS CREATESCREEN DSPCREATE CREATEW.NEW OPENW.NEW CLOSEW.NEW MOVEW.NEW SHAPEW.NEW SHRINKW.NEW EXPANDW.NEW) (FNS CREATEW.XDISPLAY OPENW.XDISPLAY CLOSEW.XDISPLAY MOVEW.XDISPLAY SHAPEW.XDISPLAY SHRINKW.XDISPLAY EXPANDW.XDISPLAY TOTOPW.XDISPLAY BURYW.XDISPLAY) (FNS \XOPENW1 XSHOWWFRAME ADVISEXWDS XMOVEORRESIZED.WINDOW \XMOUSELEFT \XMOUSEMOVED \FINDWINDOW \XMOUSEENTERED XMOVEW \XCLOSEW1 XSHAPEW \XSHAPEW1 XCREATEWFROMPIXMAP XCLOSEMAINWINDOW \XINTERNALTOTOPW) (FNS ISXWINDOW?) (FNS INIT.XMAS2) (VARS XMAS2COMS))) (PUTPROPS XMAS2 COPYRIGHT ("Fuji Xerox Co., Ltd" 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1816 10841 (CREATESCREEN 1826 . 3905) (DSPCREATE 3907 . 7484) (CREATEW.NEW 7486 . 8271) (OPENW.NEW 8273 . 8747) (CLOSEW.NEW 8749 . 9129) (MOVEW.NEW 9131 . 9614) (SHAPEW.NEW 9616 . 10006) ( SHRINKW.NEW 10008 . 10458) (EXPANDW.NEW 10460 . 10839)) (10842 30847 (CREATEW.XDISPLAY 10852 . 13334) (OPENW.XDISPLAY 13336 . 13835) (CLOSEW.XDISPLAY 13837 . 14174) (MOVEW.XDISPLAY 14176 . 18419) ( SHAPEW.XDISPLAY 18421 . 21590) (SHRINKW.XDISPLAY 21592 . 28583) (EXPANDW.XDISPLAY 28585 . 29816) ( TOTOPW.XDISPLAY 29818 . 30569) (BURYW.XDISPLAY 30571 . 30845)) (30848 57817 (\XOPENW1 30858 . 32860) ( XSHOWWFRAME 32862 . 36235) (ADVISEXWDS 36237 . 42690) (XMOVEORRESIZED.WINDOW 42692 . 44286) ( \XMOUSELEFT 44288 . 44760) (\XMOUSEMOVED 44762 . 45165) (\FINDWINDOW 45167 . 45683) (\XMOUSEENTERED 45685 . 46087) (XMOVEW 46089 . 50325) (\XCLOSEW1 50327 . 51941) (XSHAPEW 51943 . 55096) (\XSHAPEW1 55098 . 56108) (XCREATEWFROMPIXMAP 56110 . 57083) (XCLOSEMAINWINDOW 57085 . 57578) (\XINTERNALTOTOPW 57580 . 57815)) (57818 58184 (ISXWINDOW? 57828 . 58182)) (58185 61281 (INIT.XMAS2 58195 . 61279))))) STOP \ No newline at end of file diff --git a/obsolete/sources/new-edit-interface.tedit b/obsolete/sources/new-edit-interface.tedit deleted file mode 100644 index 693420f8..00000000 Binary files a/obsolete/sources/new-edit-interface.tedit and /dev/null differ diff --git a/obsolete/sources/subrs.h b/obsolete/sources/subrs.h deleted file mode 100644 index 8f8dd528..00000000 --- a/obsolete/sources/subrs.h +++ /dev/null @@ -1,150 +0,0 @@ -/* This file written from LLSUBRS on 17-Mar-2021 11:14:28 */ -/* Do not edit this file! Instead, edit the list \initsubrs */ -/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to */ -/* generate a new version. */ -#ifndef SUBRS_H -#define SUBRS_H 1 -#define sb_YIELD 0322 -#define sb_BACKGROUNDSUBR 06 -#define sb_CHECKBCPLPASSWORD 07 -#define sb_DISKPARTITION 010 -#define sb_DSPBOUT 011 -#define sb_DSPRATE 012 -#define sb_GATHERSTATS 013 -#define sb_GETPACKETBUFFER 014 -#define sb_LISPFINISH 015 -#define sb_MOREVMEMFILE 016 -#define sb_RAID 017 -#define sb_READRAWPBI 020 -#define sb_WRITERAWPBI 021 -#define sb_SETSCREENCOLOR 022 -#define sb_SHOWDISPLAY 023 -#define sb_PUPLEVEL1STATE 024 -#define sb_WRITESTATS 025 -#define sb_CONTEXTSWITCH 026 -#define sb_COPYSYS0SUBR 027 -#define sb_WRITEMAP 030 -#define sb_UFS_GETFILENAME 042 -#define sb_UFS_DELETEFILE 043 -#define sb_UFS_RENAMEFILE 044 -#define sb_COM_READPAGES 045 -#define sb_COM_WRITEPAGES 046 -#define sb_COM_TRUNCATEFILE 047 -#define sb_UFS_DIRECTORYNAMEP 051 -#define sb_COM_GETFREEBLOCK 055 -#define sb_SETUNIXTIME 060 -#define sb_GETUNIXTIME 061 -#define sb_COPYTIMESTATS 062 -#define sb_UNIX_USERNAME 063 -#define sb_UNIX_FULLNAME 064 -#define sb_UNIX_GETENV 065 -#define sb_UNIX_GETPARM 066 -#define sb_CHECK_SUM 067 -#define sb_ETHER_SUSPEND 070 -#define sb_ETHER_RESUME 071 -#define sb_ETHER_AVAILABLE 072 -#define sb_ETHER_RESET 073 -#define sb_ETHER_GET 074 -#define sb_ETHER_SEND 075 -#define sb_ETHER_SETFILTER 076 -#define sb_ETHER_CHECK 077 -#define sb_DSPCURSOR 0100 -#define sb_SETMOUSEXY 0101 -#define sb_DSP_VIDEOCOLOR 0102 -#define sb_DSP_SCREENWIDTH 0103 -#define sb_DSP_SCREENHEIGHT 0104 -#define sb_BITBLTSUB 0105 -#define sb_BLTCHAR 0106 -#define sb_TEDIT_BLTCHAR 0107 -#define sb_BITBLT_BITMAP 0110 -#define sb_BLTSHADE_BITMAP 0111 -#define sb_RS232C_CMD 0112 -#define sb_RS232C_READ_INIT 0113 -#define sb_RS232C_WRITE 0114 -#define sb_KEYBOARDBEEP 0120 -#define sb_KEYBOARDMAP 0121 -#define sb_KEYBOARDSTATE 0122 -#define sb_VMEMSAVE 0131 -#define sb_LISP_FINISH 0132 -#define sb_NEWPAGE 0133 -#define sb_DORECLAIM 0134 -#define sb_DUMMY_135Q 0135 -#define sb_NATIVE_MEMORY_REFERENCE 0136 -#define sb_OLD_COMPILE_LOAD_NATIVE 0137 -#define sb_DISABLEGC 0140 -#define sb_COM_SETFILEINFO 0147 -#define sb_COM_OPENFILE 0150 -#define sb_COM_CLOSEFILE 0151 -#define sb_DSK_GETFILENAME 0152 -#define sb_DSK_DELETEFILE 0153 -#define sb_DSK_RENAMEFILE 0154 -#define sb_COM_NEXT_FILE 0156 -#define sb_COM_FINISH_FINFO 0157 -#define sb_COM_GEN_FILES 0160 -#define sb_DSK_DIRECTORYNAMEP 0161 -#define sb_COM_GETFILEINFO 0162 -#define sb_COM_CHANGEDIR 0164 -#define sb_UNIX_HANDLECOMM 0165 -#define sb_RPC_CALL 0167 -#define sb_MESSAGE_READP 0170 -#define sb_MESSAGE_READ 0171 -#define sb_MONITOR_CONTROL 0200 -#define sb_GET_NATIVE_ADDR_FROM_LISP_PTR 0203 -#define sb_GET_LISP_PTR_FROM_NATIVE_ADDR 0204 -#define sb_LOAD_NATIVE_FILE 0205 -#define sb_SUSPEND_LISP 0206 -#define sb_NEW_BLTCHAR 0207 -#define sb_COLOR_INIT 0210 -#define sb_COLOR_SCREENMODE 0211 -#define sb_COLOR_MAP 0212 -#define sb_COLOR_BASE 0213 -#define sb_C_SlowBltChar 0214 -#define sb_UNCOLORIZE_BITMAP 0215 -#define sb_COLORIZE_BITMAP 0216 -#define sb_COLOR_8BPPDRAWLINE 0217 -#define sb_TCP_OP 0220 -#define sb_WITH_SYMBOL 0221 -#define sb_CAUSE_INTERRUPT 0222 -#define sb_OPEN_SOCKET 0240 -#define sb_CLOSE_SOCKET 0241 -#define sb_READ_SOCKET 0242 -#define sb_WRITE_SOCKET 0243 -#define sb_CALL_C_FUNCTION 0247 -#define sb_DLD_LINK 0250 -#define sb_DLD_UNLINK_BY_FILE 0251 -#define sb_DLD_UNLINK_BY_SYMBOL 0252 -#define sb_DLD_GET_SYMBOL 0253 -#define sb_DLD_GET_FUNC 0254 -#define sb_DLD_FUNCTION_EXECUTABLE_P 0255 -#define sb_DLD_LIST_UNDEFINED_SYMBOLS 0256 -#define sb_C_MALLOC 0257 -#define sb_C_FREE 0260 -#define sb_C_PUTBASEBYTE 0261 -#define sb_C_GETBASEBYTE 0262 -#define sb_CHAR_OPENFILE 0310 -#define sb_CHAR_BIN 0311 -#define sb_CHAR_BOUT 0312 -#define sb_CHAR_IOCTL 0313 -#define sb_CHAR_CLOSEFILE 0314 -#define sb_CHAR_EOFP 0315 -#define sb_CHAR_READP 0316 -#define sb_CHAR_BINS 0317 -#define sb_CHAR_BOUTS 0320 -#define sb_CHAR_FILLBUFFER 0321 -/* MISCN opcodes */ -#define miscn_USER_SUBR 00 -#define miscn_VALUES 01 -#define miscn_SXHASH 02 -#define miscn_EQLHASHBITSFN 03 -#define miscn_STRINGHASHBITS 04 -#define miscn_STRING_EQUAL_HASHBITS 05 -#define miscn_VALUES_LIST 06 -#define miscn_LCFetchMethod 07 -#define miscn_LCFetchMethodOrHelp 010 -#define miscn_LCFindVarIndex 011 -#define miscn_LCGetIVValue 012 -#define miscn_LCPutIVValue 013 -/* Assigned USER SUBR numbers */ -#define user_subr_DUMMY 012 -#define user_subr_SAMPLE_USER_SUBR 00 -#endif diff --git a/obsolete/sunloadup/FASTINIT b/obsolete/sunloadup/FASTINIT deleted file mode 100644 index 9ca76db7..00000000 --- a/obsolete/sunloadup/FASTINIT +++ /dev/null @@ -1,82 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "26-Jan-90 11:46:56" |{DSK}/home/neptune/jds/FASTINIT.;1| 2946 - - |changes| |to:| (VARS FASTINITCOMS) - (FNS FASTSETAW FASTSETA FASTELTW FASTELT)) - - -(PRETTYCOMPRINT FASTINITCOMS) - -(RPAQQ FASTINITCOMS ( - (* |;;| - "Function definitions for the \"fast\" array accessors used in making the INIT.") - - - (* |;;| - "<...>Library>VMEM defines these as ELT & SETA, which aren't too fast.") - - - (* |;;| - "This is an attempt to speed up INIT building on Suns. --JDS 1/26/90") - - (FNS FASTELT FASTELTW FASTSETA FASTSETAW))) - - - -(* |;;| "Function definitions for the \"fast\" array accessors used in making the INIT.") - - - - -(* |;;| "<...>Library>VMEM defines these as ELT & SETA, which aren't too fast.") - - - - -(* |;;| "This is an attempt to speed up INIT building on Suns. --JDS 1/26/90") - -(DEFINEQ - -(FASTELT - (LAMBDA (A N) (* \; "Edited 26-Jan-90 11:39 by jds") - - (* |;;| "Fast version of pointer-array ELT, for use in building INIT.") - - (PROG ((BASE (|ffetch| (ARRAYP BASE) |of| A)) - (N0 (IDIFFERENCE N (|ffetch| (ARRAYP ORIG) |of| A)))) - (SETQ N0 (IPLUS N0 (|ffetch| (ARRAYP OFFST) |of| A))) - (RETURN (\\GETBASEPTR (\\ADDBASE2 BASE N0) - 0))))) - -(FASTELTW - (LAMBDA (A N) (* \; "Edited 26-Jan-90 11:40 by jds") - (PROG ((BASE (|fetch| (ARRAYP BASE) |of| A)) - (N0 (IDIFFERENCE N (|fetch| (ARRAYP ORIG) |of| A)))) - (SETQ N0 (IPLUS N0 (|fetch| (ARRAYP OFFST) |of| A))) - (RETURN (\\GETBASE BASE N0))))) - -(FASTSETA - (LAMBDA (A N V) (* \; "Edited 26-Jan-90 11:41 by jds") - - (* |;;| "Fast version of SETA for pointer arrays for the INIT building code.") - - (PROG ((BASE (|fetch| (ARRAYP BASE) |of| A)) - (N0 (IDIFFERENCE N (|fetch| (ARRAYP ORIG) |of| A)))) - (SETQ N0 (IPLUS N0 (|fetch| (ARRAYP OFFST) |of| A))) - (RETURN (\\RPLPTR (\\ADDBASE2 BASE N0) - 0 V))))) - -(FASTSETAW - (LAMBDA (A N V) (* \; "Edited 26-Jan-90 11:42 by jds") - - (* |;;| "Fast version of SETA for wrod-arrays, for INIT building code.") - - (PROG ((BASE (|fetch| (ARRAYP BASE) |of| A)) - (N0 (IDIFFERENCE N (|fetch| (ARRAYP ORIG) |of| A)))) - (SETQ N0 (IPLUS N0 (|fetch| (ARRAYP OFFST) |of| A))) - (RETURN (\\PUTBASE BASE N0 V))))) -) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (1126 2923 (FASTELT 1136 . 1622) (FASTELTW 1624 . 1983) (FASTSETA 1985 . 2474) ( -FASTSETAW 2476 . 2921))))) -STOP diff --git a/obsolete/sunloadup/FASTINIT-2.0.DFASL b/obsolete/sunloadup/FASTINIT-2.0.DFASL deleted file mode 100644 index 09dbca9e..00000000 Binary files a/obsolete/sunloadup/FASTINIT-2.0.DFASL and /dev/null differ diff --git a/obsolete/sunloadup/FASTINIT.DFASL b/obsolete/sunloadup/FASTINIT.DFASL deleted file mode 100644 index d58457d7..00000000 Binary files a/obsolete/sunloadup/FASTINIT.DFASL and /dev/null differ diff --git a/obsolete/sunloadup/FILESETS b/obsolete/sunloadup/FILESETS deleted file mode 100644 index fc1d0976..00000000 --- a/obsolete/sunloadup/FILESETS +++ /dev/null @@ -1,69 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 9-Apr-90 16:57:44" {DSK}mitani>SUNLOADUP>FILESETS;2 5281 - - changes to%: (VARS 1LISPSET) - - previous date%: " 5-Apr-89 16:28:12" {DSK}mitani>SUNLOADUP>FILESETS;1) - - -(* " -Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT FILESETSCOMS) - -(RPAQQ FILESETSCOMS ((* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS))) - - - -(* ;;; "contains all of the lists of files which are used in various ways") - - - - -(* ;; -"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" -) - - -(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET)) - -(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE IOCHAR LLKEY LLTIMER)) - -(RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PUP LEAF PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) - -(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) - -(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) - -(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) - -(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) - -(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) - -(RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY)) - -(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) - -(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) - -(RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) - -(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) - -(RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET))) - -(RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES)))) - -(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) - -(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) - -(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) - -(RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL))) -(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/sunloadup/FILESETS.NOETHER b/obsolete/sunloadup/FILESETS.NOETHER deleted file mode 100644 index 5f3a9f88..00000000 --- a/obsolete/sunloadup/FILESETS.NOETHER +++ /dev/null @@ -1,175 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "15-Feb-90 16:21:14" {DSK}/users/osamu/SUNLOADUP/FILESETS.;1 6850 - - previous date%: " 5-Apr-89 16:28:12" {ERIS}SUNLOADUP>FILESETS.;7) - - -(* " -Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT FILESETSCOMS) - -(RPAQQ FILESETSCOMS - ( - -(* ;;; "contains all of the lists of files which are used in various ways") - - - (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") - - - (* ;; "'90/02/15 osamu: REMOVE LLETHER from 1LISPSET.") - - (VARS * FILESETS) - (VARS EXPORTFILES) - (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) - (VARS DEADFNS))) - - - -(* ;;; "contains all of the lists of files which are used in various ways") - - - - -(* ;; -"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" -) - - - - -(* ;; "'90/02/15 osamu: REMOVE LLETHER from 1LISPSET.") - - -(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET - 9LISPSET)) - -(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC - LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS - LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) - -(RPAQQ 1LISPSET - (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM - APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV - CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE - XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ - COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS - MAIKOBITBLT MAIKOINIT)) - -(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) - -(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) - -(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) - -(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) - -(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) - -(RPAQQ 7LISPSET - (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT - INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT - CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN - DPUPFTP FLOPPY)) - -(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) - -(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) - -(RPAQQ EXPORTFILES - (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW - LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY - ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER - LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) - -(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) - -(RPAQQ MAKEINITTYPES - ((NIL INIT (0 1) - 2LISPSET 1600) - (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD - LLCHAR TINYPATCH)) - (MACROTEST MACROTEST ((MACROTEST) - 0 1) - 2LISPSET) - (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) - (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) - (NULL NULL ((DUMMY))) - (MILLITEST MILLITEST - ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT - LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) - (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) - 2LISPSET))) - -(RPAQQ RENAMETYPES - ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS - MODARITH LLFAULT LLKEY LLBFS LLTIMER) - (RENAMEDFILE . I-NEW) - (SUBNAME . MKI.SUBFNS) - (COMSNAME . INEWCOMS) - (EXTRACOMS (VARS INITPTRS INITVALUES) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - MAKEINIT))) - (MKI.SUBFNS) - (INEWCOMS) - (VALUES . INITVALUES) - (PTRS . INITPTRS) - (PREFIX . I.) - (VAG2FN . I.VAG2)) - (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK - RENAMEMACROS MODARITH LLFAULT) - (RENAMEDFILE . RDSYS) - (SUBNAME . RD.SUBFNS) - (COMSNAME . RDCOMS) - (EXTRACOMS (FILES VMEM) - (VARS RDVALS RDPTRS) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - VMEM))) - (RD.SUBFNS (\CALLME . *)) - (RDCOMS) - (PTRS . RDPTRS) - (PREFIX . V) - (VAG2FN . VVAG2) - (VALUES . RDVALS) - (RDPTRS) - (RDVALUES)))) - -(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 - DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) - -(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) - -(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) - (3LISPSET DLAP) - (4LISPSET DFILE DMISC) - 7LISPSET - (8LISPSET MAKEINIT MEM) - 9LISPSET - (10LISPSET LLPARAMS) - (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) - -(RPAQQ DEADFNS - ((PUTBASE \PUTBASE) - (GETBASE \GETBASE) - (ADDBASE \ADDBASE) - (GETBASEBYTE \GETBASEBYTE) - (PUTBASEBYTE \PUTBASEBYTE) - (PUTBASEPTR \PUTBASEPTR) - (HILOC \HILOC) - (LOLOC \LOLOC) - (VAG2 \VAG2) - (PAGEBASE NIL) - (PAGELOC NIL) - (WordsPerPage WORDSPERPAGE) - (ALTOMACRO DMACRO) - (\STACKSPACE ??) - (GETBASEPTR \GETBASEPTR) - (FPLUS2) - (FTIMES2) - (CREATECELL \CREATECELL))) -(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/sunloadup/FILESETS.ORIG b/obsolete/sunloadup/FILESETS.ORIG deleted file mode 100644 index ea51dea1..00000000 --- a/obsolete/sunloadup/FILESETS.ORIG +++ /dev/null @@ -1,168 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-Apr-89 16:28:12" {ERIS}SUNLOADUP>FILESETS.;7 7015 - - changes to%: (VARS 1LISPSET) - - previous date%: " 6-Feb-89 15:49:03" {ERIS}SUNLOADUP>FILESETS.;6) - - -(* " -Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT FILESETSCOMS) - -(RPAQQ FILESETSCOMS ( - -(* ;;; "contains all of the lists of files which are used in various ways") - - - (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") - - (VARS * FILESETS) - (VARS EXPORTFILES) - (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES - DATABASEFILES) - (VARS DEADFNS))) - - - -(* ;;; "contains all of the lists of files which are used in various ways") - - - - -(* ;; -"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" -) - - -(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET - 9LISPSET)) - -(RPAQQ 0LISPSET - (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT - LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM - LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) - -(RPAQQ 1LISPSET - (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM - APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV - CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE - XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PASSWORDS FONT SUNFONT LLDISPLAY - APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) - -(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) - -(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) - -(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) - -(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) - -(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) - -(RPAQQ 7LISPSET - (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT - INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT - CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN - DPUPFTP FLOPPY)) - -(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) - -(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) - -(RPAQQ EXPORTFILES - (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW - LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY - ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER - LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) - -(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) - -(RPAQQ MAKEINITTYPES - ((NIL INIT (0 1) - 2LISPSET 1600) - (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD - LLCHAR TINYPATCH)) - (MACROTEST MACROTEST ((MACROTEST) - 0 1) - 2LISPSET) - (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) - (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) - (NULL NULL ((DUMMY))) - (MILLITEST MILLITEST - ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT - LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) - (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) - 2LISPSET))) - -(RPAQQ RENAMETYPES - ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS - MODARITH LLFAULT LLKEY LLBFS LLTIMER) - (RENAMEDFILE . I-NEW) - (SUBNAME . MKI.SUBFNS) - (COMSNAME . INEWCOMS) - (EXTRACOMS (VARS INITPTRS INITVALUES) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - MAKEINIT))) - (MKI.SUBFNS) - (INEWCOMS) - (VALUES . INITVALUES) - (PTRS . INITPTRS) - (PREFIX . I.) - (VAG2FN . I.VAG2)) - (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK - RENAMEMACROS MODARITH LLFAULT) - (RENAMEDFILE . RDSYS) - (SUBNAME . RD.SUBFNS) - (COMSNAME . RDCOMS) - (EXTRACOMS (FILES VMEM) - (VARS RDVALS RDPTRS) - (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) - VMEM))) - (RD.SUBFNS (\CALLME . *)) - (RDCOMS) - (PTRS . RDPTRS) - (PREFIX . V) - (VAG2FN . VVAG2) - (VALUES . RDVALS) - (RDPTRS) - (RDVALUES)))) - -(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 - DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) - -(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) - -(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) - (3LISPSET DLAP) - (4LISPSET DFILE DMISC) - 7LISPSET - (8LISPSET MAKEINIT MEM) - 9LISPSET - (10LISPSET LLPARAMS) - (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) - -(RPAQQ DEADFNS ((PUTBASE \PUTBASE) - (GETBASE \GETBASE) - (ADDBASE \ADDBASE) - (GETBASEBYTE \GETBASEBYTE) - (PUTBASEBYTE \PUTBASEBYTE) - (PUTBASEPTR \PUTBASEPTR) - (HILOC \HILOC) - (LOLOC \LOLOC) - (VAG2 \VAG2) - (PAGEBASE NIL) - (PAGELOC NIL) - (WordsPerPage WORDSPERPAGE) - (ALTOMACRO DMACRO) - (\STACKSPACE ??) - (GETBASEPTR \GETBASEPTR) - (FPLUS2) - (FTIMES2) - (CREATECELL \CREATECELL))) -(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/sunloadup/FILESETS.PUP b/obsolete/sunloadup/FILESETS.PUP deleted file mode 100644 index cfc9462d..00000000 --- a/obsolete/sunloadup/FILESETS.PUP +++ /dev/null @@ -1,69 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 9-Apr-90 16:57:44" {DSK}mitani>SUNLOADUP>FILESETS;2 5281 - - changes to%: (VARS 1LISPSET) - - previous date%: " 5-Apr-89 16:28:12" {DSK}mitani>SUNLOADUP>FILESETS;1) - - -(* " -Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. -") - -(PRETTYCOMPRINT FILESETSCOMS) - -(RPAQQ FILESETSCOMS ((* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS))) - - - -(* ;;; "contains all of the lists of files which are used in various ways") - - - - -(* ;; -"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" -) - - -(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET)) - -(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) - -(RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PUP LEAF PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) - -(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) - -(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) - -(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) - -(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) - -(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) - -(RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY)) - -(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) - -(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) - -(RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) - -(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) - -(RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET))) - -(RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES)))) - -(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) - -(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) - -(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) - -(RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL))) -(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990)) -(DECLARE%: DONTCOPY - (FILEMAP (NIL))) -STOP diff --git a/obsolete/sunloadup/HOWTO-LOADUP-SUNLISP.TXT b/obsolete/sunloadup/HOWTO-LOADUP-SUNLISP.TXT deleted file mode 100644 index 9e250cf3..00000000 --- a/obsolete/sunloadup/HOWTO-LOADUP-SUNLISP.TXT +++ /dev/null @@ -1,173 +0,0 @@ -Notes on making a Sun Loadup - -update Jan. 25, 1990 by osamu - -In a medley sysout on cottonmouth do the following: - -;;CONN {DSK}/cottonmouth/users/medley/sources/ - --- Make sure all the files are current. There are SUN specific changes to --- the following files: - --- FILESETS: took PUP and LEAF out of 1LISPSET - -(CL:IN-PACKAGE "IL") - --- make copyfiles go faster - -(SETQ COPYFILESENUMERATE NIL) - -(COPYFILES '{ERIS}SOURCES>*.* - '{DSK}/cottonmouth/USERS/MEDLEY/SOURCES/ '(>A)) - -(COPYFILE '{ERIS}SUNLOADUP>FILESETS 'FILESETS) - -(COPYFILE '{ERIS}SUNLOADUP>LOADUP.LISP 'LOADUP.LISP) - -(COPYFILE '{ERIS}SUNLOADUP>FIX-ETHER.LCOM 'FIX-ETHER.LCOM) - -(COPYFILES '{ERIS}SUNLOADUP>MAIKOLOADUPFNS.* '{DSK}/cottonmouth/USERS/MEDLEY/SOURCES/ '(>A)) - - --- You will need the instructions on your local directory. - -;;;(COPYFILE '{ERIS}SUNLOADUP>HOWTO-LOADUPSUN.TXT '{DSK}HOWTO-LOADUP-SUNLISP.TXT) - --- set the directories so you can find all the proper files... - -;;;(SETQ DIRECTORIES '( -;;;"{DSK}/home2/will/sybalsky/lispcore/Sources/" -;;; "{DSK}/home2/will/sybalsky/lispcore/library/" -;;; "{DSK}/home2/will/sybalsky/lispcore/internal/library/" ;;;"{dsk}/home2/will/sybalsky/lispcore/sunloadup/")) - -(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG") - -;(SETQ DIRECTORIES '( -;"{DSK}~/SUNLOADUP/lispcore/Sources/" -; "{DSK}~/SUNLOADUP/lispcore/library/" -; "{DSK}~/SUNLOADUP/lispcore/internal/library/" "{dsk}~/SUNLOADUP/lispcore/sunloadup/")) - -(SETQ DIRECTORIES '( -"{DSK}/users/sybalsky/lispcore/Sources/" - "{DSK}/users/sybalsky/lispcore/library/" - "{DSK}/users/sybalsky/lispcore/internal/library/" "{dsk}/users/sybalsky/lispcore/sunloadup/")) - - ---you really want the source code for this - -(LOAD 'FILESETS) - -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}/users/sybalsky/FASTINIT.DFASL") - --- turn off idle or you get stuck. - -(IDLE.SET.OPTION 'TIMEOUT T) - --- and start making the init. This takes about 2.5 hrs. - -;(PROGN -; (DORENAME 'I) -; (DLFIXINIT -; (MAKEINIT '(11500Q 13062Q 25400Q) -; NIL NIL -; '({DSK}/home2/will/sybalsky/lispcore/Sources/ {dsk}/home2/will/sybalsky/lispcore/sunloadup/ )) -; '{DSK}INIT.DLINIT -; '{dsk}/medley/project4/venue/LISPDLION.DB -; 300) -; (COPYFILE '{eris}sunloadup>XREM.CM '{DSK}XREM.CM) -; (COPYFILE '{eris}sunloadup>LOADUP-REM.CM '{DSK}LOADUP-REM.CM) -; (LOGOUT T) -;) -(PROGN - (DORENAME 'I) - (DLFIXINIT - (MAKEINIT '(11500Q 13062Q 25400Q) - NIL NIL - '({DSK}/users/sybalsky/lispcore/Sources/ {dsk}/users/sybalsky/lispcore/sunloadup/ )) - '{DSK}INIT.DLINIT - '{dsk}/users/sybalsky/lispcore/next/LISPDLION.DB - 300) - (COPYFILE '{dsk}/users/sybalsky/lispcore/sunloadup/XREM.CM - '{DSK}SUNLOADUP/XREM.CM) - (COPYFILE '{dsk}/users/sybalsky/lispcore/sunloadup/LOADUP-REM.CM - '{DSK}SUNLOADUP/LOADUP-REM.CM) - (DATE) - (DRIBBLE) - (LOGOUT T) -) - --- Now, if you are on the "loadup" machine, exit medley and go to another --- machine. RLOGIN to the loadup machine and do the following: - --- Build an init-specific lde note: you must have a directory under --- the maiko directory called init.ARCH where ARCH is the architecture --- of the machine you will run the lde on. On a sun4, it would be init.sparc. - -cd ~/maiko/bin -makeinitlde -e - --- connect back to your home directory and make a link to the lde and --- ldeether (fill in yourname and machine os and arch in the proper --- slots below - -cd ~ -ln -s /users/YOURNAME/maiko/init.ARCH/lde -ln -s /users/YOURNAME/maiko/init.ARCH/ldeether - --- make sure you don't have LDEDESTSYSOUT set as you want the sysout on your home --- directory. - --- You will need dbxinit.txt available - --- YOU MUST USE A FRESH COPY OF XREM.CM EVERY TIME YOU TRY THIS AS IT --- GETS SMASHED AT STARTUP - -cp ~/XREM.CM ~/REM.CM - --- start lde under dbx - --- init lde can't treat 'LDEDESTSYSOUT' -unsetenv LDEDESTSYSOUT - -dbx lde - --- load the dbxinit - -source /users/maiko/working/bin/dbxinit.txt - --- now set up to stop on error (before URAID, which loses 'cause --- it can't find the keyboard.) - -err - -run ~/INIT.DLINIT -INIT -NF - --- this is going to run and eventually log itself out. when dbx returns, quit --- from dbx and presto! You've built the beginnings of a loadup. - ---- - --- go to the loadup machine and connect to the place where you normally --- get your lde from - -cd ~/maiko/sunos4.sparc/ - --- Get the new REM.CM: (YOU MUST DO THIS EVERYTIME AS --- REM.CM gets wasted on startup!!) - -cp ~/LOADUP-REM.CM ~/REM.CM -ldeether - --- Now this is going to march happily through loading files. When it turns --- on the windowworld, you may have to hit the space bar to make it continue. - --- I don't know how to make PUP and LEAF load at this point, but I'm working --- on it. - --- I am also working on integrating the changes to the emulator with the latest --- stuff. - --- closure caching is still off. - --- Questions or comments? diff --git a/obsolete/sunloadup/HOWTO-MAKE-SYSOUT.TEDIT b/obsolete/sunloadup/HOWTO-MAKE-SYSOUT.TEDIT deleted file mode 100644 index 400adf15..00000000 Binary files a/obsolete/sunloadup/HOWTO-MAKE-SYSOUT.TEDIT and /dev/null differ diff --git a/obsolete/sunloadup/INIT.DO-TEST b/obsolete/sunloadup/INIT.DO-TEST deleted file mode 100644 index 3a569f01..00000000 --- a/obsolete/sunloadup/INIT.DO-TEST +++ /dev/null @@ -1,55 +0,0 @@ -;; Automatic DO-TEST -(in-package "INTERLISP") - -;; search path when file not found on current directory -;(SETQ DIRECTORIES '( -; "{dsk}/usr/local/lde/internal/library/" -;)) - -;; paths for display fonts; list the ones that are installed -(SETQ DISPLAYFONTDIRECTORIES - '("{DSK}/usr/local/lde/fonts/display/presentation" - "{DSK}/usr/local/lde/fonts/display/publishing" - "{DSK}/usr/local/lde/fonts/display/printwheel" - "{DSK}/usr/local/lde/fonts/display/miscellaneous" - "{DSK}/usr/local/lde/fonts/display/jis1" - "{DSK}/usr/local/lde/fonts/display/jis2" - "{DSK}/usr/local/lde/fonts/display/chinese")) - -;; paths for interpress font widths; list the ones that are installed -(SETQ INTERPRESSFONTDIRECTORIES - '("{DSK}/usr/local/lde/fonts/interpress/presentation" - "{DSK}/usr/local/lde/fonts/interpress/publishing" - "{DSK}/usr/local/lde/fonts/interpress/printwheel" - "{DSK}/usr/local/lde/fonts/interpress/miscellaneous" - "{DSK}/usr/local/lde/fonts/interpress/jis1" - "{DSK}/usr/local/lde/fonts/interpress/jis2" - "{DSK}/usr/local/lde/fonts/interpress/chinese")) - -;; let any user with a valid UNIX login to exit Idle mode -(LISTPUT IDLE.PROFILE 'AUTHENTICATE 'UNIX) -(LISTPUT IDLE.PROFILE 'ALLOWED.LOGINS '(*)) -(LISTPUT IDLE.PROFILE 'SAVEVM NIL) -(IDLE.SET.OPTION 'TIMEOUT T) -(SETQ |\\BeginDST| 98) -(SETQ |\\EndDST| 305) - -;; edit to have your particular site parameters-- for standalone, short -;; site name is host name - -(SETQ XCL:*LONG-SITE-NAME* -(SETQ XCL:*SHORT-SITE-NAME* (UNIX-GETPARM "HOSTNAME"))) - -;; Now loading DO-TEST and run DO-TEST -;(load "{DSK}/python1/fuji/TESTTOOL/omake/DO-TEST.DFASL") -(load "{DSK}~/lispcore/internal/library/DO-TEST.DFASL") -(il:load? 'masterscope.dfasl) - -(il:cndir "{dsk}/python1/fuji/TESTTOOL/LANGUAGE/") -(xcl-test::do-all-tests - :results "{DSK}~/DO-TEST/AUTO-TESTS.results" - :patterns '("*.TEST")) - -(DATE) -(PRINT "DO-TEST completed.") - diff --git a/obsolete/sunloadup/INIT.LOADFULL b/obsolete/sunloadup/INIT.LOADFULL deleted file mode 100644 index 3bbaf7cf..00000000 --- a/obsolete/sunloadup/INIT.LOADFULL +++ /dev/null @@ -1,5 +0,0 @@ -" -SHH(LOAD '{DSK}~/SUNLOADUP/LOADFULL.LISP) -SHH(MAKESYS '{DSK}~/FULL.SYSOUT] -SHH(LOGOUT] " - diff --git a/obsolete/sunloadup/INIT.LOADFULLFROMLISP b/obsolete/sunloadup/INIT.LOADFULLFROMLISP deleted file mode 100644 index 431211f1..00000000 --- a/obsolete/sunloadup/INIT.LOADFULLFROMLISP +++ /dev/null @@ -1,2 +0,0 @@ -(PROGN (ILLOAD '{dsk}SUNLOADUP/LOADFULL.LISP) (ILMAKESYS 'FULL.SYSOUT) (ILLOGOUT T)) - diff --git a/obsolete/sunloadup/INIT.MAKEBIG b/obsolete/sunloadup/INIT.MAKEBIG deleted file mode 100644 index c458e4a0..00000000 --- a/obsolete/sunloadup/INIT.MAKEBIG +++ /dev/null @@ -1,50 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; Same as INIT.MAKEINITFULL, but points to DSK for files, not Pele:. -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}~/lispcore/SUNLOADUP/LOADUP.LOG") -(SETQ CH.DEFAULT.DOMAIN "mv") -(SETQ CH.DEFAULT.ORGANIZATION "envos") -(CNDIR "{dsk}~/lispcore/sources/") -(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0) -(SETQ CROSSCOMPILING T) - -(SETQ DIRECTORIES '( - "{dsk}~/lispcore/sources/" "{dsk}~/lispcore/library/" - "{DSK}~/lispcore/internal/library/" - "{DSK}~/lispcore/sunloadup/" )) -(LOAD "{dsk}~/lispcore/SUNLOADUP/FILESETS") -;;(PUTPROP :D8 'CODEREADER (GETPROP :D7 'CODEREADER)) -(LOAD "{dsk}~/lispcore/library/VMEM.LCOM") -(LOAD "{dsk}~/lispcore/sources/MEM.LCOM") -(LOAD "{dsk}~/lispcore/library/READSYS.LCOM") -(LOAD "{dsk}~/lispcore/library/RDSYS.LCOM") -(LOAD "{DSK}~/lispcore/sources/DTDECLARE.LCOM") -;; Not when start in .30(LOAD "{DSK}~/lispcore/medley2.01/cmlarray-support.lcom") -;;(LOADFNS '\MAP-CODE-POINTERS "{dsk}~/lispcore/sources/ACODE.LCOM;1") -;;(LOADFNS 'VNTYPX "{dsk}~/lispcore/sources/RDSYS.LCOM") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}~/lispcore/SUNLOADUP/FASTINIT.DFASL") -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(CNDIR "{dsk}~/lispcore/4-BYTE-ATOMS/") -(PROGN -(DORENAME 'I) ;; At times, this is commented out if I-NEW needs hand tweeking... - (DLFIXINIT - (MAKEINIT '(35010 35010 25400Q) - NIL '{dsk}~/lispcore/INIT.SYSOUT - '("{dsk}~/lispcore/4-BYTE-ATOMS/" - "{dsk}~/lispcore/sources/" - "{dsk}~/lispcore/3-BYTE-ATOMS/" - "{DSK}~/lispcore/sunloadup/" )) - '{DSK}~/lispcore/INIT.DLINIT - '{dsk}~/lispcore/SUNLOADUP/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKEBIGFULLFROMLISP b/obsolete/sunloadup/INIT.MAKEBIGFULLFROMLISP deleted file mode 100644 index 5d36eae5..00000000 --- a/obsolete/sunloadup/INIT.MAKEBIGFULLFROMLISP +++ /dev/null @@ -1,13 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; -(CL:IN-PACKAGE "IL") -(SETQ DIRECTORIES '( - "{dsk}/users/sybalsky/4-BYTE-ATOMS/" - "{dsk}/king/export/lispcore/lafite/parc-94/" - "{DSK}/users/sybalsky/4-byte-lib/" - "{DSK}/users/sybalsky/4-byte-intlib/" - "{DSK}/users/sybalsky/sunloadup/" )) -) diff --git a/obsolete/sunloadup/INIT.MAKEBIGSGI b/obsolete/sunloadup/INIT.MAKEBIGSGI deleted file mode 100644 index 8e1ea878..00000000 --- a/obsolete/sunloadup/INIT.MAKEBIGSGI +++ /dev/null @@ -1,48 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; Same as INIT.MAKEINITFULL, but points to DSK for files, not Pele:. -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}/users/sybalsky/SUNLOADUP/LOADUP.LOG") -(SETQ CH.DEFAULT.DOMAIN "mv") -(SETQ CH.DEFAULT.ORGANIZATION "envos") -(CNDIR "{dsk}/king/export/lispcore/sources/") -(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0) -(SETQ CROSSCOMPILING T) - -(SETQ DIRECTORIES '( - "{dsk}/king/export/lispcore/sources/" "{dsk}/king/export/lispcore/library/" - "{DSK}/king/export/lispcore/internal/library/" - "{DSK}/users/sybalsky/sunloadup/" )) -(LOAD "{dsk}/users/sybalsky/SUNLOADUP/FILESETS") -(PUTPROP :D8 'CODEREADER (GETPROP :D7 'CODEREADER)) -(LOAD "{dsk}/king/export/lispcore/library/VMEM.LCOM") -(LOAD "{dsk}/king/export/lispcore/sources/MEM.LCOM") -(LOAD "{dsk}/king/export/lispcore/library/READSYS.LCOM") -(LOAD "{dsk}/king/export/lispcore/library/RDSYS.LCOM") -(LOAD "{DSK}/king/export/lispcore/sources/DTDECLARE.LCOM") -;;(LOAD "{DSK}/users/sybalsky/medley2.01/cmlarray-support.lcom") -(LOADFNS '\MAP-CODE-POINTERS "{dsk}/king/export/lispcore/sources/ACODE.LCOM;1") -(LOADFNS 'VNTYPX "{dsk}/king/export/lispcore/sources/RDSYS.LCOM") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}/users/sybalsky/SUNLOADUP/FASTINIT.DFASL") -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(CNDIR "{dsk}/users/sybalsky/4-BYTE-ATOMS/") -(PROGN -;; (DORENAME 'I) ;; At times, this is commented out if I-NEW needs hand tweeking... - (DLFIXINIT - (MAKEINIT '(21000 21000 25400Q) - NIL '{dsk}/users/sybalsky/INIT.SYSOUT - '("{dsk}/users/sybalsky/4-BYTE-ATOMS/" - "{DSK}/users/sybalsky/sunloadup/" )) - '{DSK}/users/sybalsky/INIT.DLINIT - '{dsk}/users/sybalsky/SUNLOADUP/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKECLTL2SGI b/obsolete/sunloadup/INIT.MAKECLTL2SGI deleted file mode 100644 index f023705b..00000000 --- a/obsolete/sunloadup/INIT.MAKECLTL2SGI +++ /dev/null @@ -1,51 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; Same as INIT.MAKEINITFULL, but points to DSK for files, not Pele:. -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}/users/sybalsky/SUNLOADUP/LOADUP.LOG") -(SETQ CH.DEFAULT.DOMAIN "mv") -(SETQ CH.DEFAULT.ORGANIZATION "envos") -(CNDIR "{dsk}~/4-byte-atoms/") -(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0) -(SETQ CROSSCOMPILING T) - -(SETQ DIRECTORIES '( - "{dsk}~/4-byte-lib/" "{dsk}~/4-byte-atoms/" "{dsk}/king/export/lispcore/sources/cltl2/" - "{dsk}/king/export/lispcore/sources/" "{dsk}/king/export/lispcore/library/" - "{DSK}/king/export/lispcore/internal/library/" - "{DSK}/users/sybalsky/sunloadup/" )) -(LOAD "{dsk}/users/sybalsky/SUNLOADUP/FILESETS") -(FILESLOAD VMEM MEM READSYS RDSYS) -; (LOAD "{dsk}/king/export/lispcore/library/VMEM.LCOM") -; (LOAD "{dsk}/king/export/lispcore/sources/MEM.LCOM") -; (LOAD "{dsk}/king/export/lispcore/library/READSYS.LCOM") -; (LOAD "{dsk}/king/export/lispcore/library/RDSYS.LCOM") -; (LOAD "{DSK}/king/export/lispcore/sources/DTDECLARE.LCOM") -; (LOAD "{DSK}/users/sybalsky/medley2.01/cmlarray-support.lcom") -; (LOADFNS '\MAP-CODE-POINTERS "{dsk}/king/export/lispcore/sources/ACODE.LCOM;1") -; (LOADFNS 'VNTYPX "{dsk}/king/export/lispcore/sources/RDSYS.LCOM") -(LOAD '{dsk}/king/export/lispcore/sources/cltl2/MACHINEINDEPENDENT.LCOM) -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}/users/sybalsky/SUNLOADUP/bigFASTINIT.DFASL") -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(CNDIR "{dsk}/king/export/lispcore/sources/cltl2/") -(PROGN - (DORENAME 'I) - (DLFIXINIT - (MAKEINIT '(11500Q 13062Q 25400Q) - NIL '{dsk}/users/sybalsky/INIT.SYSOUT - '("{dsk}/king/export/lispcore/sources/cltl2/" - "{dsk}/users/sybalsky/4-BYTE-ATOMS/" - "{DSK}/users/sybalsky/sunloadup/" )) - '{DSK}/users/sybalsky/INIT.DLINIT - '{dsk}/users/sybalsky/SUNLOADUP/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKEINIT b/obsolete/sunloadup/INIT.MAKEINIT deleted file mode 100644 index f86fd79b..00000000 --- a/obsolete/sunloadup/INIT.MAKEINIT +++ /dev/null @@ -1,48 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG") -(SETQ DIRECTORIES '( - "{dsk}/users/sybalsky/3-byte-atom-changes/" - "{pele:mv:envos}sources>" - "{DSK}/usr/local/lde/lispcore/library/" - "{DSK}/usr/local/lde/lispcore/internal/library/" - "{DSK}/users/sybalsky/sunloadup/" )) -(LOAD "{dsk}~/SUNLOADUP/FILESETS") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL") -(FOR FILE IN '(xclc-env-ctxt.lcom xclc-top-level.dfasl dtdeclare.lcom lldatatype.lcom bytecompiler.lcom dlap.lcom d-assem.lcom llarrayelt.lcom llcode.lcom set-target) - do (LOAD FILE)) -(SET-TARGET NIL) ;; should effectively replace these lines: -;(PUTPROP 'FLOAT 'DOPVAL '((1 DTEST 0 (ATOM . FLOATP)))) -;(SETQ COMPILER::*HOST-ARCHITECTURE* NIL) -;(SETQ COMPILER::*TARGET-ARCHITECTURE* NIL) -;(SETQ *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T)) -; -; Mark this as making a 3-byte INIT: -(SETQ COMPILER::*TARGET-ARCHITECTURE* '(:3-BYTE-INIT)) -(SETQ *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T)) -; -; -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(PROGN - (DORENAME 'I) - (SET-TARGET T) - - (DLFIXINIT - (MAKEINIT '(11500Q 13062Q 25400Q) - NIL NIL - '("{DSK}/users/sybalsky/3-BYTE-ATOMS/" - "{DSK}/users/sybalsky/sunloadup/" )) - '{DSK}~/INIT.DLINIT - '{dsk}/python1/fuji/sunloadup/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKEINIT-3BYTE b/obsolete/sunloadup/INIT.MAKEINIT-3BYTE deleted file mode 100644 index f86fd79b..00000000 --- a/obsolete/sunloadup/INIT.MAKEINIT-3BYTE +++ /dev/null @@ -1,48 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG") -(SETQ DIRECTORIES '( - "{dsk}/users/sybalsky/3-byte-atom-changes/" - "{pele:mv:envos}sources>" - "{DSK}/usr/local/lde/lispcore/library/" - "{DSK}/usr/local/lde/lispcore/internal/library/" - "{DSK}/users/sybalsky/sunloadup/" )) -(LOAD "{dsk}~/SUNLOADUP/FILESETS") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL") -(FOR FILE IN '(xclc-env-ctxt.lcom xclc-top-level.dfasl dtdeclare.lcom lldatatype.lcom bytecompiler.lcom dlap.lcom d-assem.lcom llarrayelt.lcom llcode.lcom set-target) - do (LOAD FILE)) -(SET-TARGET NIL) ;; should effectively replace these lines: -;(PUTPROP 'FLOAT 'DOPVAL '((1 DTEST 0 (ATOM . FLOATP)))) -;(SETQ COMPILER::*HOST-ARCHITECTURE* NIL) -;(SETQ COMPILER::*TARGET-ARCHITECTURE* NIL) -;(SETQ *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T)) -; -; Mark this as making a 3-byte INIT: -(SETQ COMPILER::*TARGET-ARCHITECTURE* '(:3-BYTE-INIT)) -(SETQ *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T)) -; -; -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(PROGN - (DORENAME 'I) - (SET-TARGET T) - - (DLFIXINIT - (MAKEINIT '(11500Q 13062Q 25400Q) - NIL NIL - '("{DSK}/users/sybalsky/3-BYTE-ATOMS/" - "{DSK}/users/sybalsky/sunloadup/" )) - '{DSK}~/INIT.DLINIT - '{dsk}/python1/fuji/sunloadup/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKEINIT-MAIN b/obsolete/sunloadup/INIT.MAKEINIT-MAIN deleted file mode 100644 index 0e597456..00000000 --- a/obsolete/sunloadup/INIT.MAKEINIT-MAIN +++ /dev/null @@ -1,34 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG") -(SETQ DIRECTORIES '( - "{DSK}/usr/local/lde/lispcore/sources/" - "{DSK}/usr/local/lde/lispcore/library/" - "{DSK}/usr/local/lde/lispcore/internal/library/" - "{DSK}/python1/fuji/sunloadup/" - "{dsk}/users/sybalsky/lispcore/sunloadup/" )) -(LOAD "{dsk}SUNLOADUP/FILESETS") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL") -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 45 min. -(PROGN - (DORENAME 'I) - (DLFIXINIT - (MAKEINIT '(11500Q 13062Q 25400Q) - NIL NIL - '({DSK}/usr/local/lde/lispcore/sources/ - {dsk}/users/osamu/sunloadup/ - {DSK}/python1/fuji/sunloadup/ )) - '{DSK}INIT.DLINIT - '{dsk}/python1/fuji/sunloadup/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKEINIT-NOETHER b/obsolete/sunloadup/INIT.MAKEINIT-NOETHER deleted file mode 100644 index 733f821c..00000000 --- a/obsolete/sunloadup/INIT.MAKEINIT-NOETHER +++ /dev/null @@ -1,34 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/15 Osamu -; Making LISP.SYSOUT that doesn't support XNS,PUP -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG") -(SETQ DIRECTORIES '( - "{DSK}/users/sybalsky/lispcore/Sources/" - "{DSK}/users/sybalsky/lispcore/library/" - "{DSK}/users/sybalsky/lispcore/internal/library/" - "{dsk}/users/sybalsky/lispcore/sunloadup/" )) -; -; remove LLETHER from 1LISPSET -(LOAD "{dsk}/users/osamu/SUNLOADUP/FILESETS") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}/users/sybalsky/FASTINIT.DFASL") -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(PROGN - (DORENAME 'I) - (DLFIXINIT - (MAKEINIT '(11500Q 13062Q 25400Q) - NIL NIL - '({DSK}/users/sybalsky/lispcore/Sources/ - {dsk}/users/sybalsky/lispcore/sunloadup/ )) - '{DSK}INIT.DLINIT - '{dsk}/users/sybalsky/lispcore/next/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKEINITDSK b/obsolete/sunloadup/INIT.MAKEINITDSK deleted file mode 100644 index b65e9a20..00000000 --- a/obsolete/sunloadup/INIT.MAKEINITDSK +++ /dev/null @@ -1,48 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; Same as INIT.MAKEINITFULL, but points to DSK for files, not Pele:. -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG") -(SETQ CH.DEFAULT.DOMAIN "mv") -(SETQ CH.DEFAULT.ORGANIZATION "envos") -(CNDIR "{dsk}/king/export/lispcore/sources/") -(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0) -(SETQ CROSSCOMPILING T) - -(SETQ DIRECTORIES '( - "{dsk}/king/export/lispcore/sources/" "{dsk}/king/export/lispcore/library/" - "{DSK}/king/export/lispcore/internal/library/" - "{DSK}/users/sybalsky/sunloadup/" )) -(LOAD "{dsk}~/SUNLOADUP/FILESETS") -(LOAD "{dsk}/king/export/lispcore/library-2.0/VMEM.LCOM") -(LOAD "{dsk}~/3-BYTE-ATOMS/MEM.LCOM") -(LOAD "{dsk}/king/export/lispcore/library-2.0/READSYS.LCOM") -(LOAD "{dsk}/king/export/lispcore/library-2.0/RDSYS.LCOM") -(LOAD "{DSK}~/3-BYTE-ATOMS/DTDECLARE.LCOM") -(LOAD "{DSK}/king/export/release/medley/2.0/library/cmlarray-support.lcom") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL") -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(CNDIR "{dsk}~/3-BYTE-ATOMS/") -(PROGN - ;;(DORENAME 'I) - (DLFIXINIT - (MAKEINIT '(20101 ;LISP VERSION - 20100 ; MIN MICROCODE VERSION FOR XEROX - 20100 ; MIN EMULATOR VERSION FOR UNIX/DOS, BCPL FOR XEROX - ) - NIL '{dsk}~/INIT.SYSOUT - '("{dsk}/users/sybalsky/3-BYTE-ATOMS/" - "{DSK}/users/sybalsky/sunloadup/" )) - '{DSK}~/INIT.DLINIT - '{dsk}~/SUNLOADUP/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKEINITFULL b/obsolete/sunloadup/INIT.MAKEINITFULL deleted file mode 100644 index 1c181619..00000000 --- a/obsolete/sunloadup/INIT.MAKEINITFULL +++ /dev/null @@ -1,41 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG") -(SETQ CH.DEFAULT.DOMAIN "mv") -(SETQ CH.DEFAULT.ORGANIZATION "envos") -(CNDIR "{pele:mv:envos}2.01>sources>") -(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0) - -(SETQ DIRECTORIES '( - "{pele:mv:envos}2.01>sources>" - "{pele:mv:envos}2.0>sources>" "{PELE:MV:ENVOS}2.0>LIBRARY>" - "{DSK}/users/sybalsky/sunloadup/" )) -(LOAD "{dsk}~/SUNLOADUP/FILESETS") -(LOAD "{pele:mv:envos}2.0>library>VMEM.LCOM") -(LOAD "{pele:mv:envos}2.0>library>READSYS.LCOM") -(LOAD "{pele:mv:envos}2.0>library>RDSYS.LCOM") -(LOAD "{pele:mv:envos}2.0>library>cmlarray-support.lcom") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT ) -(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL") -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(CNDIR "{dsk}~/3-BYTE-ATOMS/") -(PROGN - (DORENAME 'I) - (DLFIXINIT - (MAKEINIT '(11500Q 13062Q 25400Q) - NIL '{dsk}~/INIT.SYSOUT - '("{dsk}/users/sybalsky/3-BYTE-ATOMS/" - "{DSK}/users/sybalsky/sunloadup/" )) - '{DSK}~/INIT.DLINIT - '{dsk}~/SUNLOADUP/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/INIT.MAKEINITFULLFROMLISP b/obsolete/sunloadup/INIT.MAKEINITFULLFROMLISP deleted file mode 100644 index 5d36eae5..00000000 --- a/obsolete/sunloadup/INIT.MAKEINITFULLFROMLISP +++ /dev/null @@ -1,13 +0,0 @@ -; -; Run MAKEINIT on SUN -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; -(CL:IN-PACKAGE "IL") -(SETQ DIRECTORIES '( - "{dsk}/users/sybalsky/4-BYTE-ATOMS/" - "{dsk}/king/export/lispcore/lafite/parc-94/" - "{DSK}/users/sybalsky/4-byte-lib/" - "{DSK}/users/sybalsky/4-byte-intlib/" - "{DSK}/users/sybalsky/sunloadup/" )) -) diff --git a/obsolete/sunloadup/INIT.MAKEINITFULLSGI b/obsolete/sunloadup/INIT.MAKEINITFULLSGI deleted file mode 100644 index 4bf11849..00000000 --- a/obsolete/sunloadup/INIT.MAKEINITFULLSGI +++ /dev/null @@ -1,40 +0,0 @@ -; -; Run MAKEINIT on INDIGO, no NS access -; '90/02/09 Osamu -; '90.05/23 change DIRECTORIES -; -(CL:IN-PACKAGE "IL") -(DRIBBLE "{DSK}SUNLOADUP/LOADUP.LOG") -(SETQ CH.DEFAULT.DOMAIN "mv") -(SETQ CH.DEFAULT.ORGANIZATION "envos") -(CNDIR "{dsk}/users/sybalsky/medley2.01>") -(SETQ HELPFLAG 'BREAK!)(SETQ HELPDEPTH 0) - -(SETQ DIRECTORIES '( - "{dsk}sybalsky>medley2.01>" - "{DSK}/users/sybalsky/sunloadup/" )) -(LOAD "{dsk}~/SUNLOADUP/FILESETS") -(LOAD "VMEM.LCOM") -(LOAD "READSYS.LCOM") -(LOAD "RDSYS.LCOM") -(LOAD "cmlarray-support.lcom") -(FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) -(LOAD "{DSK}SUNLOADUP/FASTINIT.DFASL") -;; turn off idle or you get stuck. -(IDLE.SET.OPTION 'TIMEOUT T) -;;and start making the init. This takes about 2.5 hrs. -(CNDIR "{dsk}~/3-BYTE-ATOMS/") -(PROGN - (DORENAME 'I) - (DLFIXINIT - (MAKEINIT '(11500Q 13062Q 25400Q) - NIL '{dsk}~/INIT.SYSOUT - '("{dsk}/users/sybalsky/3-BYTE-ATOMS/" - "{DSK}/users/sybalsky/sunloadup/" )) - '{DSK}~/INIT.DLINIT - '{dsk}~/SUNLOADUP/LISPDLION.DB - 300) - (DATE) - (DRIBBLE) - (LOGOUT T) -) diff --git a/obsolete/sunloadup/LOADBIGFULLFROMLISP-REM.CM b/obsolete/sunloadup/LOADBIGFULLFROMLISP-REM.CM deleted file mode 100644 index 6955cd0f..00000000 --- a/obsolete/sunloadup/LOADBIGFULLFROMLISP-REM.CM +++ /dev/null @@ -1,5 +0,0 @@ -" -SHH(PROGN (IL:LOAD '\"{dsk}SUNLOADUP/LOADFULL-BIG.LISP\") (IL:MAKESYS '\"{dsk}FULL.SYSOUT\") (IL:LOGOUT T)) - -" - diff --git a/obsolete/sunloadup/LOADFULL-BIG.LISP b/obsolete/sunloadup/LOADFULL-BIG.LISP deleted file mode 100644 index dc7d5412..00000000 --- a/obsolete/sunloadup/LOADFULL-BIG.LISP +++ /dev/null @@ -1,28 +0,0 @@ -(RESETVARS - ((IDLE.PROFILE (QUOTE (TIMEOUT NIL)))) - (DEL.PROCESS (QUOTE IDLE)) - (SETQQ DISPLAYFONTDIRECTORIES - ("{DSK}/mo/release/fonts/display/presentation/" -"{DSK}/mo/release/fonts/display/publishing/" -"{DSK}/mo/release/fonts/display/miscellaneous/" )) - (SETQQ INTERPRESSFONTDIRECTORIES - ("{DSK}/mo/release/fonts/interpress/presentation/" -"{DSK}/mo/release/fonts/interpress/publishing/" -"{DSK}/mo/release/fonts/interpress/miscellaneous/" )) - (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) - (SETQQ LOADUPDIRECTORIES - ({dsk}~/4-byte-lib/ {dsk}~/4-byte-intlib/ - {dsk}/king/export/lispcore/lafite/parc-94/ - {dsk}/king/export/lispcore/library/ - {dsk}/king/export/lispcore/internal/library/ -)) - (* used to include after EDITBITMAL: MAILCLIENT NSMAIL LAFITE NEWNSMAIL) - (* used to include MAILCLIENT before NSMAIL ) - (LOADUP (QUOTE (MSANALYZE MSPARSE MASTERSCOPE GIVE-AND-TAKE CHANGECONTROL CHAT PUPCHAT NSCHAT TEDIT HRULE - TEDITCHAT READNUMBER EDITBITMAP NSMAIL LAFITE - NEWNSMAIL FILEBROWSER GRAPHER SPY AREDIT WHERE-IS COPYFILES - UNIXCOMM UNIXCHAT - POSTSCRIPTSTREAM UNIXPRINT))) - (\DAYTIME0 \LASTUSERACTION) - (ENDLOADUP)) -STOP diff --git a/obsolete/sunloadup/LOADFULL-REM.CM b/obsolete/sunloadup/LOADFULL-REM.CM deleted file mode 100644 index 4516887c..00000000 --- a/obsolete/sunloadup/LOADFULL-REM.CM +++ /dev/null @@ -1,7 +0,0 @@ -" -(PROGN (LOAD (QUOTE {dsk}~/lispcore/SUNLOADUP/LOADUP.LISP))(SETQ IL:MAKESYSNAME :MEDLEY)(HARDRESET)) -SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'LISP.SYSOUT)) -SHH(PROGN (IL:LOAD '{dsk}~/lispcore/SUNLOADUP/LOADFULL.LISP) (IL:MAKESYS 'FULL.SYSOUT) (IL:LOGOUT T)) - -" - diff --git a/obsolete/sunloadup/LOADFULL.LISP b/obsolete/sunloadup/LOADFULL.LISP deleted file mode 100644 index d7290d01..00000000 --- a/obsolete/sunloadup/LOADFULL.LISP +++ /dev/null @@ -1,29 +0,0 @@ -(RESETVARS - ((IDLE.PROFILE (QUOTE (TIMEOUT NIL)))) - (DEL.PROCESS (QUOTE IDLE)) - (SETQQ DISPLAYFONTDIRECTORIES - ("{DSK}~/lispcore/fonts/display/presentation/" -"{DSK}~/lispcore/fonts/display/publishing/" -"{DSK}~/lispcore/fonts/display/miscellaneous/" )) - (SETQQ INTERPRESSFONTDIRECTORIES - ("{DSK}~/lispcore/fonts/interpress/presentation/" -"{DSK}~/lispcore/fonts/interpress/publishing/" -"{DSK}~/lispcore/fonts/interpress/miscellaneous/" )) - (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) - (SETQQ LOADUPDIRECTORIES - ({dsk}~/lispcore/lafite/medley-2.01/ - {dsk}~/lispcore/library/ - {dsk}~/lispcore/internal/library/ - -)) - (SETQ CH.DEFAULT.DOMAIN "MV") (SETQ CH.DEFAULT.ORGANIZATION "Envos") - (* used to include after EDITBITMAL: MAILCLIENT NSMAIL LAFITE NEWNSMAIL) - (LOADUP (QUOTE (MSPARSE MSANALYZE MASTERSCOPE - GIVE-AND-TAKE CHANGECONTROL CHAT PUPCHAT NSCHAT TEDIT HRULE - TEDITCHAT READNUMBER EDITBITMAP MAILCLIENT NSMAIL LAFITE - NEWNSMAIL FILEBROWSER GRAPHER SPY AREDIT WHERE-IS COPYFILES - UNIXCOMM UNIXCHAT - POSTSCRIPTSTREAM UNIXPRINT MULTI-COMPILE))) - (\DAYTIME0 \LASTUSERACTION) - (ENDLOADUP)) -STOP diff --git a/obsolete/sunloadup/LOADFULLFROMLISP-REM.CM b/obsolete/sunloadup/LOADFULLFROMLISP-REM.CM deleted file mode 100644 index 57b12cf8..00000000 --- a/obsolete/sunloadup/LOADFULLFROMLISP-REM.CM +++ /dev/null @@ -1,5 +0,0 @@ -" -SHH(PROGN (IL:LOAD '\"{dsk}/disk/disk2/jdstools/lc3/lispcore3.0/SUNLOADUP/LOADFULL.LISP\") (IL:MAKESYS '\"{dsk}FULL.SYSOUT\") (IL:LOGOUT T)) - -" - diff --git a/obsolete/sunloadup/LOADUP-BIG.LISP b/obsolete/sunloadup/LOADUP-BIG.LISP deleted file mode 100644 index 602c01df..00000000 Binary files a/obsolete/sunloadup/LOADUP-BIG.LISP and /dev/null differ diff --git a/obsolete/sunloadup/LOADUP-NOCOMPILER-REM.CM b/obsolete/sunloadup/LOADUP-NOCOMPILER-REM.CM deleted file mode 100644 index 7aa27269..00000000 --- a/obsolete/sunloadup/LOADUP-NOCOMPILER-REM.CM +++ /dev/null @@ -1,6 +0,0 @@ -" -(SETQQ MAKESYSNAME NOCOMPILER) -(PROGN (LOAD (QUOTE {dsk}/users/osamu/SUNLOADUP/LOADUP-NOCOMPILER.LISP))(HARDRESET)) -SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'NOCOMPILER.SYSOUT)) -" - diff --git a/obsolete/sunloadup/LOADUP-NOCOMPILER.LISP b/obsolete/sunloadup/LOADUP-NOCOMPILER.LISP deleted file mode 100644 index 1504bac7..00000000 --- a/obsolete/sunloadup/LOADUP-NOCOMPILER.LISP +++ /dev/null @@ -1,83 +0,0 @@ -(* " '90/02/15 Osamu: Remove D-Machine specific file") -(* " Remove DPUPFT DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY") -(SETQQ COMPILE.EXT LCOM) - -(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES)) - -(SETQ BOOTLOADEDFILES) - -(* "following files are really loaded earlier, this call to LOADUP just cleans up") -(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP))) - -(* "establish all package exports early") -(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE))) - -(* "turn on FTP so that loadup will be faster") -(* "Osamu '90/02/15 remove DPUPFTP") -(LOADUP (QUOTE (BSP))) - -(* "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))) - -(* "remove FASDUMP XCL-COMPILER '90/02/16 Osamu") -(LOADUP (QUOTE (ADVISE))) - -(* "the bytecompiler and Interlisp compiler interface functions") -(* "remove DLAP BYTECOMPILER COMPILE '90/02/16 Osamu") -(* "(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE)))") - -(* "remove DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY TRSERVER '90/02/15 Osamu") -(LOADUP (QUOTE (LOCALFILE 10MBDRIVER MAIKOETHER LLNS 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) - -STOP diff --git a/obsolete/sunloadup/LOADUP-NODMACHINE-REM.CM b/obsolete/sunloadup/LOADUP-NODMACHINE-REM.CM deleted file mode 100644 index d4e2e033..00000000 --- a/obsolete/sunloadup/LOADUP-NODMACHINE-REM.CM +++ /dev/null @@ -1,6 +0,0 @@ -" -(SETQQ MAKESYSNAME NODMACHINE) -(PROGN (LOAD (QUOTE {dsk}/users/osamu/SUNLOADUP/LOADUP-NODMACHINE.LISP))(HARDRESET)) -SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'NODMACHINE.SYSOUT)) -" - diff --git a/obsolete/sunloadup/LOADUP-NODMACHINE.LISP b/obsolete/sunloadup/LOADUP-NODMACHINE.LISP deleted file mode 100644 index 28949ec3..00000000 --- a/obsolete/sunloadup/LOADUP-NODMACHINE.LISP +++ /dev/null @@ -1,81 +0,0 @@ -(* " '90/02/15 Osamu: Remove D-Machine specific file") -(* " Remove DPUPFT DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY") -(SETQQ COMPILE.EXT LCOM) - -(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES)) - -(SETQ BOOTLOADEDFILES) - -(* "following files are really loaded earlier, this call to LOADUP just cleans up") -(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP))) - -(* "establish all package exports early") -(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE))) - -(* "turn on FTP so that loadup will be faster") -(* "Osamu '90/02/15 remove DPUPFTP") -(LOADUP (QUOTE (BSP))) - -(* "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))) - -(* "remove DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY TRSERVER '90/02/15 Osamu") -(LOADUP (QUOTE (LOCALFILE 10MBDRIVER MAIKOETHER LLNS 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) - -STOP diff --git a/obsolete/sunloadup/LOADUP-NOETHER-REM.CM b/obsolete/sunloadup/LOADUP-NOETHER-REM.CM deleted file mode 100644 index cc898fd5..00000000 --- a/obsolete/sunloadup/LOADUP-NOETHER-REM.CM +++ /dev/null @@ -1,6 +0,0 @@ -" -(SETQQ MAKESYSNAME NOETHER) -(PROGN (LOAD (QUOTE {dsk}/users/osamu/SUNLOADUP/LOADUP-NOETHER.LISP))(HARDRESET)) -SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'NOETHER.SYSOUT)) -" - diff --git a/obsolete/sunloadup/LOADUP-NOETHER.LISP b/obsolete/sunloadup/LOADUP-NOETHER.LISP deleted file mode 100644 index 058c42fc..00000000 --- a/obsolete/sunloadup/LOADUP-NOETHER.LISP +++ /dev/null @@ -1,82 +0,0 @@ -(* "Makeing LISP.SYSOUT that doesn't support XNS and PUP. '90/02/15 Osamu") - -(SETQQ COMPILE.EXT LCOM) - -(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES)) - -(SETQ BOOTLOADEDFILES) - -(* "following files are really loaded earlier, this call to LOADUP just cleans up") -(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP))) - -(* "establish all package exports early") -(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE))) - -(* "turn on FTP so that loadup will be faster") -(* "'90/02/15 Osamu: Remove DPUPFTP") -(LOADUP (QUOTE (BSP))) - -(* "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))) - -(* "'90/02/15 Osamu: Remove LLNS TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS") - -(LOADUP (QUOTE (DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER MAIKOETHER HARDCOPY FLOPPY IDLER ICONW FREEMENU SEDIT))) - -(LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT))) - -(LOADUP (QUOTE (TIME))) - -(LOADUP (QUOTE (XCL-EXTRAS))) - -(* "CMLPACKAGE pushes onto INSPECTMACROS") -(LOADUP (QUOTE (CMLPACKAGE))) - -(* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs") -(LOADUP (QUOTE (CMLSMARTARGS))) - -(LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE))) - -(* "Already enabled, but this time fixes tables that weren't defined in the init") -(PACKAGE-ENABLE) - -STOP diff --git a/obsolete/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM b/obsolete/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM deleted file mode 100644 index e774ccda..00000000 --- a/obsolete/sunloadup/LOADUP-NOXCLCOMPILER-REM.CM +++ /dev/null @@ -1,6 +0,0 @@ -" -(SETQQ MAKESYSNAME NOXCLCOMPILER) -(PROGN (LOAD (QUOTE {dsk}/users/osamu/SUNLOADUP/LOADUP-NOXCLCOMPILER.LISP))(HARDRESET)) -SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'NOXCLCOMPILER.SYSOUT)) -" - diff --git a/obsolete/sunloadup/LOADUP-NOXCLCOMPILER.LISP b/obsolete/sunloadup/LOADUP-NOXCLCOMPILER.LISP deleted file mode 100644 index 537ddd31..00000000 --- a/obsolete/sunloadup/LOADUP-NOXCLCOMPILER.LISP +++ /dev/null @@ -1,84 +0,0 @@ -(* " '90/02/15 Osamu: Remove D-Machine specific file") -(* " Remove DPUPFT DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY") -(* " '90/02/19 Osamu: Remove XCL Compiler.") -(* " Remove FASDUMP XCL-COMPILER. '90/02/19 Osamu") -(SETQQ COMPILE.EXT LCOM) - -(SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES)) - -(SETQ BOOTLOADEDFILES) - -(* "following files are really loaded earlier, this call to LOADUP just cleans up") -(LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP))) - -(* "establish all package exports early") -(LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE))) - -(* "turn on FTP so that loadup will be faster") -(* "Osamu '90/02/15 remove DPUPFTP") -(LOADUP (QUOTE (BSP))) - -(* "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))) - -(* "Remove FASDUMP XCL-COMPILER. '90/02/19 Osamu") -(LOADUP (QUOTE (ADVISE))) - -(* "the bytecompiler and Interlisp compiler interface functions") -(LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE))) - -(* "remove DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY DSKDISPLAY FLOPPY TRSERVER '90/02/15 Osamu") -(LOADUP (QUOTE (LOCALFILE 10MBDRIVER MAIKOETHER LLNS 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) - -STOP diff --git a/obsolete/sunloadup/LOADUP-REM.CM b/obsolete/sunloadup/LOADUP-REM.CM deleted file mode 100644 index 5da6248a..00000000 --- a/obsolete/sunloadup/LOADUP-REM.CM +++ /dev/null @@ -1,5 +0,0 @@ -" -(PROGN (LOAD (QUOTE {dsk}SUNLOADUP/LOADUP.LISP))(SETQ IL:MAKESYSNAME :MEDLEY)(HARDRESET)) -SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'LISP.SYSOUT)) -" - diff --git a/obsolete/sunloadup/LOADUP.LISP b/obsolete/sunloadup/LOADUP.LISP deleted file mode 100644 index 086575b2..00000000 --- a/obsolete/sunloadup/LOADUP.LISP +++ /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 b/obsolete/sunloadup/LOADUP.LOG deleted file mode 100644 index b6a48079..00000000 --- a/obsolete/sunloadup/LOADUP.LOG +++ /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/LispDlion.db b/obsolete/sunloadup/LispDlion.db deleted file mode 100644 index caf1b2fc..00000000 Binary files a/obsolete/sunloadup/LispDlion.db and /dev/null differ diff --git a/obsolete/sunloadup/LispDove.db b/obsolete/sunloadup/LispDove.db deleted file mode 100644 index a2ca1ebd..00000000 Binary files a/obsolete/sunloadup/LispDove.db and /dev/null differ diff --git a/obsolete/sunloadup/MAIKOINIT b/obsolete/sunloadup/MAIKOINIT deleted file mode 100644 index a57ccc94..00000000 --- a/obsolete/sunloadup/MAIKOINIT +++ /dev/null @@ -1,7 +0,0 @@ - -(RPAQQ SI::*CLOSURE-CACHE-ENABLED* NIL) - -(QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT* )) - -(PUTPROPS MAIKOINIT COPYRIGHT ("Venue" 1990)) -STOP diff --git a/obsolete/sunloadup/MAIKOLOADUPFNS b/obsolete/sunloadup/MAIKOLOADUPFNS deleted file mode 100644 index 3a3e4a35..00000000 --- a/obsolete/sunloadup/MAIKOLOADUPFNS +++ /dev/null @@ -1,589 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 5-Apr-89 16:23:30" {ERIS}SUNLOADUP>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/obsolete/sunloadup/MAIKOLOADUPFNS.LCOM b/obsolete/sunloadup/MAIKOLOADUPFNS.LCOM deleted file mode 100644 index d1276f25..00000000 Binary files a/obsolete/sunloadup/MAIKOLOADUPFNS.LCOM and /dev/null differ diff --git a/obsolete/sunloadup/MAKE-UTILS b/obsolete/sunloadup/MAKE-UTILS deleted file mode 100644 index de61be92..00000000 --- a/obsolete/sunloadup/MAKE-UTILS +++ /dev/null @@ -1,24 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "12-Mar-92 15:41:46" |{DSK}sybalsky>SUNLOADUP>MAKE-UTILS.;1| 906 - - |changes| |to:| (FNS DO-MAKE-COPIES)) - - -; Copyright (c) 1992 by Venue. All rights reserved. - -(PRETTYCOMPRINT MAKE-UTILSCOMS) - -(RPAQQ MAKE-UTILSCOMS ((FNS DO-MAKE-COPIES))) -(DEFINEQ - -(DO-MAKE-COPIES - (LAMBDA NIL (* \; "Edited 12-Mar-92 15:40 by jds") - (COPYFILES "{PELE:MV:ENVOS}SOURCES>*.LCOM" "{DSK}~/3-BYTE-ATOMS/*.LCOM" '>A) - (COPYFILES "{PELE:MV:ENVOS}SOURCES>*.DFASL" "{DSK}~/3-BYTE-ATOMS/*.LCOM" '>A) - (COPYFILES "{PELE:MV:ENVOS}LIBRARY>*.LCOM" "{DSK}~/3-BYTE-LIB/*.LCOM" '>A) - (COPYFILES "{PELE:MV:ENVOS}LIBRARY>*.DFASL" "{DSK}~/3-BYTE-LIB/*.LCOM" '>A))) -) -(PUTPROPS MAKE-UTILS COPYRIGHT ("Venue" 1992)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (337 836 (DO-MAKE-COPIES 347 . 834))))) -STOP diff --git a/obsolete/sunloadup/NLOCALFILE b/obsolete/sunloadup/NLOCALFILE deleted file mode 100644 index 078bcd41..00000000 --- a/obsolete/sunloadup/NLOCALFILE +++ /dev/null @@ -1,47 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(filecreated "14-Aug-88 19:30:10" |{DSK}/usr/local/medley/sources/NLOCALFILE.;2| 2162 - - |previous| |date:| "14-Aug-88 19:28:24" |{DSK}/usr/local/medley/sources/NLOCALFILE.;1|) - - -(prettycomprint nlocalfilecoms) - -(rpaqq nlocalfilecoms ((records |GenerateFileState|) - (fns |\\LFReturnNextFile| |\\LFReturnInfo|))) -(declare\: eval@compile - -(typerecord |GenerateFileState| (currentfile restoffiles attributes)) -) -(defineq - -(|\\LFReturnNextFile| - (lambda (generated) (* |amd| "10-Feb-86 16:04") - - (* * |comment|) - - (|if| (null (|fetch| (|GenerateFileState| restoffiles) |of| generated)) - |then| nil - |else| (|replace| (|GenerateFileState| currentfile) |of| generated - |with| (|pop| (|fetch| (|GenerateFileState| restoffiles) |of| - generated))) - (|fetch| (|GeneratedFile| fullname) |of| (|fetch| (|GenerateFileState| - currentfile) - |of| generated))))) - -(|\\LFReturnInfo| - (lambda (generated prop) (* |amd| "10-Feb-86 16:04") - - (* * |comment|) - - (|for| attrib |in| (|fetch| (|GenerateFileState| attributes) |of| generated) - |as| infoval |in| (|fetch| (|GeneratedFile| info) |of| (|fetch| - (|GenerateFileState| - currentfile) - |of| generated)) - |do| (|if| (eq (mkatom (u-case attrib)) - (mkatom (u-case prop))) - |then| (return infoval))))) -) -(declare\: dontcopy - (filemap (nil (513 2139 (|\\LFReturnNextFile| 523 . 1346) (|\\LFReturnInfo| 1348 . 2137))))) -stop diff --git a/obsolete/sunloadup/NLOCALFILE.LCOM b/obsolete/sunloadup/NLOCALFILE.LCOM deleted file mode 100644 index 3ec1457d..00000000 Binary files a/obsolete/sunloadup/NLOCALFILE.LCOM and /dev/null differ diff --git a/obsolete/sunloadup/POSTLOADUP b/obsolete/sunloadup/POSTLOADUP deleted file mode 100644 index 20beb166..00000000 --- a/obsolete/sunloadup/POSTLOADUP +++ /dev/null @@ -1,41 +0,0 @@ -(FILECREATED " 8-DEC-81 15:27:54" POSTLOADUP.;2 982 - - changes to: POSTLOADUPCOMS - - previous date: " 7-DEC-81 19:39:43" POSTLOADUP.;1) - - -(* Copyright (c) 1981 - by - Xerox Corporation *) - -(PRETTYCOMPRINT POSTLOADUPCOMS) - -(RPAQQ POSTLOADUPCOMS [(* set up so that files can be loaded directly from phylum) - (* turn off checking for dates of source) - (P (MOVD (QUOTE NILL) - (QUOTE LOADUP2A)) - (CHANGENAME (QUOTE LOADUP2) - (QUOTE ASSOC) - (QUOTE TRUE]) - - - -(* set up so that files can be loaded directly from phylum) - - - - -(* turn off checking for dates of source) - -(MOVD (QUOTE NILL) - (QUOTE LOADUP2A)) -(CHANGENAME (QUOTE LOADUP2) - (QUOTE ASSOC) - (QUOTE TRUE)) -(DECLARE: DONTCOPY - (FILEMAP (NIL))) -(PUTPROPS POSTLOADUP COPYRIGHTOWNER "Xerox Corporation") -(PUTPROPS POSTLOADUP COPYRIGHTYEARS 1981) -(PRINT (QUOTE (HI THERE)) T) -STOP diff --git a/obsolete/sunloadup/POSTLOADUP.LCOM b/obsolete/sunloadup/POSTLOADUP.LCOM deleted file mode 100644 index 0eb848c6..00000000 --- a/obsolete/sunloadup/POSTLOADUP.LCOM +++ /dev/null @@ -1 +0,0 @@ -(FILECREATED "18-Jul-90 18:44:25" ("compiled on " {DSK}sybalsky>SUNLOADUP>POSTLOADUP.;1) "18-Jul-90 17:36:59" bcompl'd in "Lispcore 3-Jul-90 ..." dated " 3-Jul-90 15:55:29") (FILECREATED " 8-DEC-81 15:27:54" POSTLOADUP.;2 982 changes to: POSTLOADUPCOMS previous date: " 7-DEC-81 19:39:43" POSTLOADUP.;1) (PRETTYCOMPRINT POSTLOADUPCOMS) (RPAQQ POSTLOADUPCOMS ((* set up so that files can be loaded directly from phylum) (* turn off checking for dates of source) (P (MOVD (QUOTE NILL) (QUOTE LOADUP2A)) (CHANGENAME (QUOTE LOADUP2) ( QUOTE ASSOC) (QUOTE TRUE))))) (MOVD (QUOTE NILL) (QUOTE LOADUP2A)) (CHANGENAME (QUOTE LOADUP2) (QUOTE ASSOC) (QUOTE TRUE)) (PUTPROPS POSTLOADUP COPYRIGHTOWNER "Xerox Corporation") (PUTPROPS POSTLOADUP COPYRIGHTYEARS 1981) (PRINT (QUOTE (HI THERE)) T) NIL \ No newline at end of file diff --git a/obsolete/sunloadup/REM.CM b/obsolete/sunloadup/REM.CM deleted file mode 100644 index 0121925e..00000000 --- a/obsolete/sunloadup/REM.CM +++ /dev/null @@ -1,7 +0,0 @@ -" -(PROGN (LOAD (QUOTE {dsk}SUNLOADUP/LOADUP.LISP))(SETQ IL:MAKESYSNAME :MEDLEY)(HARDRESET)) -SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS 'LISP.SYSOUT)) -SHH(PROGN (IL:LOAD '{dsk}SUNLOADUP/LOADFULL.LISP) (IL:MAKESYS 'FULL.SYSOUT) (IL:LOGOUT T)) - -" - diff --git a/obsolete/sunloadup/SUNFONT b/obsolete/sunloadup/SUNFONT deleted file mode 100644 index c449f5e4..00000000 --- a/obsolete/sunloadup/SUNFONT +++ /dev/null @@ -1,32 +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}~/lispcore/fonts/display/presentation/" - - "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" - - "{DSK}~/lispcore/fonts/display/publishing/" - - "{DSK}~/lispcore/fonts/display/miscellaneous/" - )) -(PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL))) -STOP - - - - diff --git a/obsolete/sunloadup/SUNFONT.LCOM b/obsolete/sunloadup/SUNFONT.LCOM deleted file mode 100644 index 60d6b9ef..00000000 --- a/obsolete/sunloadup/SUNFONT.LCOM +++ /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}~/lispcore/fonts/display/presentation/" "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" "{DSK}~/lispcore/fonts/display/publishing/" "{DSK}~/lispcore/fonts/display/miscellaneous/")) (PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998)) NIL \ No newline at end of file diff --git a/obsolete/sunloadup/XREM-NOETHER.CM b/obsolete/sunloadup/XREM-NOETHER.CM deleted file mode 100644 index 19245020..00000000 --- a/obsolete/sunloadup/XREM-NOETHER.CM +++ /dev/null @@ -1,8 +0,0 @@ -" -(SETQ SI::*CLOSURE-CACHE-ENABLED* NIL) -(QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT* )) -(MOVD? (QUOTE NILL) (QUOTE PROMPTPRINT)) -(MOVD? (QUOTE NILL) (QUOTE CURSORP)) -(MOVD? (QUOTE NILL) (QUOTE CHANGEBACKGROUNDBORDER)) -(LOGOUT) -" diff --git a/obsolete/sunloadup/bigFASTINIT.DFASL b/obsolete/sunloadup/bigFASTINIT.DFASL deleted file mode 100644 index 58354fec..00000000 Binary files a/obsolete/sunloadup/bigFASTINIT.DFASL and /dev/null differ diff --git a/obsolete/sunloadup/runloadbig b/obsolete/sunloadup/runloadbig deleted file mode 100644 index 4a4ef4d5..00000000 --- a/obsolete/sunloadup/runloadbig +++ /dev/null @@ -1,113 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure thru to FULL.SYSOUT -# -# Bootstrapping from 32-MB sysout version to 64- or -# larger sysouts. -# -###################################################################### -# -# -# Things to watch for: -# -# * LOADUP.LISP sets XCLC::*HOST-ARCHITECTURE*, which must match -# what we want it to be in the new sysout. -# -# * RDSYS needs to get re-built whenevver LLPARAMS is changed, -# so the addresses of things like MDS Type Table track. -# -# * SUNFONT contains directory names for font directories, -# and may need to be updated if you move this directory. -# -# * I had to define a function BIG-VMEM-CODE ( ( a b ) a), -# in order to compile LLKEY when making a fix... -# -# * PARC's version of FONT has *USEOLDDIRECTORIES* = NIL, -# which works WRONG with our font-directory layout. -# -######################################################################### -# -# VARIABLES IN THIS FILE AND WHAT THEY MEAN... -# -# LDE The lde to be run in first phase. -# MAIKO Directory the lde is in. -# INITLDE path to ldeinit for step 2 -# -####################################################################### - -#set LDE = $HOME/maiko/sunos4.sparc/lde -set MAIKO = ~/maiko-9912/sunos5.sparc -set LOADDIR = ~/lispcore -set LDE = $MAIKO/ldex-3.5 -set LDE2 = $MAIKO/ldex-3.51 -set LDEPATH = $MAIKO -set INITLDE = $MAIKO/ldeinit -#set INITLDEPATH = $HOME/maiko/init.sgi -set INITLDEPATH = ~/maiko-9912/init.sparc -#set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -#set FULL_SYSOUT = $HOME/FULL.SYSOUT # FULL.SYSOUT -set FULL_SYSOUT = /project/medley3.5/basics/full.sysout -set FIRST_REM_CM = $LOADDIR/sunloadup/XREM.CM -set SECOND_REM_CM = $LOADDIR/sunloadup/LOADFULL-REM.CM -#set SECOND_REM_CM = $HOME/sunloadup/LOADBIGFULLFROMLISP-REM.CM -# - -######################################################### -# # -# S T E P 1 # -# # -# Using an existing sysout and emulator, # -# create the new INIT.SYSOUT and INIT.DLINIT. # -# # -# (INIT.DLINIT has the dlion microcode spliced in.) # -# # -######################################################### - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT ~/lispcore/sunloadup/INIT.MAKEBIG -rm ~/REM.CM -$LDE $FULL_SYSOUT - - - -######################################################### -# # -# S T E P 2 # -# # -# Using the ldeinit emulator (which has special sup- # -# port for an incomplete lisp world) boot INIT.DLINIT # -# and LOGOUT. This runs the MAKEINIT.EXPRESSIONS for # -# a bunch of files, which set up much of the # -# infrastructure. # -# # -######################################################### - -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM - -# save your lisp.virtualmem - -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE $LOADDIR/INIT.DLINIT -INIT - - -######################################################### -# # -# S T E P 3 # -# # -# Start the emulator for the new version, and fire # -# up the lisp.virtualmem from step 2. Load in the # -# rest of the system, and do a MAKESYS to create the # -# LISP.SYSOUT. # -# # -######################################################### - -set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc) -set path=( $LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc ) -cp $SECOND_REM_CM ~/REM.CM -$LDE2 ~/lisp.virtualmem - diff --git a/obsolete/sunloadup/runloadbig-sgi b/obsolete/sunloadup/runloadbig-sgi deleted file mode 100644 index 1bbdc02d..00000000 --- a/obsolete/sunloadup/runloadbig-sgi +++ /dev/null @@ -1,43 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure thru to FULL.SYSOUT -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -set LDE = $HOME/maiko/irix.sgi/ldex-small -set LDE2 = $HOME/maiko/irix.sgi/ldex-bigvm -set LDEPATH = $HOME/maiko/irix.sgi -set INITLDE = $HOME/maiko/irix.sgi/ldeinit -set INITLDEPATH = $HOME/maiko/init.sgi -#set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -#set FULL_SYSOUT = $HOME/FULL.SYSOUT # FULL.SYSOUT -set FULL_SYSOUT = $HOME/smallFULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADFULL-REM.CM -#set SECOND_REM_CM = $HOME/SUNLOADUP/LOADBIGFULLFROMLISP-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -#set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -#setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEBIGSGI -#rm ~/REM.CM -#$LDE $FULL_SYSOUT - - -# Boot INIT.DLINIT and LOGOUT. -#set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -#unsetenv LDEDESTSYSOUT -#cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -#if( -e ~/lisp.virtualmem ) then - #mv ~/lisp.virtualmem ~/lisp.virtualmem.save -#endif -#$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc) -set path=( $LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc ) -cp $SECOND_REM_CM ~/REM.CM -$LDE2 ~/lisp.virtualmem -#$LDE2 ~/bigLISP.SYSOUT - diff --git a/obsolete/sunloadup/runloadcltl2-sgi b/obsolete/sunloadup/runloadcltl2-sgi deleted file mode 100644 index 710d51a4..00000000 --- a/obsolete/sunloadup/runloadcltl2-sgi +++ /dev/null @@ -1,42 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure thru to FULL.SYSOUT -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -set LDE = $HOME/maiko/irix.sgi/lde -set LDE2 = $HOME/maiko/irix.sgi/lde -set LDEPATH = $HOME/maiko/irix.sgi -set INITLDE = $HOME/maiko/irix.sgi/ldeinit -set INITLDEPATH = $HOME/maiko/init.sgi -#set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -set FULL_SYSOUT = $HOME/bigLISP.SYSOUT -#set FULL_SYSOUT = $HOME/bigLISP.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADFULL-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKECLTL2SGI -rm ~/REM.CM -$LDE $FULL_SYSOUT - - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -#set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc) -set path=( $LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc ) -cp $SECOND_REM_CM ~/REM.CM -$LDE2 ~/lisp.virtualmem - - diff --git a/obsolete/sunloadup/runloadfull b/obsolete/sunloadup/runloadfull deleted file mode 100644 index 16081558..00000000 --- a/obsolete/sunloadup/runloadfull +++ /dev/null @@ -1,44 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure thru to FULL.SYSOUT -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -#set LDE = $HOME/maiko/sunos4.sparc/ldeether -set LDE = $HOME/ldeether -set LDE2 = $HOME/ldeether -#set LDE2 = $HOME/maiko/sunos4.sparc/ldeether -set LDEPATH = $HOME -set LDE2PATH = $HOME/maiko/sunos4.sparc -set INITLDE = $HOME/maiko/sunos4.sparc/ldeinit -set INITLDEPATH = $HOME/maiko/init.sparc -#set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -set FULL_SYSOUT = $HOME/smallFULL.SYSOUT -set FIRST_REM_CM = /disk1/lispcore3.0/SUNLOADUP/XREM.CM -set SECOND_REM_CM = /disk1/lispcore3.0/SUNLOADUP/LOADFULL-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINITFULL -rm ~/REM.CM -$LDE $FULL_SYSOUT - - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc) -#set path=(/bin /usr/bin /usr/ucb /etc /usr/etc $LDE2PATH) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem - - diff --git a/obsolete/sunloadup/runloadfull-2nd b/obsolete/sunloadup/runloadfull-2nd deleted file mode 100644 index 6b3ce2b5..00000000 --- a/obsolete/sunloadup/runloadfull-2nd +++ /dev/null @@ -1,38 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure thru to FULL.SYSOUT -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -set LDE = $HOME/maiko/sunos4.sparc/ldeether -set LDEPATH = $HOME/maiko/sunos4.sparc -set INITLDE = $HOME/maiko/sunos4.sparc/ldeinit -set INITLDEPATH = $HOME/maiko/init.sparc -set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADFULL-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -#set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -#setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINITFULL -#rm ~/REM.CM -#$LDE $FULL_SYSOUT -#ldeether $FULL_SYSOUT - -# Boot INIT.DLINIT and LOGOUT. -#set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -#unsetenv LDEDESTSYSOUT -#cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -#if( -e ~/lisp.virtualmem ) then -# mv ~/lisp.virtualmem ~/lisp.virtualmem.save -#endif -#$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem - -#~/ldemulti3 ~/lisp.virtualmem -NF diff --git a/obsolete/sunloadup/runloadfull-dsk b/obsolete/sunloadup/runloadfull-dsk deleted file mode 100644 index 0c845ee1..00000000 --- a/obsolete/sunloadup/runloadfull-dsk +++ /dev/null @@ -1,47 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure thru to FULL.SYSOUT -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -set LDEPATH = $HOME -#set LDEPATH2 = $HOME/maiko/sunos4.sparc -set LDEPATH2 = $HOME -#set LDE = $LDEPATH/oldldex -set LDE = /users/sybalsky/ldeether -set LDE2 = $LDEPATH/ldemulti -set INITLDE = $LDEPATH/ldeinit -set INITLDEPATH = $HOME/maiko/init.sparc -#set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -set FULL_SYSOUT = $HOME/smallFULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADFULL-REM.CM -# - -setenv LDEFILETIMEOUT 1000000 - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINITDSK -rm ~/REM.CM -$LDE $FULL_SYSOUT - - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM - save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc) -set path=(/bin /usr/bin /usr/ucb /etc /usr/etc $LDEPATH2) -cp $SECOND_REM_CM ~/REM.CM -#newlde -$LDE ~/lisp.virtualmem - - diff --git a/obsolete/sunloadup/runloadfull-sgi b/obsolete/sunloadup/runloadfull-sgi deleted file mode 100644 index 31e3ac6d..00000000 --- a/obsolete/sunloadup/runloadfull-sgi +++ /dev/null @@ -1,42 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure thru to FULL.SYSOUT -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -set LDE = $HOME/maiko/irix.sgi/ldex-small -set LDE2 = $HOME/maiko/irix.sgi/lde -set LDEPATH = $HOME/maiko/irix.sgi -set INITLDE = $HOME/maiko/irix.sgi/ldeinit -set INITLDEPATH = $HOME/maiko/init.sgi -#set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -set FULL_SYSOUT = $HOME/smallFULL.SYSOUT -#set FULL_SYSOUT = $HOME/bigLISP.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADFULL-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -#set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -#setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINITFULLSGI -#rm ~/REM.CM -#$LDE $FULL_SYSOUT - - -# Boot INIT.DLINIT and LOGOUT. -#set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -#unsetenv LDEDESTSYSOUT -#cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -#if( -e ~/lisp.virtualmem ) then - #mv ~/lisp.virtualmem ~/lisp.virtualmem.save -#endif -#$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -#set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc) -set path=( $LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc ) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem - - diff --git a/obsolete/sunloadup/runloadfullfromlisp b/obsolete/sunloadup/runloadfullfromlisp deleted file mode 100644 index 67b677d9..00000000 --- a/obsolete/sunloadup/runloadfullfromlisp +++ /dev/null @@ -1,38 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure thru to FULL.SYSOUT -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -set LDE = $HOME/ldeether -set LDEPATH = $HOME -set INITLDE = $HOME/maiko/sunos4.sparc/ldeinit -set INITLDEPATH = $HOME/maiko/init.sparc -#set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -set FULL_SYSOUT = $HOME/smallFULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADFULLFROMLISP-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -#set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.LOADFULLFROMLISP -#rm ~/REM.CM -#$LDE $FULL_SYSOUT -##ldeether $FULL_SYSOUT - -# Boot INIT.DLINIT and LOGOUT. -#set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -#unsetenv LDEDESTSYSOUT -#cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -#if( -e ~/lisp.virtualmem ) then - #mv ~/lisp.virtualmem ~/lisp.virtualmem.save -#endif -#$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=(~ /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -#$LDE ~/lisp.virtualmem -$LDE $HOME/smallLISP.SYSOUT diff --git a/obsolete/sunloadup/runloadup b/obsolete/sunloadup/runloadup deleted file mode 100644 index df736b39..00000000 --- a/obsolete/sunloadup/runloadup +++ /dev/null @@ -1,38 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -set LDE = $HOME/maiko/sunos4.sparc/ldeether -set LDEPATH = $HOME -set INITLDE = $HOME/maiko/sunos4.sparc/ldeinit -set INITLDEPATH = $HOME/maiko/init.sparc -set FULL_SYSOUT = $HOME/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADUP-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINIT -rm ~/REM.CM -#$LDE $FULL_SYSOUT -ldeether $FULL_SYSOUT - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=($LDEPATH/maiko/sunos4.sparc /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem - -#~/ldemulti3 ~/lisp.virtualmem -NF diff --git a/obsolete/sunloadup/runloadup-2nd b/obsolete/sunloadup/runloadup-2nd deleted file mode 100644 index 2bb386bb..00000000 --- a/obsolete/sunloadup/runloadup-2nd +++ /dev/null @@ -1,31 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure -# run 2nd and 3rd step for loadup -# -set LDE = $HOME/maiko/sunos4.sparc/lde -set LDEPATH = $HOME/maiko/sunos4.sparc -set INITLDE = $HOME/maiko/sunos4.sparc/ldeinit -set INITLDEPATH = $HOME/maiko/init.sparc -set FULL_SYSOUT = /python1/fuji/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADUP-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem diff --git a/obsolete/sunloadup/runloadup-2nd-sun3 b/obsolete/sunloadup/runloadup-2nd-sun3 deleted file mode 100644 index 686d5618..00000000 --- a/obsolete/sunloadup/runloadup-2nd-sun3 +++ /dev/null @@ -1,31 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure -# run 2nd and 3rd step for loadup -# -set LDE = $HOME/maiko/sunos4.mc68020/lde -set LDEPATH = $HOME/maiko/sunos4.mc68020 -set INITLDE = $HOME/maiko/init.mc68020/lde -set INITLDEPATH = $HOME/maiko/init.mc68020 -set FULL_SYSOUT = /python1/fuji/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADUP-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem diff --git a/obsolete/sunloadup/runloadup-main b/obsolete/sunloadup/runloadup-main deleted file mode 100644 index e425fe9c..00000000 --- a/obsolete/sunloadup/runloadup-main +++ /dev/null @@ -1,34 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure -# -set LDE = $HOME/maiko/sunos4.sparc/lde -set LDEPATH = $HOME/maiko/sunos4.sparc -set INITLDE = $HOME/maiko/init.sparc/lde -set INITLDEPATH = $HOME/maiko/init.sparc -set FULL_SYSOUT = /python1/fuji/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADUP-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINIT-MAIN -rm ~/REM.CM -$LDE $FULL_SYSOUT - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem diff --git a/obsolete/sunloadup/runloadup-nodmachine b/obsolete/sunloadup/runloadup-nodmachine deleted file mode 100644 index ffdc9384..00000000 --- a/obsolete/sunloadup/runloadup-nodmachine +++ /dev/null @@ -1,35 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure -# Remove D-Machine specific code version -# -set LDE = $HOME/maiko/sunos4.sparc/lde -set LDEPATH = $HOME/maiko/sunos4.sparc -set INITLDE = $HOME/maiko/init.sparc/lde -set INITLDEPATH = $HOME/maiko/init.sparc -set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADUP-NODMACHINE-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINIT -rm ~/REM.CM -$LDE $FULL_SYSOUT - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem diff --git a/obsolete/sunloadup/runloadup-noether b/obsolete/sunloadup/runloadup-noether deleted file mode 100644 index 9835e7d4..00000000 --- a/obsolete/sunloadup/runloadup-noether +++ /dev/null @@ -1,35 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure -# NO Ether version -# -set LDE = $HOME/maiko/sunos4.sparc/lde -set LDEPATH = $HOME/maiko/sunos4.sparc -set INITLDE = $HOME/maiko/init.sparc/lde -set INITLDEPATH = $HOME/maiko/init.sparc -set FULL_SYSOUT = /usr/local/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM-NOETHER.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADUP-NOETHER-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINIT-NOETHER -rm ~/REM.CM -$LDE $FULL_SYSOUT - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem diff --git a/obsolete/sunloadup/runloadup-nt b/obsolete/sunloadup/runloadup-nt deleted file mode 100644 index d5c8151f..00000000 --- a/obsolete/sunloadup/runloadup-nt +++ /dev/null @@ -1,38 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure -# -#set LDE = $HOME/maiko/sunos4.sparc/lde -set LDENT = $HOME/maiko/sunos4.sparc/ldemulti -set LDENTPATH = $HOME/maiko/sunos4.sparc -set INITLDE = $HOME/maiko/init.sparc/lde -set INITLDEPATH = $HOME/maiko/init.sparc -set FULL_SYSOUT = /python1/fuji/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADUP-REM.CM -# -set LDE = $HOME/maiko/savelde.sparc/lde -set LDEPATH = $HOME/maiko/savelde.sparc -# - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINIT -rm ~/REM.CM -$LDE $FULL_SYSOUT - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=($LDENTPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDENT ~/lisp.virtualmem diff --git a/obsolete/sunloadup/runloadup-sun3 b/obsolete/sunloadup/runloadup-sun3 deleted file mode 100644 index 34b8c64c..00000000 --- a/obsolete/sunloadup/runloadup-sun3 +++ /dev/null @@ -1,34 +0,0 @@ -#! /bin/csh -f -# -# automatic loadup procedure -# -set LDE = $HOME/maiko/sunos4.mc68020/lde -set LDEPATH = $HOME/maiko/sunos4.mc68020 -set INITLDE = $HOME/maiko/init.mc68020/lde -set INITLDEPATH = $HOME/maiko/init.mc68020 -set FULL_SYSOUT = /python1/fuji/sysouts/FULL.SYSOUT -set FIRST_REM_CM = $HOME/SUNLOADUP/XREM.CM -set SECOND_REM_CM = $HOME/SUNLOADUP/LOADUP-REM.CM -# - -#first create INIT.SYSOUT and INIT.DLINIT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -setenv LDEINIT $HOME/SUNLOADUP/INIT.MAKEINIT -rm ~/REM.CM -$LDE $FULL_SYSOUT - -# Boot INIT.DLINIT and LOGOUT. -set path=($INITLDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -unsetenv LDEDESTSYSOUT -cp $FIRST_REM_CM ~/REM.CM -# save your lisp.virtualmem -if( -e ~/lisp.virtualmem ) then - mv ~/lisp.virtualmem ~/lisp.virtualmem.save -endif -$INITLDE ~/INIT.DLINIT -INIT - -# Finally boot ~/lisp.virtualmem created by previous LOGOUT, -# and MAKESYS LISP.SYSOUT -set path=($LDEPATH /bin /usr/bin /usr/ucb /etc /usr/etc) -cp $SECOND_REM_CM ~/REM.CM -$LDE ~/lisp.virtualmem diff --git a/obsolete/sunloadup/xrem.cm b/obsolete/sunloadup/xrem.cm deleted file mode 100644 index 82ea1e4d..00000000 --- a/obsolete/sunloadup/xrem.cm +++ /dev/null @@ -1 +0,0 @@ -" (SETQ SI::*CLOSURE-CACHE-ENABLED* NIL) (QUOTE (\\TEDIT.BLTCHAR \\MAIKO.PUNTBLTCHAR SI::*CLOSURE-CACHE* XCL::*DELETED-IMPLICIT-HASH-SLOT* )) (MOVD? (QUOTE NILL) (QUOTE PROMPTPRINT)) (MOVD? (QUOTE NILL) (QUOTE CURSORP)) (MOVD? (QUOTE NILL) (QUOTE CHANGEBACKGROUNDBORDER)) (MOVD (QUOTE \ETHEREVENTFN) (QUOTE \ETHEREVENTFN-)) (MOVD (QUOTE NILL) (QUOTE \ETHEREVENTFN)) (LOGOUT) " \ No newline at end of file diff --git a/obsolete/tcp/TCP b/obsolete/tcp/TCP deleted file mode 100644 index 49a212eb..00000000 --- a/obsolete/tcp/TCP +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Aug-90 12:01:50" {DSK}ETHERNET>TCP>NEW>TCP.;5 98103 changes to%: (FILES TCPLLIP) (FNS \TCP.DELETE.TCB) previous date%: "13-Feb-89 21:04:17" {DSK}ETHERNET>TCP>NEW>TCP.;3) (* " Copyright (c) 1983, 1984, 1985, 1986, 1901, 1900, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPCOMS) (RPAQQ TCPCOMS [(COMS (* ;; "Transmission Control Protocol. RFC 793, September 1981") ) (COMS (DECLARE%: EVAL@LOAD (FILES (SYSLOAD) TCPLLIP)) (GLOBALVARS \TCP.LOCK \TCP.CONTROL.BLOCKS \TCP.CHECKSUMS.ON \TCP.PSEUDOHEADER \TCP.MSL \TCP.DEFAULT.USER.TIMEOUT \TCP.DEFAULT.RECEIVE.WINDOW \TCP.DEVICE \TCP.MASTER.SOCKET)) (COMS (* ;; "DoD Internet addresses") (FNS SET.IP.ADDRESS STRING.TO.IP.ADDRESS IP.ADDRESS.TO.STRING \LOCAL.IP.ADDRESS)) [COMS (* ;; "TCP segments") (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "control bits for TCP.CTRL field of TCP header") (EXPORT (CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST \TCP.CTRL.SYN \TCP.CTRL.URG) (* ;; "option definitions") (CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG) (* ;; "TCP protocol number for IP level dispatch") (CONSTANTS \TCP.PROTOCOL) (* ;; "TCP header length in bytes (= 4 * min data offset)") (CONSTANTS \TCP.HEADER.LENGTH) (* ;;  "minimum offset of data from segment in 32-bit words (= header length / 4)") (CONSTANTS \TCP.MIN.DATA.OFFSET) (* ;; "default maximum segment size") (CONSTANTS \TCP.DEFAULT.MAXSEG) (* ;; "TCP segment") (RECORDS TCPSEGMENT] (COMS (* ;; "TCP sequence numbers") (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "macros for comparing TCP sequence numbers") (MACROS \32BIT.EQ \32BIT.LT \32BIT.LEQ \32BIT.GT \32BIT.GEQ) (* ;; "fast multiply by 3 -- evaluates its argument twice") (MACROS \3TIMES)) (FNS \TCP.SELECT.ISS)) (COMS (* ;; "TCP control blocks") (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "TCP control block") (EXPORT (RECORDS TCP.CONTROL.BLOCK TCPSTREAM)) (* ;; "TCP stream") ) (INITRECORDS TCP.CONTROL.BLOCK TCPSTREAM) (* ;; "global lock for TCP-related mutual exclusion") (INITVARS (\TCP.LOCK (CREATE.MONITORLOCK))) (* ;; "list of TCP control blocks for connection lookup") (INITVARS (\TCP.CONTROL.BLOCKS NIL)) (FNS \TCP.CREATE.TCB \TCP.SELECT.PORT \TCP.LOOKUP.TCB \TCP.DELETE.TCB \TCP.NOSOCKETFN \TCP.PORTCOMPARE)) (COMS (* ;; "TCP checksums") (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "pseudo-header for checksum calculation") (RECORDS TCP.PSEUDOHEADER) (CONSTANTS \TCP.PSEUDOHEADER.LENGTH) (MACROS \16BIT.COMPLEMENT \16BIT.1C.PLUS)) (INITRECORDS TCP.PSEUDOHEADER) (INITVARS (\TCP.PSEUDOHEADER NIL)) (* ;; "this variable controls whether checksums are performed on incoming segments") (INITVARS (\TCP.CHECKSUMS.ON NIL)) (* ;; "checksum routines") (FNS \COMPUTE.CHECKSUM \TCP.CHECKSUM.INCOMING \TCP.CHECKSUM.OUTGOING)) (COMS (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "constants for retransmission timeout calculation") (* ;; "initial retransmission timeout") (CONSTANTS \TCP.INITIAL.RTO) (* ;; "upper and lower bounds on retransmission timeout") (CONSTANTS (\TCP.UBOUND 5000) (\TCP.LBOUND 1000))) (* ;; "maximum segment lifetime") (INITVARS (\TCP.MSL 5000)) (INITVARS (\TCP.DEFAULT.USER.TIMEOUT 60000) (\TCP.DEFAULT.RECEIVE.WINDOW 4096) (\TCP.DEVICE NIL)) (* ;; "TCP protocol routines") (FNS \TCP.ACK# \TCP.PACKET.FILTER \TCP.SETUP.SEGMENT \TCP.RELEASE.SEGMENT \TCP.CONNECTION \TCP.FIX.INCOMING.SEGMENT \TCP.DATA.LENGTH \TCP.SYN.OR.FIN \TCP.INPUT \TCP.INPUT.INITIAL \TCP.INPUT.UNSYNC \TCP.INPUT.LISTEN \TCP.INPUT.SYN.SENT \TCP.CHECK.WINDOW \TCP.CHECK.RESET \TCP.CHECK.SECURITY \TCP.CHECK.NO.SYN \TCP.CHECK.ACK \TCP.HANDLE.ACK \TCP.HANDLE.URG \TCP.QUEUE.INPUT \TCP.HANDLE.FIN \TCP.OUR.FIN.IS.ACKED \TCP.SIGNAL.URGENT.DATA \TCP.PROCESS \TCP.TEMPLATE \TCP.SETUP.SEGMENT.OPTIONS \TCP.SEND.CONTROL \TCP.SEND.ACK \TCP.SEND.RESET \TCP.FIX.OUTGOING.SEGMENT \TCP.SEND.DATA \TCP.SEND.SEGMENT \TCP.NEW.TEMPLATE \TCP.START.PROBE.TIMER \TCP.RETRANSMIT \TCP.START.TIME.WAIT \TCP.CONNECTION.DROPPED \TCP.CHECK.OPTIONS \TCP.PROCESS.OPTIONS)) (COMS (* ;; "support for ICMP messages that affect TCP connections") (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "ICMP protocol number for IP level dispatch") (CONSTANTS \ICMP.PROTOCOL) (* ;;  "number of 32 bit words in ICMP message before start of original datagram") (CONSTANTS \ICMP.32BIT.WORDS) (* ;; "relevant ICMP message types") (CONSTANTS \ICMP.DESTINATION.UNREACHABLE \ICMP.SOURCE.QUENCH)) (FNS \TCP.HANDLE.ICMP)) (COMS (* ;; "TCP stream routines") (FNS TCP.OPEN TCP.OTHER.STREAM \TCP.BOUTS \TCP.OTHER.BIN \TCP.OTHER.BOUT \TCP.BIN \TCP.BACKFILEPTR \TCP.GETNEXTBUFFER \TCP.GET.SEGMENT \TCP.PEEKBIN \TCP.GETFILEPTR \TCP.READP \TCP.EOFP TCP.URGENTP TCP.URGENT.EVENT \TCP.BOUT \TCP.FLUSH \TCP.FORCEOUTPUT TCP.URGENT.MARK \TCP.FILL.IN.SEGMENT \TCP.CLOSE \TCP.RESETCLOSE TCP.CLOSE.SENDER TCP.DESTADDRESS TCP.STOP)) (COMS (* ;; "well-known ports for network standard functions") (CONSTANTS * \TCP.ASSIGNED.PORTS)) (COMS (* ;; "Stub for debugging") (INITVARS (\TCP.DEBUGGABLE) (TCPTRACEFLG)) (GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG) (FNS PPTCB \TCP.TRACE.SEGMENT \TCP.TRACE.TRANSITION)) (COMS (* ;; "TCP initialization") (FNS \TCP.INIT) (P (\TCP.INIT]) (* ;; "Transmission Control Protocol. RFC 793, September 1981") (DECLARE%: EVAL@LOAD (FILESLOAD (SYSLOAD) TCPLLIP) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TCP.LOCK \TCP.CONTROL.BLOCKS \TCP.CHECKSUMS.ON \TCP.PSEUDOHEADER \TCP.MSL \TCP.DEFAULT.USER.TIMEOUT \TCP.DEFAULT.RECEIVE.WINDOW \TCP.DEVICE \TCP.MASTER.SOCKET) ) (* ;; "DoD Internet addresses") (DEFINEQ (SET.IP.ADDRESS (LAMBDA NIL (* ejs%: "28-Dec-84 18:45") (* set local IP address manually) (PROG ((ADDR (\IP.READ.STRING.ADDRESS (PROMPTFORWORD "Enter IP address:" (\IP.ADDRESS.TO.STRING (OR (CAR \IP.LOCAL.ADDRESSES) 0)))))) (SETQ \IP.LOCAL.ADDRESSES (LIST ADDR)))) ) (STRING.TO.IP.ADDRESS (LAMBDA (STR) (* ecc "14-May-84 15:01") (APPLY (FUNCTION IP\Make\Address) (to 4 bind (I _ 0) OFFSET collect (SETQ OFFSET (ADD1 I)) (MKATOM (SUBSTRING STR OFFSET (AND (SETQ I (STRPOS "." STR OFFSET)) (SUB1 I))))))) ) (IP.ADDRESS.TO.STRING (LAMBDA (IPADDR) (* ecc "14-May-84 14:32") (PROG ((A (LOADBYTE IPADDR 24 8)) (B (LOADBYTE IPADDR 16 8)) (C (LOADBYTE IPADDR 8 8)) (D (LOADBYTE IPADDR 0 8))) (RETURN (CONCAT A "." B "." C "." D)))) ) (\LOCAL.IP.ADDRESS (LAMBDA NIL (* ejs%: "28-Dec-84 18:45") (* return our IP address (or the first if we're multi-homed)) (if (NULL \IP.LOCAL.ADDRESSES) then (ERROR "You must set \IP.LOCAL.ADDRESSES to a list of our local IP addresses")) (CAR \IP.LOCAL.ADDRESSES)) ) ) (* ;; "TCP segments") (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.CTRL.ACK 16) (RPAQQ \TCP.CTRL.FIN 1) (RPAQQ \TCP.CTRL.PSH 8) (RPAQQ \TCP.CTRL.RST 4) (RPAQQ \TCP.CTRL.SYN 2) (RPAQQ \TCP.CTRL.URG 32) (CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST \TCP.CTRL.SYN \TCP.CTRL.URG) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TCPOPT.END 0) (RPAQQ \TCPOPT.NOP 1) (RPAQQ \TCPOPT.MAXSEG 2) (CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.PROTOCOL 6) (CONSTANTS \TCP.PROTOCOL) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.HEADER.LENGTH 20) (CONSTANTS \TCP.HEADER.LENGTH) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.MIN.DATA.OFFSET 5) (CONSTANTS \TCP.MIN.DATA.OFFSET) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.DEFAULT.MAXSEG 536) (CONSTANTS \TCP.DEFAULT.MAXSEG) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS TCPSEGMENT ((TCPHEADER (\IPDATABASE DATUM))) (BLOCKRECORD TCPHEADER ((TCP.SRC.PORT WORD) (TCP.DST.PORT WORD) (TCP.SEQ FIXP) (TCP.ACK FIXP) (TCP.DATA.OFFSET BITS 4) (TCP.MBZ BITS 6) (TCP.CTRL BITS 6) (TCP.WINDOW WORD) (TCP.CHECKSUM WORD) (TCP.URG.PTR WORD))) [ACCESSFNS TCPSEGMENT ((TCP.DATA.LENGTH (fetch (IP IPHEADERCHECKSUM) of DATUM) (replace (IP IPHEADERCHECKSUM) of DATUM with NEWVALUE)) (TCP.SRC.ADDR (fetch (IP IPSOURCEADDRESS) of DATUM) (replace (IP IPSOURCEADDRESS) of DATUM with NEWVALUE)) (TCP.DST.ADDR (fetch (IP IPDESTINATIONADDRESS) of DATUM) (replace (IP IPDESTINATIONADDRESS) of DATUM with NEWVALUE)) (TCP.HEADER.LENGTH (LLSH (fetch TCP.DATA.OFFSET of DATUM) 2)) (TCP.CONTENTS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD (fetch TCP.DATA.OFFSET of DATUM) WORDSPERCELL))) (TCP.OPTIONS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD \TCP.MIN.DATA.OFFSET WORDSPERCELL]) ) (* "END EXPORTED DEFINITIONS") ) (* ;; "TCP sequence numbers") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \32BIT.EQ MACRO ((A B) (IEQP A B))) (PUTPROPS \32BIT.LT MACRO ((A B) (ILESSP (IDIFFERENCE A B) 0))) (PUTPROPS \32BIT.LEQ MACRO ((A B) (ILEQ (IDIFFERENCE A B) 0))) (PUTPROPS \32BIT.GT MACRO ((A B) (IGREATERP (IDIFFERENCE A B) 0))) (PUTPROPS \32BIT.GEQ MACRO ((A B) (IGEQ (IDIFFERENCE A B) 0))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \3TIMES MACRO ((N) (IPLUS (LLSH N 1) N))) ) ) (DEFINEQ (\TCP.SELECT.ISS (LAMBDA NIL (* ecc "16-May-84 11:40") (* select an initial send sequence number -- use the time of day to make sure we won't repeat after a crash) (LOGAND (DAYTIME) 65535)) ) ) (* ;; "TCP control blocks") (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (DATATYPE TCP.CONTROL.BLOCK ((TCB.LOCK POINTER) (* monitor lock for synchronizing  access) (TCB.STATE POINTER) (* one of CLOSED LISTEN SYN.SENT  SYN.RECEIVED ESTABLISHED FIN.WAIT.1  FIN.WAIT.2 CLOSE.WAIT CLOSING  LAST.ACK TIME.WAIT) (TCB.SND.STREAM POINTER) (* user's send stream) (TCB.SND.SEGMENT POINTER) (* current output packet being  filled) (TCB.RCV.STREAM POINTER) (* user's receive stream) (TCB.RCV.SEGMENT POINTER) (* current input packet being read) (TCB.2MSL.TIMER POINTER) (* 2*MSL quiet time) (TCB.MAXSEG POINTER) (* maximum segment size) (TCB.CLOSEDFLG POINTER) (* T if user has initiated close  (no more data to send)) (TCB.FINSEQ POINTER) (* one past the sequence number of  the FIN we sent) (TCB.ACKFLG POINTER) (* when to ACK peer%: NOW or LATER) (TCB.TEMPLATE POINTER) (* TCP header template) (TCB.PH POINTER) (* TCP pseudo-header for  checksumming) (TCB.SRC.PORT WORD) (* local port) (TCB.DST.PORT WORD) (* remote port) (TCB.DST.HOST FIXP) (* remote host address) (TCB.INPUT.QUEUE POINTER) (* queue of received segments to be  read) (TCB.REXMT.QUEUE POINTER) (* queue of unacked segments to be  retransmitted) (TCB.SND.UNA FIXP) (* first unacknowledged sequence  number) (TCB.SND.NXT FIXP) (* next sequence number to be sent) (TCB.SND.UP FIXP) (* send urgent pointer) (TCB.SND.WL1 FIXP) (* segment sequence number used for  last window update) (TCB.SND.WL2 FIXP) (* segment acknowledgment number  used for last window update) (TCB.ISS FIXP) (* initial send sequence number) (TCB.SND.WND WORD) (* send window) (TCB.RCV.WND WORD) (* receive window) (TCB.RCV.NXT FIXP) (* next sequence number expected) (TCB.RCV.UP FIXP) (* receive urgent pointer) (TCB.IRS FIXP) (* initial receive sequence number) (TCB.USER.TIMEOUT POINTER) (* in milliseconds) (TCB.ESTABLISHED POINTER) (* processes waiting for this event  are notified when the connection  becomes established) (TCB.SND.EVENT POINTER) (* processes waiting for this event  are notified when the send window  opens up) (TCB.RCV.EVENT POINTER) (* processes waiting for this event  are notified when data is received) (TCB.URGENT.EVENT POINTER) (* processes waiting for this event  are notified when urgent data is  received) (TCB.FINACKED.EVENT POINTER)(* processes waiting for this event  are notified when our FIN has been  acked) (TCB.MODE POINTER) (* ACTIVE or PASSIVE) (TCB.RTFLG POINTER) (* T if round trip time being  measured) (TCB.RTSEQ POINTER) (* sequence number being timed) (TCB.RTTIMER POINTER) (* round trip timer) (TCB.SRTT POINTER) (* smoothed round trip time) (TCB.RTO POINTER) (* retransmission timeout based on  smoothed round trip time) (TCB.PROBE.TIMER POINTER) (* timer for delayed ACKs and window  probes) (TCB.IPSOCKET POINTER) (* Pointer to open IP socket for  this connection) (TCB.PROCESS POINTER) (* TCP monitor process for this  connection) (TCB.SENT.ZERO FLAG) (* Sent a zero allocation last time) (TCB.OUTPUT.HELD FLAG) (* True if output window shut) (TCB.NO.IDLE.PROBING FLAG) (* True if we don't probe when  nothing to output) (NIL BITS 5) (TCB.OUR.MAXSEG WORD) (TCB.LAST.SENT.RCV.WND WORD)(* The value of the last rcv window  we sent) ) TCB.LOCK _ (CREATE.MONITORLOCK) TCB.STATE _ 'CLOSED TCB.RCV.WND _ \TCP.DEFAULT.RECEIVE.WINDOW TCB.USER.TIMEOUT _ \TCP.DEFAULT.USER.TIMEOUT TCB.ESTABLISHED _ ( CREATE.EVENT ) TCB.SND.EVENT _ (CREATE.EVENT) TCB.RCV.EVENT _ (CREATE.EVENT) TCB.URGENT.EVENT _ (CREATE.EVENT) TCB.FINACKED.EVENT _ (CREATE.EVENT) TCB.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.OUR.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.SRTT _ \TCP.INITIAL.RTO TCB.RTO _ \TCP.INITIAL.RTO) (ACCESSFNS TCPSTREAM ((TCB (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) (BYTECOUNT (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)) (ACCESS (fetch (STREAM ACCESS) of DATUM) (replace (STREAM ACCESS) of DATUM with NEWVALUE)) (ORIGINAL.COFFSET (fetch (STREAM FW6) of DATUM) (replace (STREAM FW6) of DATUM with NEWVALUE))) (CREATE (create STREAM DEVICE _ \TCP.DEVICE))) ) (/DECLAREDATATYPE 'TCP.CONTROL.BLOCK '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD FIXP POINTER POINTER FIXP FIXP FIXP FIXP FIXP FIXP WORD WORD FIXP FIXP FIXP POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG (BITS 5) WORD WORD) '((TCP.CONTROL.BLOCK 0 POINTER) (TCP.CONTROL.BLOCK 2 POINTER) (TCP.CONTROL.BLOCK 4 POINTER) (TCP.CONTROL.BLOCK 6 POINTER) (TCP.CONTROL.BLOCK 8 POINTER) (TCP.CONTROL.BLOCK 10 POINTER) (TCP.CONTROL.BLOCK 12 POINTER) (TCP.CONTROL.BLOCK 14 POINTER) (TCP.CONTROL.BLOCK 16 POINTER) (TCP.CONTROL.BLOCK 18 POINTER) (TCP.CONTROL.BLOCK 20 POINTER) (TCP.CONTROL.BLOCK 22 POINTER) (TCP.CONTROL.BLOCK 24 POINTER) (TCP.CONTROL.BLOCK 26 (BITS . 15)) (TCP.CONTROL.BLOCK 27 (BITS . 15)) (TCP.CONTROL.BLOCK 28 FIXP) (TCP.CONTROL.BLOCK 30 POINTER) (TCP.CONTROL.BLOCK 32 POINTER) (TCP.CONTROL.BLOCK 34 FIXP) (TCP.CONTROL.BLOCK 36 FIXP) (TCP.CONTROL.BLOCK 38 FIXP) (TCP.CONTROL.BLOCK 40 FIXP) (TCP.CONTROL.BLOCK 42 FIXP) (TCP.CONTROL.BLOCK 44 FIXP) (TCP.CONTROL.BLOCK 46 (BITS . 15)) (TCP.CONTROL.BLOCK 47 (BITS . 15)) (TCP.CONTROL.BLOCK 48 FIXP) (TCP.CONTROL.BLOCK 50 FIXP) (TCP.CONTROL.BLOCK 52 FIXP) (TCP.CONTROL.BLOCK 54 POINTER) (TCP.CONTROL.BLOCK 56 POINTER) (TCP.CONTROL.BLOCK 58 POINTER) (TCP.CONTROL.BLOCK 60 POINTER) (TCP.CONTROL.BLOCK 62 POINTER) (TCP.CONTROL.BLOCK 64 POINTER) (TCP.CONTROL.BLOCK 66 POINTER) (TCP.CONTROL.BLOCK 68 POINTER) (TCP.CONTROL.BLOCK 70 POINTER) (TCP.CONTROL.BLOCK 72 POINTER) (TCP.CONTROL.BLOCK 74 POINTER) (TCP.CONTROL.BLOCK 76 POINTER) (TCP.CONTROL.BLOCK 78 POINTER) (TCP.CONTROL.BLOCK 80 POINTER) (TCP.CONTROL.BLOCK 82 POINTER) (TCP.CONTROL.BLOCK 82 (FLAGBITS . 0)) (TCP.CONTROL.BLOCK 82 (FLAGBITS . 16)) (TCP.CONTROL.BLOCK 82 (FLAGBITS . 32)) (TCP.CONTROL.BLOCK 82 (BITS . 52)) (TCP.CONTROL.BLOCK 84 (BITS . 15)) (TCP.CONTROL.BLOCK 85 (BITS . 15))) '86) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'TCP.CONTROL.BLOCK '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD FIXP POINTER POINTER FIXP FIXP FIXP FIXP FIXP FIXP WORD WORD FIXP FIXP FIXP POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG (BITS 5) WORD WORD) '((TCP.CONTROL.BLOCK 0 POINTER) (TCP.CONTROL.BLOCK 2 POINTER) (TCP.CONTROL.BLOCK 4 POINTER) (TCP.CONTROL.BLOCK 6 POINTER) (TCP.CONTROL.BLOCK 8 POINTER) (TCP.CONTROL.BLOCK 10 POINTER) (TCP.CONTROL.BLOCK 12 POINTER) (TCP.CONTROL.BLOCK 14 POINTER) (TCP.CONTROL.BLOCK 16 POINTER) (TCP.CONTROL.BLOCK 18 POINTER) (TCP.CONTROL.BLOCK 20 POINTER) (TCP.CONTROL.BLOCK 22 POINTER) (TCP.CONTROL.BLOCK 24 POINTER) (TCP.CONTROL.BLOCK 26 (BITS . 15)) (TCP.CONTROL.BLOCK 27 (BITS . 15)) (TCP.CONTROL.BLOCK 28 FIXP) (TCP.CONTROL.BLOCK 30 POINTER) (TCP.CONTROL.BLOCK 32 POINTER) (TCP.CONTROL.BLOCK 34 FIXP) (TCP.CONTROL.BLOCK 36 FIXP) (TCP.CONTROL.BLOCK 38 FIXP) (TCP.CONTROL.BLOCK 40 FIXP) (TCP.CONTROL.BLOCK 42 FIXP) (TCP.CONTROL.BLOCK 44 FIXP) (TCP.CONTROL.BLOCK 46 (BITS . 15)) (TCP.CONTROL.BLOCK 47 (BITS . 15)) (TCP.CONTROL.BLOCK 48 FIXP) (TCP.CONTROL.BLOCK 50 FIXP) (TCP.CONTROL.BLOCK 52 FIXP) (TCP.CONTROL.BLOCK 54 POINTER) (TCP.CONTROL.BLOCK 56 POINTER) (TCP.CONTROL.BLOCK 58 POINTER) (TCP.CONTROL.BLOCK 60 POINTER) (TCP.CONTROL.BLOCK 62 POINTER) (TCP.CONTROL.BLOCK 64 POINTER) (TCP.CONTROL.BLOCK 66 POINTER) (TCP.CONTROL.BLOCK 68 POINTER) (TCP.CONTROL.BLOCK 70 POINTER) (TCP.CONTROL.BLOCK 72 POINTER) (TCP.CONTROL.BLOCK 74 POINTER) (TCP.CONTROL.BLOCK 76 POINTER) (TCP.CONTROL.BLOCK 78 POINTER) (TCP.CONTROL.BLOCK 80 POINTER) (TCP.CONTROL.BLOCK 82 POINTER) (TCP.CONTROL.BLOCK 82 (FLAGBITS . 0)) (TCP.CONTROL.BLOCK 82 (FLAGBITS . 16)) (TCP.CONTROL.BLOCK 82 (FLAGBITS . 32)) (TCP.CONTROL.BLOCK 82 (BITS . 52)) (TCP.CONTROL.BLOCK 84 (BITS . 15)) (TCP.CONTROL.BLOCK 85 (BITS . 15))) '86) (* ;; "global lock for TCP-related mutual exclusion") (RPAQ? \TCP.LOCK (CREATE.MONITORLOCK)) (* ;; "list of TCP control blocks for connection lookup") (RPAQ? \TCP.CONTROL.BLOCKS NIL) (DEFINEQ (\TCP.CREATE.TCB (LAMBDA (DST.HOST DST.PORT SRC.PORT MODE OUR.MAXSEG) (* ejs%: "27-May-86 14:39") (* create a new TCB and the input and output streams that go with it) (WITH.FAST.MONITOR \TCP.LOCK (PROG ((TCB (create TCP.CONTROL.BLOCK TCB.DST.HOST _ DST.HOST TCB.DST.PORT _ DST.PORT TCB.SRC.PORT _ (if (ZEROP SRC.PORT) then (\TCP.SELECT.PORT) else SRC.PORT) TCB.INPUT.QUEUE _ (create SYSQUEUE) TCB.REXMT.QUEUE _ (create SYSQUEUE) TCB.MODE _ MODE TCB.OUR.MAXSEG _ (OR OUR.MAXSEG \TCP.DEFAULT.MAXSEG)))) (replace (STREAM STRMBOUTFN) of (replace TCB.RCV.STREAM of TCB with (create TCPSTREAM ACCESS _ (QUOTE INPUT) TCB _ TCB BYTECOUNT _ 0)) with (FUNCTION \TCP.OTHER.BOUT)) (replace (STREAM STRMBINFN) of (replace TCB.SND.STREAM of TCB with (create TCPSTREAM ACCESS _ (QUOTE APPEND) TCB _ TCB BYTECOUNT _ 0)) with (FUNCTION \TCP.OTHER.BIN)) (\TCP.START.PROBE.TIMER TCB) (push \TCP.CONTROL.BLOCKS TCB) (* put it on the global list of TCBs so it can be found by \TCP.LOOKUP.TCB) (replace TCB.IPSOCKET of TCB with (\IP.OPEN.SOCKET \TCP.PROTOCOL TCB)) (* Tell IP about it) (RETURN TCB)))) ) (\TCP.SELECT.PORT (LAMBDA NIL (* ecc " 7-May-84 17:23") (* find a port unique among all TCP connections on this host) (PROG ((PORT (LOGAND (DAYTIME) 65535))) (until (for TCB in \TCP.CONTROL.BLOCKS always (NEQ PORT (fetch TCB.SRC.PORT of TCB))) do (add PORT 1)) (RETURN PORT))) ) (\TCP.LOOKUP.TCB (LAMBDA (DST.HOST DST.PORT SRC.PORT NOWILDCARDFLG) (* ejs%: "21-Mar-86 18:40") (* Find a TCB that matches the specified addresses. If NOWILDCARDFLG is non-NIL we match against a partially specified TCB if no fully specified one was found.) (WITH.FAST.MONITOR \TCP.LOCK (bind WILDCARD for TCB in \TCP.CONTROL.BLOCKS do (if (EQ SRC.PORT (fetch TCB.SRC.PORT of TCB)) then (* only check further if the local ports match) (if (AND (IEQP DST.HOST (fetch TCB.DST.HOST of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB))) then (* a full match) (RETURN TCB) elseif (AND (NOT NOWILDCARDFLG) (NULL WILDCARD) (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (IEQP DST.HOST (fetch TCB.DST.HOST of TCB))) (OR (ZEROP (fetch TCB.DST.PORT of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB)))) then (* a wildcard match) (SETQ WILDCARD TCB))) finally (RETURN (if NOWILDCARDFLG then NIL else WILDCARD))))) ) (\TCP.DELETE.TCB [LAMBDA (TCB) (* ; "Edited 25-Aug-88 18:39 by bvm") (WITH.FAST.MONITOR \TCP.LOCK (\TCP.TRACE.TRANSITION TCB 'CLOSED) (replace TCB.STATE of TCB with 'CLOSED) (\FLUSH.PACKET.QUEUE (fetch TCB.INPUT.QUEUE of TCB)) (\FLUSH.PACKET.QUEUE (fetch TCB.REXMT.QUEUE of TCB)) (SETQ \TCP.CONTROL.BLOCKS (DREMOVE TCB \TCP.CONTROL.BLOCKS)) (\IP.CLOSE.SOCKET (fetch TCB.IPSOCKET of TCB) \TCP.PROTOCOL T) (replace TCB.IPSOCKET of TCB with NIL) [LET [(WHENCLOSEDFN (PROCESSPROP (THIS.PROCESS) 'WHENCLOSEDFN] (COND (WHENCLOSEDFN (CL:FUNCALL WHENCLOSEDFN (fetch TCB.RCV.STREAM of TCB) (fetch TCB.SND.STREAM of TCB] (* ; "break circular links") (replace TCB.SND.STREAM of TCB with NIL) (replace TCB.RCV.STREAM of TCB with NIL) (* ;  "wake up anyone waiting for events to occur") (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB)) (NOTIFY.EVENT (fetch TCB.SND.EVENT of TCB)) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB)) (NOTIFY.EVENT (fetch TCB.URGENT.EVENT of TCB)) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB]) (\TCP.NOSOCKETFN (LAMBDA (IP) (* ejs%: " 1-Feb-86 18:12") (* * Called when no TCP port corresponding to IP packet is found. We try again, allowing for wildcards) (LET* ((PROTOCOLCHAIN (\IP.FIND.PROTOCOL \TCP.PROTOCOL \IP.PROTOCOLS)) (IPSOCKET (fetch (IPSOCKET IPSLINK) of PROTOCOLCHAIN))) (while IPSOCKET do (COND ((\TCP.PORTCOMPARE IP IPSOCKET T) (APPLY* (ffetch (IPSOCKET IPSINPUTFN) of IPSOCKET) IP IPSOCKET) (RETURN)) (T (SETQ IPSOCKET (fetch (IPSOCKET IPSLINK) of IPSOCKET)))) finally (COND ((NOT (BITTEST (fetch TCP.CTRL of IP) \TCP.CTRL.RST)) (COND ((BITTEST (fetch TCP.CTRL of IP) \TCP.CTRL.ACK) (\TCP.SEND.RESET IP (fetch TCP.ACK of IP) 0 \TCP.CTRL.RST)) (T (\TCP.SEND.RESET IP 0 (IPLUS (fetch TCP.SEQ of IP) (fetch TCP.DATA.LENGTH of IP)) (LOGOR \TCP.CTRL.ACK \TCP.CTRL.RST))))) (T (\RELEASE.ETHERPACKET IP)))))) ) (\TCP.PORTCOMPARE (LAMBDA (SEGMENT IPSOCKET WILDCARDFLG) (* ejs%: "13-Apr-85 17:44") (* Find a TCB that matches the specified addresses. If NOWILDCARDFLG is non-NIL we match against a partially specified TCB if no fully specified one was found.) (WITH.FAST.MONITOR \TCP.LOCK (PROG ((DST.HOST (fetch (TCPSEGMENT TCP.SRC.ADDR) of SEGMENT)) (DST.PORT (fetch (TCPSEGMENT TCP.SRC.PORT) of SEGMENT)) (SRC.PORT (fetch (TCPSEGMENT TCP.DST.PORT) of SEGMENT)) (TCB (fetch (IPSOCKET IPSOCKET) of IPSOCKET))) (COND ((AND TCB (EQ SRC.PORT (fetch TCB.SRC.PORT of TCB))) (* only check further if the local ports match) (COND ((AND (IEQP DST.HOST (fetch TCB.DST.HOST of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB))) (* a full match) (RETURN IPSOCKET)) ((AND WILDCARDFLG (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (IEQP DST.HOST (fetch TCB.DST.HOST of TCB))) (OR (ZEROP (fetch TCB.DST.PORT of TCB)) (EQ DST.PORT (fetch TCB.DST.PORT of TCB)))) (* a wildcard match) (RETURN IPSOCKET)))))))) ) ) (* ;; "TCP checksums") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE TCP.PSEUDOHEADER ((PH.SRC.ADDR FIXP) (PH.DST.ADDR FIXP) (NIL BYTE) (PH.PROTOCOL BYTE) (PH.LENGTH WORD)) PH.PROTOCOL _ \TCP.PROTOCOL) ) (/DECLAREDATATYPE 'TCP.PSEUDOHEADER '(FIXP FIXP BYTE BYTE WORD) '((TCP.PSEUDOHEADER 0 FIXP) (TCP.PSEUDOHEADER 2 FIXP) (TCP.PSEUDOHEADER 4 (BITS . 7)) (TCP.PSEUDOHEADER 4 (BITS . 135)) (TCP.PSEUDOHEADER 5 (BITS . 15))) '6) (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.PSEUDOHEADER.LENGTH 12) (CONSTANTS \TCP.PSEUDOHEADER.LENGTH) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \16BIT.COMPLEMENT MACRO ((X) (LOGXOR X (MASK.1'S 0 16] [PUTPROPS \16BIT.1C.PLUS MACRO ((X Y) (* compute the one's complement sum of X and Y without creating FIXP boxes --  the sum modulo |2^16| plus an end-around carry) (PROG ((DELTA (IDIFFERENCE MAX.SMALLP Y))) (RETURN (if (ILEQ X DELTA) then (IPLUS X Y) else (IDIFFERENCE X DELTA] ) ) (/DECLAREDATATYPE 'TCP.PSEUDOHEADER '(FIXP FIXP BYTE BYTE WORD) '((TCP.PSEUDOHEADER 0 FIXP) (TCP.PSEUDOHEADER 2 FIXP) (TCP.PSEUDOHEADER 4 (BITS . 7)) (TCP.PSEUDOHEADER 4 (BITS . 135)) (TCP.PSEUDOHEADER 5 (BITS . 15))) '6) (RPAQ? \TCP.PSEUDOHEADER NIL) (* ;; "this variable controls whether checksums are performed on incoming segments") (RPAQ? \TCP.CHECKSUMS.ON NIL) (* ;; "checksum routines") (DEFINEQ (\COMPUTE.CHECKSUM (LAMBDA (BASE LENGTH DONTCOMPLEMENTFLG) (* ecc "25-May-84 18:47") (* TCP/IP protocol checksum is the 16-bit 1's complement of the 1's complement sum of the 16-bit words) (PROG ((CHECKSUM 0) (N (SUB1 (LRSH LENGTH 1)))) (for I from 0 to N do (SETQ CHECKSUM (\16BIT.1C.PLUS CHECKSUM (\GETBASE BASE I)))) (if (ODDP LENGTH) then (* if LENGTH is odd, the last byte must be padded on the right by a zero byte) (SETQ CHECKSUM (\16BIT.1C.PLUS CHECKSUM (LLSH (\GETBASEBYTE BASE (SUB1 LENGTH)) 8)))) (RETURN (if DONTCOMPLEMENTFLG then (* if DONTCOMPLEMENTFLG is non-NIL just return the 1's complement sum) CHECKSUM else (\16BIT.COMPLEMENT CHECKSUM))))) ) (\TCP.CHECKSUM.INCOMING (LAMBDA (SEGMENT) (* ecc "16-May-84 11:53") (* computes the TCP checksum and returns T or NIL depending on whether it matches the checksum in the header) (PROG ((LENGTH (IPLUS (fetch TCP.HEADER.LENGTH of SEGMENT) (\TCP.DATA.LENGTH SEGMENT))) (SEGMENT.CHECKSUM (fetch TCP.CHECKSUM of SEGMENT)) CHECKSUM OK) (WITH.FAST.MONITOR \TCP.LOCK (* need to lock this because we're using \TCP.PSEUDOHEADER) (replace PH.SRC.ADDR of \TCP.PSEUDOHEADER with (fetch TCP.SRC.ADDR of SEGMENT)) (replace PH.DST.ADDR of \TCP.PSEUDOHEADER with (fetch TCP.DST.ADDR of SEGMENT)) (replace PH.LENGTH of \TCP.PSEUDOHEADER with LENGTH) (replace TCP.CHECKSUM of SEGMENT with 0) (* checksum field must be 0 while we are computing checksum) (SETQ CHECKSUM (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM \TCP.PSEUDOHEADER \TCP.PSEUDOHEADER.LENGTH T) (\COMPUTE.CHECKSUM (fetch TCPHEADER of SEGMENT) LENGTH T))))) (SETQ OK (EQ CHECKSUM SEGMENT.CHECKSUM)) (if (AND (NOT OK) (MEMB (QUOTE CHECKSUM) TCPTRACEFLG)) then (printout TCPTRACEFILE .TAB0 0 "[bad checksum " CHECKSUM "]" T)) (RETURN OK))) ) (\TCP.CHECKSUM.OUTGOING (LAMBDA (TCB SEGMENT) (* ecc "16-May-84 11:53") (* compute checksum and place in header) (PROG ((LENGTH (IPLUS (fetch TCP.HEADER.LENGTH of SEGMENT) (\TCP.DATA.LENGTH SEGMENT))) (PH (if TCB then (fetch TCB.PH of TCB) else \TCP.PSEUDOHEADER))) (WITH.FAST.MONITOR \TCP.LOCK (* need to lock this in case we're using \TCP.PSEUDOHEADER) (replace PH.SRC.ADDR of PH with (fetch TCP.SRC.ADDR of SEGMENT)) (replace PH.DST.ADDR of PH with (fetch TCP.DST.ADDR of SEGMENT)) (replace PH.LENGTH of PH with LENGTH) (replace TCP.CHECKSUM of SEGMENT with 0) (* checksum field must be 0 while we are computing checksum) (replace TCP.CHECKSUM of SEGMENT with (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM PH \TCP.PSEUDOHEADER.LENGTH T) (\COMPUTE.CHECKSUM (fetch TCPHEADER of SEGMENT) LENGTH T))))))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.INITIAL.RTO 1000) (CONSTANTS \TCP.INITIAL.RTO) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.UBOUND 5000) (RPAQQ \TCP.LBOUND 1000) (CONSTANTS (\TCP.UBOUND 5000) (\TCP.LBOUND 1000)) ) ) (* ;; "maximum segment lifetime") (RPAQ? \TCP.MSL 5000) (RPAQ? \TCP.DEFAULT.USER.TIMEOUT 60000) (RPAQ? \TCP.DEFAULT.RECEIVE.WINDOW 4096) (RPAQ? \TCP.DEVICE NIL) (* ;; "TCP protocol routines") (DEFINEQ (\TCP.ACK# (LAMBDA (TCB) (* ejs%: " 7-Jun-85 13:18") (* * Returns the byte id for the next ACK) (* (LET* ((STREAM (fetch TCB.RCV.STREAM of TCB)) (BUFFER (fetch TCB.RCV.SEGMENT of TCB))) (COND (BUFFER (IPLUS (fetch TCP.SEQ of BUFFER) (fetch (STREAM COFFSET) of STREAM))) ((SETQ BUFFER (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (IMIN (fetch TCB.RCV.NXT of TCB) (fetch TCP.SEQ of BUFFER))) (T (fetch TCB.RCV.NXT of TCB))))) (fetch TCB.RCV.NXT of TCB)) ) (\TCP.PACKET.FILTER (LAMBDA (SEGMENT PROTOCOL) (* ecc " 7-May-84 17:27") (* packet filter used by IP code to dispatch packets by protocol) (SELECTC PROTOCOL (\TCP.PROTOCOL (ERSETQ (\TCP.INPUT SEGMENT)) T) (\ICMP.PROTOCOL (ERSETQ (\TCP.HANDLE.ICMP SEGMENT)) T) NIL)) ) (\TCP.SETUP.SEGMENT (LAMBDA (SRC.HOST SRC.PORT DST.HOST DST.PORT) (* ejs%: " 1-Jan-01 10:28") (* allocate a new TCP segment and set up its header) (PROG ((SEGMENT (\IP.SETUPIP (\ALLOCATE.ETHERPACKET) DST.HOST NIL \TCP.MASTER.SOCKET (QUOTE FREE)))) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) \TCP.HEADER.LENGTH) (replace TCP.SRC.PORT of SEGMENT with SRC.PORT) (replace TCP.DST.PORT of SEGMENT with DST.PORT) (replace TCP.DATA.OFFSET of SEGMENT with \TCP.MIN.DATA.OFFSET) (replace TCP.MBZ of SEGMENT with 0) (RETURN SEGMENT))) ) (\TCP.RELEASE.SEGMENT (LAMBDA (SEGMENT) (* ecc " 7-May-84 17:28") (* release a TCP segment -- it had better not be on anyone's queue) (CHECK (OR (NULL (fetch QLINK of SEGMENT)) (SHOULDNT "releasing queued segment"))) (\RELEASE.ETHERPACKET SEGMENT)) ) (\TCP.CONNECTION (LAMBDA (DST.HOST DST.PORT SRC.PORT MODE OPTIONS) (* ; "Edited 23-May-88 19:14 by Snow") (* ;; "open a TCP connection and return the TCB or NIL if the connection fails") (PROG (SPECIFIED TCB ISS TCP.PROCESS) (SELECTQ MODE (ACTIVE) (PASSIVE) (ERROR "TCP open mode must be ACTIVE or PASSIVE")) (if (NULL DST.HOST) then (SETQ DST.HOST 0)) (if (NULL DST.PORT) then (SETQ DST.PORT 0)) (if (NULL SRC.PORT) then (SETQ SRC.PORT 0)) (SETQ SPECIFIED (NOT (OR (ZEROP DST.HOST) (ZEROP DST.PORT)))) (if (AND (EQ MODE (QUOTE ACTIVE)) (NOT SPECIFIED)) then (ERROR "foreign socket unspecified")) (* ;; "Check for conflict with existing connections. ACTIVE open only conflicts with other fully specified connections. PASSIVE open conflicts with fully specified connections if the open is fully specifed, and with partially specified connections if the open is partially specified") (if (SETQ TCB (OR (AND (OR (EQ MODE (QUOTE ACTIVE)) SPECIFIED) (\TCP.LOOKUP.TCB DST.HOST DST.PORT SRC.PORT T)) (AND (EQ MODE (QUOTE PASSIVE)) (NOT SPECIFIED) (SETQ TCB (\TCP.LOOKUP.TCB DST.HOST DST.PORT SRC.PORT NIL)) (OR (ZEROP (fetch TCB.DST.HOST of TCB)) (ZEROP (fetch TCB.DST.PORT of TCB))) TCB))) then (COND ((type? TCP.CONTROL.BLOCK TCB) (COND ((FMEMB (fetch TCB.STATE of TCB) (QUOTE (CLOSED CLOSE.WAIT TIME.WAIT FIN.WAIT.1 FIN.WAIT.2))) (\TCP.DELETE.TCB TCB)) (T (ERROR "TCP connection already exists")))) (T (ERROR "TCP connection already exists")))) (SETQ TCB (\TCP.CREATE.TCB DST.HOST DST.PORT SRC.PORT MODE (OR (LISTGET OPTIONS (QUOTE MAXSEG)) \TCP.DEFAULT.MAXSEG))) (replace TCB.NO.IDLE.PROBING of TCB with (LISTGET OPTIONS (QUOTE NO.IDLE.PROBING))) (SELECTQ MODE (ACTIVE (WITH.MONITOR \TCP.LOCK (SETQ ISS (\TCP.SELECT.ISS)) (replace TCB.ISS of TCB with ISS)) (\TCP.TEMPLATE TCB (COND ((LISTGET OPTIONS (QUOTE MAXSEG)) OPTIONS) (T (APPEND OPTIONS (BQUOTE (MAXSEG %, \TCP.DEFAULT.MAXSEG)))))) (replace TCB.SND.UNA of TCB with ISS) (replace TCB.SND.NXT of TCB with ISS) (replace TCB.SND.UP of TCB with ISS) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.SENT)) (replace TCB.STATE of TCB with (QUOTE SYN.SENT)) (SETQ TCP.PROCESS (ADD.PROCESS (BQUOTE (\TCP.PROCESS %, TCB)) (QUOTE NAME) (QUOTE TCP) (QUOTE WHENCLOSEDFN) (LISTGET OPTIONS (QUOTE WHENCLOSEDFN)))) (* ; "initiate the three-way handshake to establish the connection") (\TCP.FLUSH (fetch TCB.SND.STREAM of TCB) \TCP.CTRL.SYN) (* ; "wait until established") (WITH.MONITOR (fetch TCB.LOCK of TCB) (RESETLST (RESETSAVE NIL (BQUOTE (AND RESETSTATE (DEL.PROCESS %, TCP.PROCESS)))) (until (NEQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB)))))) (PASSIVE (\TCP.TRACE.TRANSITION TCB (QUOTE LISTEN)) (replace TCB.STATE of TCB with (QUOTE LISTEN)) (SETQ TCP.PROCESS (ADD.PROCESS (BQUOTE (\TCP.PROCESS %, TCB)) (QUOTE NAME) (QUOTE TCP) (QUOTE WHENCLOSEDFN) (LISTGET OPTIONS (QUOTE WHENCLOSEDFN)))) (* ; "wait until established") (WITH.MONITOR (fetch TCB.LOCK of TCB) (RESETLST (RESETSAVE NIL (BQUOTE (AND RESETSTATE (DEL.PROCESS %, TCP.PROCESS)))) (until (NEQ (fetch TCB.STATE of TCB) (QUOTE LISTEN)) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB)))))) (SHOULDNT)) (RETURN (if (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) then TCB else NIL)))) ) (\TCP.FIX.INCOMING.SEGMENT (LAMBDA (SEGMENT FLAGS) (* ecc "16-May-84 11:56") (PROG NIL (if (AND (BITTEST FLAGS \TCP.CTRL.SYN) (BITTEST FLAGS \TCP.CTRL.FIN)) then (RETURN NIL)) (* calculate the length of the segment data and place it in a fixed position in the header for fast access -- note that the TCP.DATA.LENGTH field isn't a true part of the TCP header; it overlays the IP level checksum which is no longer needed) (replace TCP.DATA.LENGTH of SEGMENT with (\TCP.DATA.LENGTH SEGMENT)) (* return T or NIL depending on whether checksum is correct) (RETURN (OR (NOT \TCP.CHECKSUMS.ON) (\TCP.CHECKSUM.INCOMING SEGMENT))))) ) (\TCP.DATA.LENGTH (LAMBDA (SEGMENT) (* ejs%: "21-Jun-85 17:04") (* data length = total segment length - (IP header length + TCP header length)) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of SEGMENT) (IPLUS (UNFOLD (fetch (IP IPHEADERLENGTH) of SEGMENT) BYTESPERCELL) (UNFOLD (fetch TCP.DATA.OFFSET of SEGMENT) BYTESPERCELL)))) ) (\TCP.SYN.OR.FIN (LAMBDA (FLAGS NOERRORFLG) (* ecc " 1-May-84 17:10") (* SYN and FIN occupy sequence number space so we have to include them in the "length" of the segment) (SELECTC (LOGAND FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.FIN)) (0 0) (\TCP.CTRL.SYN 1) (\TCP.CTRL.FIN 1) (if NOERRORFLG then 0 else (SHOULDNT "both SYN and FIN")))) ) (\TCP.INPUT (LAMBDA (SEGMENT TCB) (* ejs%: "20-Jun-85 13:06") (* handle an incoming TCP segment -- pages |65-76| of RFC 793) (PROG ((SEQ (fetch TCP.SEQ of SEGMENT)) (ACK (fetch TCP.ACK of SEGMENT)) (FLAGS (fetch TCP.CTRL of SEGMENT)) UNA QUEUEDFLG) (if (NOT (\TCP.INPUT.INITIAL TCB SEGMENT SEQ ACK FLAGS)) then (\TCP.RELEASE.SEGMENT SEGMENT) (RETURN)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (PROG NIL (* handle unsynchronized states) (if (NOT (\TCP.INPUT.UNSYNC TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (* first check sequence number) (if (NOT (\TCP.CHECK.WINDOW TCB SEGMENT FLAGS)) then (GO DROPIT)) (* second check the RST bit) (if (NOT (\TCP.CHECK.RESET TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (* third check security and precedence) (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (GO DROPIT)) (* fourth check the SYN bit) (if (NOT (\TCP.CHECK.NO.SYN TCB SEGMENT FLAGS)) then (GO DROPIT)) (if (NOT (\TCP.CHECK.OPTIONS TCB SEGMENT FLAGS)) then (GO DROPIT)) (* fifth check the ACK field) (if (NOT (\TCP.CHECK.ACK TCB SEGMENT FLAGS)) then (GO DROPIT)) (if (EQ (fetch TCB.STATE of TCB) (QUOTE SYN.RECEIVED)) then (if (AND (\32BIT.LEQ (fetch TCB.SND.UNA of TCB) ACK) (\32BIT.LEQ ACK (fetch TCB.SND.NXT of TCB))) then (* our SYN has been acked) (\TCP.TRACE.TRANSITION TCB (QUOTE ESTABLISHED)) (replace TCB.STATE of TCB with (QUOTE ESTABLISHED)) (replace TCB.DST.HOST of TCB with (fetch (TCPSEGMENT TCP.SRC.ADDR) of SEGMENT)) (replace TCB.DST.PORT of TCB with (fetch (TCPSEGMENT TCP.SRC.PORT) of SEGMENT)) (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB)) (* continue processing in ESTABLISHED state) else (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST) (GO DROPIT))) (if (NOT (\TCP.HANDLE.ACK TCB SEGMENT SEQ ACK FLAGS)) then (GO DROPIT)) (SELECTQ (fetch TCB.STATE of TCB) (FIN.WAIT.1 (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.TRACE.TRANSITION TCB (QUOTE FIN.WAIT.2)) (replace TCB.STATE of TCB with (QUOTE FIN.WAIT.2)) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)))) ((ESTABLISHED FIN.WAIT.2 CLOSE.WAIT) NIL) (CLOSING (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.START.TIME.WAIT TCB) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) else (GO DROPIT))) (LAST.ACK (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED)) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) (RETURN) else (GO DROPIT))) (TIME.WAIT (\TCP.SEND.ACK TCB) (GO DROPIT)) (SHOULDNT)) (* sixth check the URG bit) (\TCP.HANDLE.URG TCB SEGMENT SEQ ACK FLAGS) (* seventh process the segment text) (SELECTQ (fetch TCB.STATE of TCB) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (SETQ QUEUEDFLG (\TCP.QUEUE.INPUT TCB SEGMENT SEQ))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT)) (SHOULDNT)) (* eighth check the FIN bit) (\TCP.HANDLE.FIN TCB SEGMENT SEQ ACK FLAGS) (if QUEUEDFLG then (RETURN)) DROPIT (\TCP.RELEASE.SEGMENT SEGMENT))))) ) (\TCP.INPUT.INITIAL (LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 17:27") (* handle segment for non-existent TCB -- page 65 of RFC 793) (PROG NIL (\TCP.TRACE.SEGMENT (QUOTE RECV) SEGMENT) (if (NOT (\TCP.FIX.INCOMING.SEGMENT SEGMENT FLAGS)) then (* bad checksum) (RETURN NIL)) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED))) then (* an incoming segment not containing a RST causes a RST to be sent in response) (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[no such TCP connection]")) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (* send a RST) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (\TCP.SEND.RESET SEGMENT ACK) else (\TCP.SEND.RESET SEGMENT 0 (IPLUS SEQ (fetch TCP.DATA.LENGTH of SEGMENT) (\TCP.SYN.OR.FIN FLAGS))))) (RETURN NIL)) (RETURN T))) ) (\TCP.INPUT.UNSYNC (LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "21-Mar-86 20:03") (* handle segment for TCB in LISTEN or SYN.SENT state -- pages |65-68| of RFC 793) (SELECTQ (fetch TCB.STATE of TCB) (LISTEN (\TCP.INPUT.LISTEN TCB SEGMENT SEQ ACK FLAGS) NIL) (SYN.SENT (\TCP.INPUT.SYN.SENT TCB SEGMENT SEQ ACK FLAGS) (\TCP.CHECK.OPTIONS TCB SEGMENT FLAGS) NIL) T)) ) (\TCP.INPUT.LISTEN (LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "22-Jun-85 03:14") (* handle segment for TCB in LISTEN state -- pages |65-66| of RFC 793) (PROG (ISS) (* first check for a RST) (if (BITTEST FLAGS \TCP.CTRL.RST) then (RETURN NIL)) (* second check for an ACK) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (* any acknowledgment is bad if it arrives on a connection still in the LISTEN state) (\TCP.SEND.RESET SEGMENT ACK) (RETURN NIL)) (* third check for a SYN) (if (BITTEST FLAGS \TCP.CTRL.SYN) then (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (RETURN NIL)) (replace TCB.RCV.NXT of TCB with (ADD1 SEQ)) (replace TCB.IRS of TCB with SEQ) (SETQ ISS (\TCP.SELECT.ISS)) (replace TCB.ISS of TCB with ISS) (replace TCB.SND.NXT of TCB with ISS) (replace TCB.SND.UNA of TCB with ISS) (replace TCB.SND.UP of TCB with ISS) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.RECEIVED)) (replace TCB.STATE of TCB with (QUOTE SYN.RECEIVED)) (* fill in foreign socket in case it was only partially specified) (replace TCB.DST.HOST of TCB with (fetch TCP.SRC.ADDR of SEGMENT)) (replace TCB.DST.PORT of TCB with (fetch TCP.SRC.PORT of SEGMENT)) (\TCP.TEMPLATE TCB) (* send a SYN, ACK segment using \TCP.FLUSH because SYN occupies sequence number space) (\TCP.FLUSH (fetch TCB.SND.STREAM of TCB) \TCP.CTRL.SYN) (* NOTE%: we never queue data that arrives in a SYN segment, we just ACK the SYN and require the data to be retransmitted)) (RETURN NIL))) ) (\TCP.INPUT.SYN.SENT (LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:13") (* handle segment for TCB in SYN.SENT state -- pages |66-68| of RFC 793) (PROG NIL (* first check the ACK bit) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (if (OR (\32BIT.LEQ ACK (fetch TCB.ISS of TCB)) (\32BIT.GT ACK (fetch TCB.SND.NXT of TCB))) then (* ACK is unacceptable) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST)) (RETURN NIL))) (* second check the RST bit) (if (BITTEST FLAGS \TCP.CTRL.RST) then (if (BITTEST FLAGS \TCP.CTRL.ACK) then (* if the ACK was acceptable then signal the user) (\TCP.CONNECTION.DROPPED TCB "reset")) (RETURN NIL)) (* third check the security and precedence) (if (NOT (\TCP.CHECK.SECURITY TCB SEGMENT FLAGS)) then (RETURN NIL)) (* fourth check the SYN bit) (if (BITTEST FLAGS \TCP.CTRL.SYN) then (replace TCB.RCV.NXT of TCB with (ADD1 SEQ)) (replace TCB.IRS of TCB with SEQ) (if (AND (BITTEST FLAGS \TCP.CTRL.ACK) (\32BIT.GEQ ACK (fetch TCB.SND.UNA of TCB))) then (* new ACK information) (replace TCB.SND.UNA of TCB with ACK)) (replace TCP.CTRL of SEGMENT with (SETQ FLAGS (BITCLEAR FLAGS \TCP.CTRL.SYN))) (if (\32BIT.GT (fetch TCB.SND.UNA of TCB) (fetch TCB.ISS of TCB)) then (* our SYN has been acked) (\TCP.TRACE.TRANSITION TCB (QUOTE ESTABLISHED)) (replace TCB.STATE of TCB with (QUOTE ESTABLISHED)) (* send an ACK segment) (\TCP.SEND.ACK TCB (QUOTE NOW)) (NOTIFY.EVENT (fetch TCB.ESTABLISHED of TCB)) else (* we can just let our original SYN segment be retransmitted) (\TCP.TRACE.TRANSITION TCB (QUOTE SYN.RECEIVED)) (replace TCB.STATE of TCB with (QUOTE SYN.RECEIVED)) (* send an ACK segment) (\TCP.SEND.ACK TCB (QUOTE NOW))) (* NOTE%: we never queue data that arrives in a SYN segment, we just ACK the SYN and require the data to be retransmitted)) (* drop the segment and return) (RETURN NIL))) ) (\TCP.CHECK.WINDOW (LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 16:29") (* check segment length against receive window -- page 69 of RFC 793) (PROG ((LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (SEQ (fetch TCP.SEQ of SEGMENT)) (RCV.NXT (fetch TCB.RCV.NXT of TCB)) (WND (fetch TCB.RCV.WND of TCB)) TOP) (SETQ TOP (IPLUS SEQ LEN (\TCP.SYN.OR.FIN FLAGS))) (if (ZEROP LEN) then (if (ZEROP WND) then (if (\32BIT.EQ SEQ RCV.NXT) then (RETURN T)) else (if (AND (\32BIT.LEQ RCV.NXT SEQ) (\32BIT.LT SEQ (IPLUS RCV.NXT WND))) then (RETURN T))) else (if (NOT (ZEROP WND)) then (if (OR (AND (\32BIT.LEQ RCV.NXT SEQ) (\32BIT.LT SEQ (IPLUS RCV.NXT WND))) (AND (\32BIT.LT RCV.NXT TOP) (\32BIT.LEQ TOP (IPLUS RCV.NXT WND)))) then (RETURN T)))) (if (NOT (BITTEST FLAGS \TCP.CTRL.RST)) then (* send an ACK in reply) (\TCP.SEND.ACK TCB (QUOTE NOW))) (RETURN NIL))) ) (\TCP.CHECK.RESET (LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:07") (* check the RST bit -- page 70 of RFC 793) (PROG NIL (if (BITTEST FLAGS \TCP.CTRL.RST) then (SELECTQ (fetch TCB.STATE of TCB) (SYN.RECEIVED (if (EQ (fetch TCB.MODE of TCB) (QUOTE PASSIVE)) then (\TCP.TRACE.TRANSITION TCB (QUOTE LISTEN)) (replace TCB.STATE of TCB with (QUOTE LISTEN)) else (\TCP.CONNECTION.DROPPED TCB "refused")) (\FLUSH.PACKET.QUEUE (fetch TCB.REXMT.QUEUE of TCB)) (\TCP.SEND.CONTROL TCB ACK NIL \TCP.CTRL.RST)) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2 CLOSE.WAIT) (\TCP.CONNECTION.DROPPED TCB "reset")) ((CLOSING LAST.ACK TIME.WAIT) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED))) (SHOULDNT)) (RETURN NIL) else (RETURN T)))) ) (\TCP.CHECK.SECURITY (LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:06") (* returns T or NIL depending on whether security and precedence are OK; sends RST if necessary) (* not implemented) T) ) (\TCP.CHECK.NO.SYN (LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:07") (* check the SYN bit -- page 71 of RFC 793) (PROG NIL (CHECK (OR (NOT (BITTEST FLAGS \TCP.CTRL.RST)) (SHOULDNT "RST bit set"))) (if (NOT (BITTEST FLAGS \TCP.CTRL.SYN)) then (RETURN T)) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (\TCP.SEND.CONTROL TCB (fetch TCP.ACK of SEGMENT) NIL \TCP.CTRL.RST) else (\TCP.SEND.CONTROL TCB 0 (IPLUS (fetch TCP.ACK of SEGMENT) (fetch TCP.DATA.LENGTH of SEGMENT) 1) (LOGOR \TCP.CTRL.ACK \TCP.CTRL.RST))) (\TCP.CONNECTION.DROPPED TCB "reset") (RETURN NIL))) ) (\TCP.CHECK.ACK (LAMBDA (TCB SEGMENT FLAGS) (* ecc "16-May-84 12:08") (* check the ACK field -- page 72 of RFC 793) (PROG NIL (CHECK (OR (NOT (BITTEST FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.RST))) (SHOULDNT "SYN or RST bit set"))) (RETURN (BITTEST FLAGS \TCP.CTRL.ACK)))) ) (\TCP.HANDLE.ACK (LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "22-Jun-85 00:35") (* ACK processing -- pages |72-73| of RFC 793) (PROG (EVENT) (if (\32BIT.GT ACK (fetch TCB.SND.NXT of TCB)) then (* this segment acks something we haven't sent yet) (\TCP.SEND.ACK TCB (QUOTE NOW)) (RETURN NIL)) (if (AND (fetch TCB.RTFLG of TCB) (\32BIT.GT ACK (fetch TCB.RTSEQ of TCB))) then (* calculate smoothed round trip time) (replace TCB.RTFLG of TCB with NIL) (replace TCB.SRTT of TCB with (FOLDLO (PLUS (ITIMES 7 (fetch TCB.SRTT of TCB)) (CLOCKDIFFERENCE (fetch TCB.RTTIMER of TCB))) 8)) (replace TCB.RTTIMER of TCB with (SETUPTIMER 0 (fetch TCB.RTTIMER of TCB))) (replace TCB.RTO of TCB with (IMIN \TCP.UBOUND (IMAX \TCP.LBOUND (FOLDLO (ITIMES 3 (fetch TCB.SRTT of TCB)) 2))))) (if (\32BIT.GT ACK (fetch TCB.SND.UNA of TCB)) then (* new ACK information) (replace TCB.SND.UNA of TCB with ACK) (SETQ EVENT T)) (if (OR (\32BIT.GT SEQ (fetch TCB.SND.WL1 of TCB)) (AND (\32BIT.EQ SEQ (fetch TCB.SND.WL1 of TCB)) (\32BIT.GEQ ACK (fetch TCB.SND.WL2 of TCB)))) then (* update send window) (replace TCB.SND.WND of TCB with (fetch TCP.WINDOW of SEGMENT)) (replace TCB.SND.WL1 of TCB with SEQ) (replace TCB.SND.WL2 of TCB with ACK) (SETQ EVENT T)) (if EVENT then (NOTIFY.EVENT (fetch TCB.SND.EVENT of TCB))) (RETURN T))) ) (\TCP.HANDLE.URG (LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ecc "16-May-84 12:10") (* check the URG bit -- pages |73-74| of RFC 793) (PROG (UP) (if (BITTEST FLAGS \TCP.CTRL.URG) then (SELECTQ (fetch TCB.STATE of TCB) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (SETQ UP (IPLUS SEQ (fetch TCP.URG.PTR of SEGMENT))) (if (\32BIT.GT UP (fetch TCB.RCV.UP of TCB)) then (replace TCB.RCV.UP of TCB with UP) (if (\32BIT.GT UP (fetch TCB.RCV.NXT of TCB)) then (* urgent pointer is in advance of the data consumed) (\TCP.SIGNAL.URGENT.DATA TCB)))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT) NIL) (SHOULDNT))))) ) (\TCP.QUEUE.INPUT (LAMBDA (TCB SEGMENT SEQ) (* ejs%: "18-Dec-86 17:39") (* Put the segment in its proper position in the input queue according to its sequence number range. Returns T if the segment was queued, NIL if it was a duplicate. Segments are queued by increasing left endpoint of their sequence number range. If the entire sequence number range has been seen or is covered by segments already in the queue, the segment is a duplicate. Otherwise, it covers some gap in the queue, so it is placed in its proper position. Note that a later segment that covers gaps on both sides will also be queued, resulting in duplicates in the queue. Therefore \TCP.GET.SEGMENT must be prepared to skip over duplicates.) (CHECK (OR (NULL (fetch QLINK of SEGMENT)) (SHOULDNT "input segment already queued"))) (CHECK (\TCP.CHECK.INPUT.QUEUE TCB)) (UNINTERRUPTABLY (PROG ((QUEUE (fetch TCB.INPUT.QUEUE of TCB)) (RCV.NXT (fetch TCB.RCV.NXT of TCB)) (LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (FLAGS (fetch TCP.CTRL of SEGMENT)) TOP CURRENT CURSEQ NEXT) (if (EQ 0 LEN) then (* this segment has no data) (GO DROPITANDPROBE)) (SETQ TOP (IPLUS SEQ LEN)) (if (\32BIT.LEQ TOP RCV.NXT) then (* this segment is a duplicate) (GO DROPITANDPROBE)) (SETQ CURRENT (fetch SYSQUEUEHEAD of QUEUE)) (SETQ NEXT (fetch SYSQUEUETAIL of QUEUE)) (if (OR (NULL CURRENT) (\32BIT.GEQ SEQ (fetch TCP.SEQ of NEXT))) then (* the segment goes at the tail of the queue -- we check this first since this is the expected case) (\ENQUEUE QUEUE SEGMENT) elseif (\32BIT.LT SEQ (SETQ CURSEQ (fetch TCP.SEQ of CURRENT))) then (* the segment goes at the head of the queue) (replace QLINK of SEGMENT with CURRENT) (replace SYSQUEUEHEAD of QUEUE with SEGMENT) else (* * Search for this segment's proper position in the queue. The invariant upon entering this loop is%: segment.seq >= current.seq) (do (if (\32BIT.LEQ TOP (IPLUS CURSEQ (fetch TCP.DATA.LENGTH of CURRENT))) then (* * segment.seq <= current.seq + current.length. The packet is totally subsumed by a previously received packet, and thus, is a duplicate and is dropped) (GO DROPITANDPROBE)) (SETQ NEXT (fetch QLINK of CURRENT)) (SETQ CURSEQ (fetch TCP.SEQ of NEXT)) (if (\32BIT.LT SEQ CURSEQ) then (* * current.seq <= segment.seq < next.seq. Insert the segment between current and next) (replace QLINK of SEGMENT with NEXT) (replace QLINK of CURRENT with SEGMENT) (RETURN)) (SETQ CURRENT NEXT))) (* * Note that we have a zero window allocation at this point. When we free up the window (in \TCP.GET.SEGMENT) %, we'll know to send a gratuitous ACK to our partner to let it know the window's once again open.) (replace TCB.RCV.WND of TCB with (IMAX 0 (IDIFFERENCE (fetch TCB.RCV.WND of TCB) LEN))) (replace TCB.LAST.SENT.RCV.WND of TCB with (IMAX 0 (IDIFFERENCE (fetch TCB.LAST.SENT.RCV.WND of TCB) LEN))) (COND ((OR (EQ 0 (fetch TCB.LAST.SENT.RCV.WND of TCB)) (EQ 0 (fetch TCB.RCV.WND of TCB))) (replace TCB.SENT.ZERO of TCB with T))) (while (AND (\32BIT.LEQ SEQ RCV.NXT) (\32BIT.LT RCV.NXT TOP)) do (* advance RCV.NXT) (replace TCB.RCV.NXT of TCB with (SETQ RCV.NXT TOP)) (if (SETQ SEGMENT (fetch QLINK of SEGMENT)) then (SETQ TOP (IPLUS (SETQ SEQ (fetch TCP.SEQ of SEGMENT)) (fetch TCP.DATA.LENGTH of SEGMENT))))) (if (BITTEST FLAGS \TCP.CTRL.PSH) then (\TCP.SEND.ACK TCB (QUOTE NOW)) else (\TCP.SEND.ACK TCB)) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB)) (RETURN T) DROPITANDPROBE (* * Here when we think we should let the other side know immediately about our condition (e.g. a duplicate packet was received)) (\TCP.SEND.ACK TCB (QUOTE NOW)) DROPIT (* * Here when we have nothing to do, but it's not worth informing our TCP partner) (RETURN NIL)))) ) (\TCP.HANDLE.FIN (LAMBDA (TCB SEGMENT SEQ ACK FLAGS) (* ejs%: "11-Aug-86 22:29") (* check the FIN bit -- pages |75-76| of RFC 793) (PROG (TOP) (if (BITTEST FLAGS \TCP.CTRL.FIN) then (SETQ TOP (IPLUS SEQ (fetch TCP.DATA.LENGTH of SEGMENT))) (* check whether we've received all the data before the FIN) (if (\32BIT.GEQ (fetch TCB.RCV.NXT of TCB) TOP) then (if (\32BIT.EQ (fetch TCB.RCV.NXT of TCB) TOP) then (* advance RCV.NXT over the FIN) (add (fetch TCB.RCV.NXT of TCB) 1)) (SELECTQ (fetch TCB.STATE of TCB) ((SYN.RECEIVED ESTABLISHED) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSE.WAIT)) (replace TCB.STATE of TCB with (QUOTE CLOSE.WAIT))) (FIN.WAIT.1 (if (\TCP.OUR.FIN.IS.ACKED TCB) then (\TCP.START.TIME.WAIT TCB) (NOTIFY.EVENT (fetch TCB.FINACKED.EVENT of TCB)) else (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSING)) (replace TCB.STATE of TCB with (QUOTE CLOSING)))) (FIN.WAIT.2 (\TCP.START.TIME.WAIT TCB)) ((CLOSE.WAIT CLOSING LAST.ACK) NIL) (TIME.WAIT (\TCP.START.TIME.WAIT TCB)) (SHOULDNT)) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB))) (* acknowledge the FIN) (\TCP.SEND.ACK TCB (QUOTE NOW))))) ) (\TCP.OUR.FIN.IS.ACKED (LAMBDA (TCB) (* ecc "16-May-84 12:15") (* check whether our FIN's sequence number (recorded in the TCB.FINSEQ field) has been acknowledged) (\32BIT.GEQ (fetch TCB.SND.UNA of TCB) (OR (fetch TCB.FINSEQ of TCB) (SHOULDNT "FIN not sent")))) ) (\TCP.SIGNAL.URGENT.DATA (LAMBDA (TCB) (* ecc " 7-May-84 12:19") (NOTIFY.EVENT (fetch TCB.URGENT.EVENT of TCB)) (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[Urgent TCP data has arrived]" T))) ) (\TCP.PROCESS (LAMBDA (TCB) (* ejs%: "11-Aug-86 21:57") (* process to handle retransmission and timeouts for TCP connection) (RESETSAVE NIL (LIST (FUNCTION \TCP.DELETE.TCB) TCB)) (PROCESSPROP (THIS.PROCESS) (QUOTE INFOHOOK) (FUNCTION (LAMBDA NIL (PPTCB TCB)))) (replace TCB.PROCESS of TCB with (THIS.PROCESS)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (bind SEGMENT PACKETQUEUE REXMTQUEUE EVENT (IPSOCKET _ (fetch TCB.IPSOCKET of TCB)) first (SETQ PACKETQUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) (SETQ REXMTQUEUE (fetch TCB.REXMT.QUEUE of TCB)) (SETQ EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET)) while (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) do (COND ((AND (fetch TCB.RTFLG of TCB) (fetch TCB.PROBE.TIMER of TCB) (IGREATERP (CLOCKDIFFERENCE (fetch TCB.RTTIMER of TCB)) (fetch TCB.USER.TIMEOUT of TCB))) (* timeout has expired without other end responding) (\TCP.CONNECTION.DROPPED TCB "not responding")) ((AND (EQ (fetch TCB.STATE of TCB) (QUOTE TIME.WAIT)) (TIMEREXPIRED? (fetch TCB.2MSL.TIMER of TCB))) (* 2MSL has expired) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED))) ((\TCP.RETRANSMIT TCB) NIL) ((OR (EQ (fetch TCB.ACKFLG of TCB) (QUOTE NOW)) (AND (EQ (fetch TCB.STATE of TCB) (QUOTE ESTABLISHED)) (fetch TCB.PROBE.TIMER of TCB) (TIMEREXPIRED? (fetch TCB.PROBE.TIMER of TCB))) (AND (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) (\32BIT.GT (fetch TCP.SEQ of (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (fetch TCB.RCV.NXT of TCB)))) (* an ACK needs to be sent either because the protocol routines requested it or because we need to fill a gap in the input queue) (\TCP.SEND.CONTROL TCB (fetch TCB.SND.NXT of TCB) (\TCP.ACK# TCB) \TCP.CTRL.ACK)) ((AND (\32BIT.GT (fetch TCB.SND.NXT of TCB) (IPLUS (fetch TCB.SND.WL1 of TCB) (fetch TCB.SND.WND of TCB))) (fetch TCB.PROBE.TIMER of TCB) (TIMEREXPIRED? (fetch TCB.PROBE.TIMER of TCB))) (* a probe needs to be sent to open the window) (\TCP.SEND.CONTROL TCB (IPLUS (fetch TCB.SND.NXT of TCB) (fetch TCB.SND.WND of TCB)) (\TCP.ACK# TCB) \TCP.CTRL.ACK))) (COND ((SETQ SEGMENT (\DEQUEUE PACKETQUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1) (\TCP.INPUT SEGMENT TCB)) (T (COND ((EQ (COND ((OR (fetch TCB.OUTPUT.HELD of TCB) (fetch SYSQUEUEHEAD of REXMTQUEUE) (\32BIT.GT (fetch TCB.SND.NXT of TCB) (IPLUS (fetch TCB.SND.WL1 of TCB) (fetch TCB.SND.WND of TCB)))) (* Something on the retransmit queue. Be agressive.) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) EVENT (fetch TCB.RTO of TCB))) (T (* Nothing to do. Be lazy) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) EVENT (fetch TCB.PROBE.TIMER of TCB) (NOT (NULL (fetch TCB.PROBE.TIMER of TCB)))))) EVENT) (COND ((SETQ SEGMENT (\DEQUEUE PACKETQUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1) (\TCP.INPUT SEGMENT TCB)))))))))) ) (\TCP.TEMPLATE (LAMBDA (TCB OPTIONS) (* ejs%: "21-Jun-85 16:40") (* set up segment for sending control information and pseudo-header for checksumming) (LET ((SEGMENT (fetch TCB.TEMPLATE of TCB))) (if SEGMENT then (replace TCP.DST.ADDR of SEGMENT with (fetch TCB.DST.HOST of TCB)) (replace TCP.DST.PORT of SEGMENT with (fetch TCB.DST.PORT of TCB)) else (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCB.SRC.PORT of TCB) (fetch TCB.DST.HOST of TCB) (fetch TCB.DST.PORT of TCB)))) (if OPTIONS then (\TCP.SETUP.SEGMENT.OPTIONS SEGMENT OPTIONS)) (replace TCB.TEMPLATE of TCB with SEGMENT) (if (NULL (fetch TCB.PH of TCB)) then (replace TCB.PH of TCB with (create TCP.PSEUDOHEADER))) SEGMENT)) ) (\TCP.SETUP.SEGMENT.OPTIONS (LAMBDA (SEGMENT OPTIONS) (* ejs%: "28-Jul-86 13:31") (* * Add options to a freshly setup segment. OPTIONS is in PLIST format) (LET ((OPTIONSBASE (fetch TCP.OPTIONS of SEGMENT)) (OPTIONSOFFSET 0) DIDPLACEOPTION) (COND ((IGREATERP (fetch (IP IPTOTALLENGTH) of SEGMENT) (CONSTANT (IPLUS \TCP.HEADER.LENGTH \IPOVLEN))) (ERROR "Tried to add options to a segment with TCP data already in place" SEGMENT))) (for OPTIONVALUETAIL on OPTIONS by (CDDR OPTIONVALUETAIL) do (SELECTQ (CAR OPTIONVALUETAIL) (MAXSEG (LET ((VALUE (CADR OPTIONVALUETAIL))) (COND ((SMALLP VALUE) (\PUTBASEBYTE OPTIONSBASE OPTIONSOFFSET \TCPOPT.MAXSEG) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) 4) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) (LOGAND (MASK.1'S 0 BITSPERBYTE) (LRSH VALUE BITSPERBYTE))) (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) (LOGAND VALUE (MASK.1'S 0 BITSPERBYTE))) (SETQ DIDPLACEOPTION T))))) NIL)) (COND (DIDPLACEOPTION (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) \TCPOPT.END))) (until (EQ 0 (IMOD OPTIONSOFFSET 4)) do (\PUTBASEBYTE OPTIONSBASE (add OPTIONSOFFSET 1) \TCPOPT.END)) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) OPTIONSOFFSET) (add (fetch TCP.DATA.OFFSET of SEGMENT) (FOLDHI OPTIONSOFFSET BYTESPERCELL)))) ) (\TCP.SEND.CONTROL (LAMBDA (TCB SEQ ACK FLAGS) (* ejs%: "18-Dec-86 17:29") (* send a control segment with the specified sequence number and ACK information) (PROG ((SEGMENT (OR (fetch TCB.TEMPLATE of TCB) (\TCP.NEW.TEMPLATE TCB)))) (if (NULL FLAGS) then (SETQ FLAGS 0)) (CHECK (OR (NOT (BITTEST FLAGS (LOGOR \TCP.CTRL.SYN \TCP.CTRL.FIN))) (SHOULDNT "SYN or FIN"))) (while (fetch EPTRANSMITTING of SEGMENT) do (BLOCK)) (replace TCP.SEQ of SEGMENT with SEQ) (if ACK then (replace TCP.ACK of SEGMENT with ACK) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK)) else (replace TCP.ACK of SEGMENT with 0)) (replace TCP.CTRL of SEGMENT with FLAGS) (replace TCB.SENT.ZERO of TCB with (EQ 0 (replace TCP.WINDOW of SEGMENT with (replace TCB.LAST.SENT.RCV.WND of TCB with (fetch TCB.RCV.WND of TCB))))) (\TCP.SEND.SEGMENT TCB SEGMENT FLAGS) (\TCP.NEW.TEMPLATE TCB))) ) (\TCP.SEND.ACK (LAMBDA (TCB WHEN) (* ejs%: "17-Dec-86 16:43") (* set TCB.ACKFLG to tell the \TCP.PROCESS that an ACK needs to be sent -- NOW means send the ack immediately, LATER means delay in the hope that it can be piggybacked on an outgoing data segment) (COND ((EQ WHEN (QUOTE NOW)) (\TCP.SEND.CONTROL TCB (fetch TCB.SND.NXT of TCB) (\TCP.ACK# TCB) \TCP.CTRL.ACK)) (T (replace TCB.ACKFLG of TCB with (OR WHEN (QUOTE LATER)))))) ) (\TCP.SEND.RESET (LAMBDA (ORIG SEQ ACK FLAGS) (* ejs%: " 7-Jun-85 12:58") (* like \TCP.SEND.CONTROL but always sends RST and can be used without a TCB) (PROG (SEGMENT) (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCP.DST.PORT of ORIG) (fetch TCP.SRC.ADDR of ORIG) (fetch TCP.SRC.PORT of ORIG))) (replace TCP.SEQ of SEGMENT with SEQ) (if ACK then (replace TCP.ACK of SEGMENT with ACK) (OR FLAGS (SETQ FLAGS (LOGOR \TCP.CTRL.RST \TCP.CTRL.ACK))) else (replace TCP.ACK of SEGMENT with 0) (OR FLAGS (SETQ FLAGS \TCP.CTRL.RST))) (replace TCP.CTRL of SEGMENT with FLAGS) (replace TCP.WINDOW of SEGMENT with 0) (replace EPREQUEUE of SEGMENT with (QUOTE FREE)) (\TCP.SEND.SEGMENT NIL SEGMENT FLAGS))) ) (\TCP.FIX.OUTGOING.SEGMENT (LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "18-Dec-86 17:29") (* fill in control bits, ACK and window information, and start round trip timer) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (replace TCP.ACK of SEGMENT with (fetch TCB.RCV.NXT of TCB)) else (replace TCP.ACK of SEGMENT with 0)) (replace TCP.CTRL of SEGMENT with FLAGS) (* set control bits) (replace TCP.WINDOW of SEGMENT with (replace TCB.LAST.SENT.RCV.WND of TCB with (fetch TCB.RCV.WND of TCB))) (if (NULL (fetch TCB.RTFLG of TCB)) then (* time round trip response to this segment) (replace TCB.RTFLG of TCB with T) (replace TCB.RTSEQ of TCB with (fetch TCP.SEQ of SEGMENT)) (replace TCB.RTTIMER of TCB with (SETUPTIMER 0 (fetch TCB.RTTIMER of TCB))))) ) (\TCP.SEND.DATA (LAMBDA (TCB SEGMENT LENGTH FLAGS) (* wjy "13-Dec-85 14:30") (* * This function is used to send a TCP data segment for the first time. Subsequent retransmissions are done directly through \TCP.SEND.SEGMENT) (* * NOTE%: This function MUST be called with the TCB.LOCK already locked!) (PROG (SEQ TOP) (CHECK (OR (EQ LENGTH (\TCP.DATA.LENGTH SEGMENT)) (SHOULDNT "bad segment length"))) (CHECK (OR (ILEQ LENGTH (fetch TCB.MAXSEG of TCB)) (SHOULDNT "segment > max segment size"))) (if (NEQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) then (* ACK in all synchronized states) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK))) (SETQ SEQ (fetch TCB.SND.NXT of TCB)) (* assign sequence number) (if (fetch TCB.ACKFLG of TCB) then (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.ACK))) (SETQ TOP (IPLUS SEQ LENGTH (\TCP.SYN.OR.FIN FLAGS))) (CHECK (OR (\32BIT.GEQ TOP (fetch TCB.SND.NXT of TCB)) (SHOULDNT "bad sequence numbers"))) (replace TCP.SEQ of SEGMENT with SEQ) (if (BITTEST FLAGS \TCP.CTRL.URG) then (replace TCB.SND.UP of TCB with TOP)) (if (\32BIT.GT (fetch TCB.SND.UP of TCB) SEQ) then (* there's urgent data to send) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.URG)) (replace TCP.URG.PTR of SEGMENT with (IDIFFERENCE (fetch TCB.SND.UP of TCB) SEQ)) else (* no urgent data) (* drag the urgent pointer along at the left edge of the window) (replace TCB.SND.UP of TCB with (fetch TCB.SND.UNA of TCB))) (if (BITTEST FLAGS \TCP.CTRL.FIN) then (* remember the sequence number of the FIN so we can tell when it's been acked) (CHECK (OR (EQ (fetch TCB.STATE of TCB) (QUOTE FIN.WAIT.1)) (EQ (fetch TCB.STATE of TCB) (QUOTE LAST.ACK)) (SHOULDNT "bad state for FIN"))) (replace TCB.FINSEQ of TCB with TOP)) (replace TCB.SND.NXT of TCB with TOP) (do (* try to send segment) (SELECTQ (fetch TCB.STATE of TCB) (LISTEN (ERROR "TCP connection not established")) ((SYN.SENT SYN.RECEIVED ESTABLISHED FIN.WAIT.1 CLOSE.WAIT LAST.ACK) (if (OR (ZEROP LENGTH) (ZEROP (fetch TCB.SND.WL1 of TCB)) (\32BIT.LEQ TOP (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB))) (\32BIT.GT (fetch TCB.SND.UP of TCB) (fetch TCB.SND.UNA of TCB))) then (* go ahead and send it) (CHECK (OR (ZEROP LENGTH) (ZEROP (fetch TCB.SND.WL1 of TCB)) (\32BIT.LEQ TOP (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB))))) (replace TCB.OUTPUT.HELD of TCB with NIL) (* advance SND.NXT) (\TCP.FIX.OUTGOING.SEGMENT TCB SEGMENT FLAGS) (replace EPREQUEUE of SEGMENT with (fetch TCB.REXMT.QUEUE of TCB)) (replace EPUSERFIELD of SEGMENT with (CLOCK0 (CREATECELL \FIXP))) (\TCP.SEND.SEGMENT TCB SEGMENT FLAGS) (RETURN) else (* block until we can send it) (replace TCB.OUTPUT.HELD of TCB with T) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.SND.EVENT of TCB)))) ((FIN.WAIT.2 CLOSING TIME.WAIT) (ERROR "TCP connection closing")) (CLOSED (ERROR "TCP connection closed")) (SHOULDNT))))) ) (\TCP.SEND.SEGMENT (LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "28-Dec-84 18:06") (* common routine to transmit a TCP segment) (\TCP.CHECKSUM.OUTGOING TCB SEGMENT) (\TCP.TRACE.SEGMENT (QUOTE SEND) SEGMENT) (if TCB then (if (BITTEST FLAGS \TCP.CTRL.ACK) then (replace TCB.ACKFLG of TCB with NIL)) (\TCP.START.PROBE.TIMER TCB)) (\IP.TRANSMIT SEGMENT)) ) (\TCP.NEW.TEMPLATE (LAMBDA (TCB) (* ejs%: "29-Dec-84 13:05") (replace TCB.TEMPLATE of TCB with NIL) (\TCP.TEMPLATE TCB))) (\TCP.START.PROBE.TIMER (LAMBDA (TCB) (* ejs%: "12-Aug-86 10:35") (replace TCB.PROBE.TIMER of TCB with (COND ((AND (fetch TCB.NO.IDLE.PROBING of TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE ESTABLISHED))) NIL) (T (COND ((NULL (fetch TCB.PROBE.TIMER of TCB)) (LET ((IPSOCKET (fetch TCB.IPSOCKET of TCB))) (COND (IPSOCKET (NOTIFY.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET))))))) (SETUPTIMER (ITIMES 4 (fetch TCB.RTO of TCB)) (fetch TCB.PROBE.TIMER of TCB)))))) ) (\TCP.RETRANSMIT (LAMBDA (TCB) (* ejs%: " 3-Jun-85 07:58") (* find the first unacknowledged segment and retransmit it) (PROG ((QUEUE (fetch TCB.REXMT.QUEUE of TCB)) (UNA (fetch TCB.SND.UNA of TCB)) CURRENT CURSEQ NEXT PREV REST FIRSTSEG MINSEQ FLAGS) (UNINTERRUPTABLY (* detach the list of segments to be retransmitted so we don't interfere with the driver) (SETQ NEXT (fetch SYSQUEUEHEAD of QUEUE)) (replace SYSQUEUEHEAD of QUEUE with NIL) (replace SYSQUEUETAIL of QUEUE with NIL)) (while (SETQ CURRENT NEXT) do (SETQ NEXT (fetch QLINK of CURRENT)) (replace QLINK of CURRENT with NIL) (if (\32BIT.LEQ (IPLUS (SETQ CURSEQ (fetch TCP.SEQ of CURRENT)) (\TCP.DATA.LENGTH CURRENT) (\TCP.SYN.OR.FIN (fetch TCP.CTRL of CURRENT))) UNA) then (* this segment has already been acked) (\TCP.RELEASE.SEGMENT CURRENT) elseif (NULL FIRSTSEG) then (* this is the first unacked segment we've encountered) (SETQ FIRSTSEG CURRENT) (SETQ MINSEQ CURSEQ) elseif (\32BIT.LT CURSEQ MINSEQ) then (* this is the lowest sequence number seen so so far; put the previous contender back on the REST queue) (replace QLINK of FIRSTSEG with REST) (SETQ REST FIRSTSEG) (SETQ FIRSTSEG CURRENT) (SETQ MINSEQ CURSEQ) else (* this is an unacked segment but later than one we've already seen; just add it to the REST queue) (replace QLINK of CURRENT with REST) (SETQ REST CURRENT))) (UNINTERRUPTABLY (* set the retransmit queue to be the REST queue we've accumulated) (if (SETQ CURRENT REST) then (* find tail of REST queue) (while (SETQ NEXT (fetch QLINK of CURRENT)) do (SETQ CURRENT NEXT))) (replace SYSQUEUEHEAD of QUEUE with REST) (replace SYSQUEUETAIL of QUEUE with CURRENT)) (if FIRSTSEG then (if (IGEQ (CLOCKDIFFERENCE (fetch EPUSERFIELD of FIRSTSEG)) (fetch TCB.RTO of TCB)) then (SETQ FLAGS (fetch TCP.CTRL of FIRSTSEG)) (\TCP.FIX.OUTGOING.SEGMENT TCB FIRSTSEG FLAGS) (replace EPREQUEUE of FIRSTSEG with (fetch TCB.REXMT.QUEUE of TCB)) (CLOCK0 (fetch EPUSERFIELD of FIRSTSEG)) (\TCP.SEND.SEGMENT TCB FIRSTSEG FLAGS) (RETURN T) else (\ENQUEUE (fetch TCB.REXMT.QUEUE of TCB) FIRSTSEG) (RETURN NIL)) else (RETURN NIL)))) ) (\TCP.START.TIME.WAIT (LAMBDA (TCB) (* ecc "16-Apr-84 17:58") (* start 2MSL timer) (replace TCB.2MSL.TIMER of TCB with (SETUPTIMER (ITIMES 2 \TCP.MSL) (fetch TCB.2MSL.TIMER of TCB))) (\TCP.TRACE.TRANSITION TCB (QUOTE TIME.WAIT)) (replace TCB.STATE of TCB with (QUOTE TIME.WAIT))) ) (\TCP.CONNECTION.DROPPED (LAMBDA (TCB MSG) (* ejs%: "29-Jan-85 16:06") (if TCPTRACEFLG then (printout TCPTRACEFILE .TAB0 0 "[TCP connection " (OR MSG "dropped") "]" T)) (\TCP.TRACE.TRANSITION TCB (QUOTE CLOSED)) (replace TCB.STATE of TCB with (QUOTE CLOSED)) (AND (OPENP (fetch TCB.RCV.STREAM of TCB) (QUOTE INPUT)) (CLOSEF (fetch TCB.RCV.STREAM of TCB))) (AND (OPENP (fetch TCB.SND.STREAM of TCB) (QUOTE OUTPUT)) (CLOSEF (fetch TCB.SND.STREAM of TCB))) (NOTIFY.EVENT (fetch TCB.RCV.EVENT of TCB))) ) (\TCP.CHECK.OPTIONS (LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "21-Mar-86 20:04") (* * Do TCP header options processing) (COND ((IGREATERP (fetch (TCPSEGMENT TCP.DATA.OFFSET) of SEGMENT) \TCP.MIN.DATA.OFFSET) (\TCP.PROCESS.OPTIONS TCB SEGMENT FLAGS)) (T T))) ) (\TCP.PROCESS.OPTIONS (LAMBDA (TCB SEGMENT FLAGS) (* ejs%: "20-Jun-85 16:08") (* * Process the options in a TCP header) (bind (OPTIONBASE _ (fetch (TCPSEGMENT TCP.OPTIONS) of SEGMENT)) (OPTIONOFFSET _ 0) OPTION eachtime (SETQ OPTION (\GETBASEBYTE OPTIONBASE OPTIONOFFSET)) until (EQ OPTION \TCPOPT.END) do (SELECTC OPTION (\TCPOPT.END (HELP "Unexpected \TCPOPT.END processing TCP options")) (\TCPOPT.NOP (add OPTIONOFFSET 1)) (\TCPOPT.MAXSEG (COND ((BITTEST FLAGS \TCP.CTRL.SYN) (replace TCB.MAXSEG of TCB with (IMIN \TCP.DEFAULT.MAXSEG (LOGOR (LLSH (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 2)) BITSPERBYTE) (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 3))))))) (add OPTIONOFFSET (\GETBASEBYTE OPTIONBASE (ADD1 OPTIONOFFSET)))) (RETURN))) T) ) ) (* ;; "support for ICMP messages that affect TCP connections") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.PROTOCOL 1) (CONSTANTS \ICMP.PROTOCOL) ) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.32BIT.WORDS 2) (CONSTANTS \ICMP.32BIT.WORDS) ) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.DESTINATION.UNREACHABLE 3) (RPAQQ \ICMP.SOURCE.QUENCH 4) (CONSTANTS \ICMP.DESTINATION.UNREACHABLE \ICMP.SOURCE.QUENCH) ) ) (DEFINEQ (\TCP.HANDLE.ICMP (LAMBDA (ICMP SEGMENT) (* ejs%: " 3-Jun-85 07:41") (* handle ICMP messages) (PROG (MSG TCB) (if (NEQ (fetch (ICMP ICMPTYPE) of ICMP) \ICMP.DESTINATION.UNREACHABLE) then (RETURN)) (SETQ MSG (SELECTQ (fetch (ICMP ICMPCODE) of ICMP) (0 "net unreachable") (1 "host unreachable") (2 "protocol unreachable") (3 "port unreachable") (4 "fragmentation needed and DF set") (5 "source route failed") "destination unreachable (unknown code)")) (SETQ TCB (\TCP.LOOKUP.TCB (fetch TCP.DST.ADDR of SEGMENT) (fetch TCP.DST.PORT of SEGMENT) (fetch TCP.SRC.PORT of SEGMENT))) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED))) then (RETURN)) (\RELEASE.ETHERPACKET ICMP) (\TCP.CONNECTION.DROPPED TCB MSG))) ) ) (* ;; "TCP stream routines") (DEFINEQ (TCP.OPEN (LAMBDA (DST.HOST DST.PORT SRC.PORT MODE ACCESS NOERRORFLG OPTIONS) (* ejs%: "21-Mar-86 17:38") (PROG (TCB DST.HOST.NUMBER) (SELECTQ ACCESS (INPUT) (APPEND) (OUTPUT (SETQ ACCESS (QUOTE APPEND))) (LISPERROR "ILLEGAL ARG" ACCESS)) (COND ((ATOM DST.HOST) (COND ((AND (NOT (SETQ DST.HOST.NUMBER (DODIP.HOSTP DST.HOST))) (EQ MODE (QUOTE ACTIVE))) (ERROR "Unknown TCP/IP host: " DST.HOST)))) ((FIXP DST.HOST) (SETQ DST.HOST.NUMBER DST.HOST)) (T (ERROR "Illegal TCP/IP host: " DST.HOST))) (SETQ TCB (\TCP.CONNECTION DST.HOST.NUMBER DST.PORT SRC.PORT MODE OPTIONS)) (RETURN (if (NULL TCB) then (if NOERRORFLG then NIL else (ERROR "TCP connection failed")) else (SELECTQ ACCESS (INPUT (fetch TCB.RCV.STREAM of TCB)) (APPEND (fetch TCB.SND.STREAM of TCB)) (SHOULDNT)))))) ) (TCP.OTHER.STREAM (LAMBDA (STREAM) (* ecc "14-May-84 16:52") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (NOT (type? TCP.CONTROL.BLOCK TCB)) then (ERROR "no TCP control block")) (RETURN (SELECTQ (fetch (TCPSTREAM ACCESS) of STREAM) (INPUT (fetch TCB.SND.STREAM of TCB)) (APPEND (fetch TCB.RCV.STREAM of TCB)) (SHOULDNT))))) ) (\TCP.BOUTS (LAMBDA (STREAM BASE OFF NBYTES) (* ejs%: "27-May-86 15:09") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (RETURN (\BUFFERED.BOUTS (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of TCB) BASE OFF NBYTES)))) ) (\TCP.OTHER.BIN (LAMBDA (STREAM) (* ejs%: "27-May-86 14:40") (\BIN (TCP.OTHER.STREAM STREAM)))) (\TCP.OTHER.BOUT (LAMBDA (STREAM BYTE) (* ejs%: "27-May-86 14:19") (BOUT (TCP.OTHER.STREAM STREAM) BYTE))) (\TCP.BIN (LAMBDA (STREAM) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (RETURN (\GETBASEBYTE (fetch CPPTR of STREAM) (PROG1 (fetch COFFSET of STREAM) (add (fetch COFFSET of STREAM) 1)))) elseif (NULL (\TCP.GET.SEGMENT STREAM)) then (RETURN (STREAMOP (QUOTE ENDOFSTREAMOP) STREAM STREAM))))) ) (\TCP.BACKFILEPTR (LAMBDA (STREAM) (* ejs%: "15-Sep-85 23:25") (COND ((AND (fetch CPPTR of STREAM) (IGEQ (fetch COFFSET of STREAM) (fetch (TCPSTREAM ORIGINAL.COFFSET) of STREAM))) (add (fetch COFFSET of STREAM) -1)) (T (\IS.NOT.RANDACCESSP STREAM)))) ) (\TCP.GETNEXTBUFFER (LAMBDA (STREAM WHATFOR NOERRORFLG) (* ejs%: "27-May-86 14:45") (BLOCK) (SELECTQ WHATFOR (READ (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.RCV.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (SETQ STREAM (TCP.OTHER.STREAM STREAM)))) (\TCP.GET.SEGMENT STREAM NOERRORFLG)) (WRITE (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (SETQ STREAM (TCP.OTHER.STREAM STREAM)))) (\TCP.FLUSH STREAM) (\TCP.FILL.IN.SEGMENT STREAM)) (SHOULDNT))) ) (\TCP.GET.SEGMENT (LAMBDA (STREAM NOERRORFLG) (* ejs%: "18-Dec-86 17:33") (* * Get the next segment from the input stream. Return T if successful; otherwise, an error code. Call the user-specified error handler to get a code, if necessary) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM)) SEGMENT SEQ LEN OLDSEGMENT OLDSEQ OLDLEN OLDTOP SUCCESS OFFSET LAST.BYTE) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB)))) then (ERROR "not TCP input stream")) (WITH.MONITOR (fetch TCB.LOCK of TCB) (SETQ OLDSEGMENT (fetch TCB.RCV.SEGMENT of TCB)) (CHECK (OR (NULL OLDSEGMENT) (EQ (fetch TCP.DATA.LENGTH of OLDSEGMENT) (fetch CBUFSIZE of STREAM)) (SHOULDNT "inconsistent stream buffer size"))) (UNINTERRUPTABLY (COND ((fetch CPPTR of STREAM) (SETQ LAST.BYTE (\GETBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM))))) (replace TCB.RCV.SEGMENT of TCB with NIL) (replace CPPTR of STREAM with NIL) (replace CBUFSIZE of STREAM with 0) (replace COFFSET of STREAM with 0)) (if OLDSEGMENT then (* remember sequence number range of previous segment so we can adjust for overlap) (SETQ OLDTOP (IPLUS (SETQ OLDSEQ (fetch TCP.SEQ of OLDSEGMENT)) (SETQ OLDLEN (fetch TCP.DATA.LENGTH of OLDSEGMENT)))) (replace TCB.RCV.WND of TCB with (IMIN \TCP.DEFAULT.RECEIVE.WINDOW (IPLUS (fetch TCB.RCV.WND of TCB) OLDLEN))) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) OLDLEN) (\TCP.RELEASE.SEGMENT OLDSEGMENT) (SETQ OLDSEGMENT T)) (* look at first segment in input queue to see if it overlaps the sequence number range we're expecting; there may be duplicates that must be skipped over) (do ((CHECK (\TCP.CHECK.INPUT.QUEUE TCB)) (COND ((AND (SETQ SEGMENT (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))) (\32BIT.LT (SETQ SEQ (fetch TCP.SEQ of SEGMENT)) (fetch TCB.RCV.NXT of TCB))) (* this segment is within the range of contiguous sequence numbers received so far, because its sequence number is less than RCV.NXT) (\DEQUEUE (fetch TCB.INPUT.QUEUE of TCB)) (SETQ LEN (fetch TCP.DATA.LENGTH of SEGMENT)) (COND ((AND OLDSEGMENT (\32BIT.LEQ (IPLUS SEQ LEN) OLDTOP)) (* this segment is a duplicate) (\TCP.RELEASE.SEGMENT SEGMENT)) (T (* this segment overlaps with the range of sequence numbers we're expecting) (CHECK (OR (NOT OLDSEGMENT) (\32BIT.LEQ SEQ OLDTOP) (SHOULDNT "gap in input queue"))) (UNINTERRUPTABLY (replace CPPTR of STREAM with (fetch TCP.CONTENTS of SEGMENT)) (* eliminate overlap) (SETQ OFFSET (replace (TCPSTREAM ORIGINAL.COFFSET) of STREAM with (replace COFFSET of STREAM with (COND (OLDSEGMENT (IDIFFERENCE OLDLEN (IDIFFERENCE SEQ OLDSEQ))) (T 0))))) (COND (LAST.BYTE (\PUTBASEBYTE (fetch CPPTR of STREAM) (SUB1 OFFSET) LAST.BYTE))) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) (IMINUS OFFSET)) (replace CBUFSIZE of STREAM with LEN) (replace TCB.RCV.SEGMENT of TCB with SEGMENT)) (SETQ SUCCESS T) (RETURN)))) (T (SELECTQ (fetch TCB.STATE of TCB) ((LISTEN SYN.SENT SYN.RECEIVED) (* wait until established) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.ESTABLISHED of TCB))) ((ESTABLISHED FIN.WAIT.1 FIN.WAIT.2) (* wait for next segment) (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.RCV.EVENT of TCB)) (SELECTQ (fetch TCB.STATE of TCB) ((CLOSED CLOSING LAST.ACK) (RELEASE.MONITORLOCK (fetch TCB.LOCK of TCB)) (COND (NOERRORFLG (RETURN NIL)) (T (RETURN (SETQ SUCCESS (\EOF.ACTION STREAM)))))) NIL)) ((CLOSED CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT) (* return NIL to punt to ENDOFSTREAMOP in \TCP.BIN) (RELEASE.MONITORLOCK (fetch TCB.LOCK of TCB)) (COND (NOERRORFLG (RETURN NIL)) (T (RETURN (SETQ SUCCESS (\EOF.ACTION STREAM)))))) (SHOULDNT))))))) (if (fetch TCB.SENT.ZERO of TCB) then (\TCP.SEND.ACK TCB (QUOTE NOW)) (BLOCK)) (RETURN SUCCESS))) ) (\TCP.PEEKBIN (LAMBDA (STREAM NOERRORFLG) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (RETURN (\GETBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM))) elseif (NULL (\TCP.GET.SEGMENT STREAM)) then (RETURN (if NOERRORFLG then NIL else (STREAMOP (QUOTE ENDOFSTREAMOP) STREAM STREAM)))))) ) (\TCP.GETFILEPTR (LAMBDA (STREAM) (* ejs%: "10-Jun-85 14:07") (IPLUS (fetch (STREAM COFFSET) of STREAM) (fetch (TCPSTREAM BYTECOUNT) of STREAM))) ) (\TCP.READP (LAMBDA (STREAM) (* ejs%: " 7-Jun-85 13:39") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB)))) then (ERROR "not TCP input stream") else (RETURN (OR (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) (AND (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) T)))))) ) (\TCP.EOFP (LAMBDA (STREAM) (* ejs%: "13-Apr-85 16:15") (* check whether EOF has been reached on stream -- may block waiting for next segment) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (NULL TCB) then (ERROR "not TCP stream") elseif (AND (NEQ (QUOTE CLOSED) (fetch TCB.STATE of TCB)) (EQ STREAM (fetch TCB.SND.STREAM of TCB))) then (RETURN T) (* Always at EOF of outgoing stream.) elseif (OR (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) (NOT (NULL (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB))))) then (* there is still data left to read) (RETURN NIL) else (RETURN (SELECTQ (fetch TCB.STATE of TCB) (ESTABLISHED NIL) ((LISTEN SYN.SENT SYN.RECEIVED FIN.WAIT.1 FIN.WAIT.2) (* can't tell without waiting for next segment) (NULL (\TCP.GET.SEGMENT STREAM T))) ((CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT CLOSED) (* no more data can be forthcoming) T) (SHOULDNT)))))) ) (TCP.URGENTP (LAMBDA (STREAM) (* ecc " 7-May-84 14:27") (* check if current point in receive stream is before receive urgent pointer) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (NEQ STREAM (fetch TCB.RCV.STREAM of TCB))) then (ERROR "not TCP input stream")) (RETURN (AND (fetch TCB.RCV.SEGMENT of TCB) (\32BIT.GT (fetch TCB.RCV.UP of TCB) (IPLUS (fetch TCP.SEQ of (fetch TCB.RCV.SEGMENT of TCB)) (fetch COFFSET of STREAM))))))) ) (TCP.URGENT.EVENT (LAMBDA (STREAM) (* edited%: "22-May-84 18:10") (* return the urgent data event so that a user process can wait for it) (fetch TCB.URGENT.EVENT of (fetch (TCPSTREAM TCB) of STREAM))) ) (\TCP.BOUT (LAMBDA (STREAM CHAR) (* ecc " 3-May-84 13:55") (do (if (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) then (\PUTBASEBYTE (fetch CPPTR of STREAM) (fetch COFFSET of STREAM) CHAR) (add (fetch COFFSET of STREAM) 1) (RETURN) else (\TCP.FLUSH STREAM) (\TCP.FILL.IN.SEGMENT STREAM)))) ) (\TCP.FLUSH (LAMBDA (STREAM FLAGS) (* ; "Edited 4-Dec-87 12:11 by scp") (* Force out current output segment. If FLAGS is non-nil, send a segment with those flags even if we have to create a new one) (PROG ((TCB (fetch TCB of STREAM)) SEGMENT LENGTH) (if (OR (NULL TCB) (AND (NEQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (NEQ STREAM (fetch TCB.SND.STREAM of TCB)))) then (ERROR "not TCP output stream")) (SETQ LENGTH (fetch COFFSET of STREAM)) (WITH.FAST.MONITOR (fetch TCB.LOCK of TCB) (if (OR (AND (SETQ SEGMENT (fetch TCB.SND.SEGMENT of TCB)) (NOT (ZEROP LENGTH))) (AND FLAGS (SETQ SEGMENT (\TCP.FILL.IN.SEGMENT STREAM (COND ((EQ (fetch TCB.STATE of TCB) (QUOTE SYN.SENT)) (BQUOTE (MAXSEG %, (OR (fetch TCB.OUR.MAXSEG of TCB) \TCP.DEFAULT.MAXSEG)))) ((EQ (fetch TCB.STATE of TCB) (QUOTE SYN.RECEIVED)) (BQUOTE (MAXSEG %, (OR (fetch TCB.OUR.MAXSEG of TCB) \TCP.DEFAULT.MAXSEG))))))))) then (if (NULL FLAGS) then (SETQ FLAGS 0)) (CHECK (OR (NOT (ZEROP LENGTH)) (NOT (ZEROP (\TCP.SYN.OR.FIN FLAGS))) (SHOULDNT "sending empty segment"))) (if (AND (IGREATERP LENGTH 0) (ILESSP LENGTH (fetch TCB.OUR.MAXSEG of TCB))) then (* PSH this segment to make sure it gets through to the remote process) (SETQ FLAGS (LOGOR FLAGS \TCP.CTRL.PSH))) (UNINTERRUPTABLY (replace TCB.SND.SEGMENT of TCB with NIL) (replace CBUFSIZE of STREAM with 0) (replace COFFSET of STREAM with 0) (replace CPPTR of STREAM with NIL) (add (fetch (TCPSTREAM BYTECOUNT) of STREAM) LENGTH)) (add (fetch (IP IPTOTALLENGTH) of SEGMENT) LENGTH) (\TCP.SEND.DATA TCB SEGMENT LENGTH FLAGS))))) ) (\TCP.FORCEOUTPUT (LAMBDA (STREAM WAITFLG) (* ejs%: "27-May-86 14:36") (* just call \TCP.FLUSH with no flags -- to implement WAITFLG we should wait for SND.UNA to overtake the current SND.NXT) (COND ((NEQ STREAM (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM))) (\TCP.FLUSH (fetch (TCP.CONTROL.BLOCK TCB.SND.STREAM) of (fetch (TCPSTREAM TCB) of STREAM)))) (T (\TCP.FLUSH STREAM)))) ) (TCP.URGENT.MARK (LAMBDA (STREAM) (* ecc " 7-May-84 14:17") (* mark the current point in the output stream as the end of urgent data) (\TCP.FLUSH STREAM \TCP.CTRL.URG)) ) (\TCP.FILL.IN.SEGMENT (LAMBDA (STREAM OPTIONS) (* ejs%: "22-Jun-85 03:18") (* * set up a new segment to be filled by the output stream. OPTIONS, if supplied, is in PLIST format) (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM)) SEGMENT) (SETQ SEGMENT (\TCP.SETUP.SEGMENT (\LOCAL.IP.ADDRESS) (fetch TCB.SRC.PORT of TCB) (fetch TCB.DST.HOST of TCB) (fetch TCB.DST.PORT of TCB))) (COND (OPTIONS (\TCP.SETUP.SEGMENT.OPTIONS SEGMENT OPTIONS))) (UNINTERRUPTABLY (replace TCB.SND.SEGMENT of TCB with SEGMENT) (replace CPPTR of STREAM with (fetch TCP.CONTENTS of SEGMENT)) (replace COFFSET of STREAM with 0) (replace CBUFSIZE of STREAM with (fetch TCB.MAXSEG of TCB)) (replace CBUFMAXSIZE of STREAM with (fetch TCB.MAXSEG of TCB))) (RETURN SEGMENT))) ) (\TCP.CLOSE (LAMBDA (STREAM) (* ejs%: "29-Jan-85 17:19") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (FMEMB (fetch TCB.STATE of TCB) (QUOTE (CLOSED TIME.WAIT)))) then (RETURN)) (if (NOT (fetch TCB.CLOSEDFLG of TCB)) then (TCP.CLOSE.SENDER (fetch TCB.SND.STREAM of TCB))) (if (EQ STREAM (fetch TCB.RCV.STREAM of TCB)) then (while (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) do (* gobble remaining segments from remote end) (\TCP.GET.SEGMENT STREAM))))) ) (\TCP.RESETCLOSE (LAMBDA (STREAM) (* ejs%: "27-May-86 11:55") (\TCP.CLOSE STREAM))) (TCP.CLOSE.SENDER (LAMBDA (STREAM) (* ecc " 7-May-84 13:44") (PROG ((TCB (fetch (TCPSTREAM TCB) of STREAM))) (if (OR (NULL TCB) (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (fetch TCB.CLOSEDFLG of TCB)) then (RETURN)) (WITH.MONITOR (fetch TCB.LOCK of TCB) (replace TCB.CLOSEDFLG of TCB with T) (SELECTQ (fetch TCB.STATE of TCB) ((LISTEN SYN.SENT) (\TCP.CONNECTION.DROPPED TCB "closed")) ((SYN.RECEIVED ESTABLISHED) (\TCP.TRACE.TRANSITION TCB (QUOTE FIN.WAIT.1)) (replace TCB.STATE of TCB with (QUOTE FIN.WAIT.1)) (\TCP.FLUSH STREAM \TCP.CTRL.FIN)) (CLOSE.WAIT (\TCP.TRACE.TRANSITION TCB (QUOTE LAST.ACK)) (replace TCB.STATE of TCB with (QUOTE LAST.ACK)) (* There is an inconsistency in the spec about this transition%: the description of the CLOSE operation says to go to the CLOSING state, while the diagram shows a transition to the LAST.ACK state. Since the LAST.ACK state avoids the 2MSL wait, we use it.) (\TCP.FLUSH STREAM \TCP.CTRL.FIN)) NIL) (while (NOT (OR (EQ (fetch TCB.STATE of TCB) (QUOTE CLOSED)) (\TCP.OUR.FIN.IS.ACKED TCB))) do (MONITOR.AWAIT.EVENT (fetch TCB.LOCK of TCB) (fetch TCB.FINACKED.EVENT of TCB)))))) ) (TCP.DESTADDRESS (LAMBDA (STREAM) (* ejs%: "27-May-86 11:53") (\IP.ADDRESS.TO.STRING (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of (fetch (TCPSTREAM TCB) of STREAM)))) ) (TCP.STOP (LAMBDA NIL (* ejs%: "28-Dec-84 18:02") (MAPC \TCP.CONTROL.BLOCKS (FUNCTION \TCP.DELETE.TCB)) (SETQ \TCP.CONTROL.BLOCKS NIL) (\IP.DELETE.PROTOCOL \TCP.PROTOCOL)) ) ) (* ;; "well-known ports for network standard functions") (RPAQQ \TCP.ASSIGNED.PORTS (\TCP.ECHO.PORT \TCP.SINK.PORT \TCP.SYSTAT.PORT \TCP.DAYTIME.PORT \TCP.NETSTAT.PORT \TCP.FAUCET.PORT \TCP.FTP.PORT \TCP.TELNET.PORT \TCP.SMTP.PORT \TCP.TIME.PORT \TCP.NAME.PORT \TCP.WHOIS.PORT \TCP.NAMESERVER.PORT \TCP.FINGER.PORT \TCP.TTYLINK.PORT \TCP.SUPDUP.PORT \TCP.HOSTNAMES.PORT \TCP.UNIXEXEC.PORT \TCP.UNIXLOGIN.PORT \TCP.UNIXSHELL.PORT)) (DECLARE%: EVAL@COMPILE (RPAQQ \TCP.ECHO.PORT 7) (RPAQQ \TCP.SINK.PORT 9) (RPAQQ \TCP.SYSTAT.PORT 11) (RPAQQ \TCP.DAYTIME.PORT 13) (RPAQQ \TCP.NETSTAT.PORT 15) (RPAQQ \TCP.FAUCET.PORT 19) (RPAQQ \TCP.FTP.PORT 21) (RPAQQ \TCP.TELNET.PORT 23) (RPAQQ \TCP.SMTP.PORT 25) (RPAQQ \TCP.TIME.PORT 37) (RPAQQ \TCP.NAME.PORT 42) (RPAQQ \TCP.WHOIS.PORT 43) (RPAQQ \TCP.NAMESERVER.PORT 53) (RPAQQ \TCP.FINGER.PORT 79) (RPAQQ \TCP.TTYLINK.PORT 87) (RPAQQ \TCP.SUPDUP.PORT 95) (RPAQQ \TCP.HOSTNAMES.PORT 101) (RPAQQ \TCP.UNIXEXEC.PORT 512) (RPAQQ \TCP.UNIXLOGIN.PORT 513) (RPAQQ \TCP.UNIXSHELL.PORT 514) (CONSTANTS \TCP.ECHO.PORT \TCP.SINK.PORT \TCP.SYSTAT.PORT \TCP.DAYTIME.PORT \TCP.NETSTAT.PORT \TCP.FAUCET.PORT \TCP.FTP.PORT \TCP.TELNET.PORT \TCP.SMTP.PORT \TCP.TIME.PORT \TCP.NAME.PORT \TCP.WHOIS.PORT \TCP.NAMESERVER.PORT \TCP.FINGER.PORT \TCP.TTYLINK.PORT \TCP.SUPDUP.PORT \TCP.HOSTNAMES.PORT \TCP.UNIXEXEC.PORT \TCP.UNIXLOGIN.PORT \TCP.UNIXSHELL.PORT) ) (* ;; "Stub for debugging") (RPAQ? \TCP.DEBUGGABLE ) (RPAQ? TCPTRACEFLG ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG) ) (DEFINEQ (PPTCB (LAMBDA (TCB FILE) (* ejs%: " 5-Feb-85 16:47") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE)) (COND (\TCP.DEBUGGABLE (printout FILE "TCP connection from " %# (\IP.PRINT.ADDRESS (\LOCAL.IP.ADDRESS) FILE) ":" (fetch TCB.SRC.PORT of TCB) " to " %# (\IP.PRINT.ADDRESS (fetch TCB.DST.HOST of TCB) FILE) ":" (fetch TCB.DST.PORT of TCB) " " (fetch TCB.STATE of TCB) T) (printout FILE " iss " (fetch TCB.ISS of TCB) " window " (fetch TCB.SND.UNA of TCB) ".." (IPLUS (fetch TCB.SND.UNA of TCB) (fetch TCB.SND.WND of TCB)) " next " (fetch TCB.SND.NXT of TCB)) (if (fetch TCB.FINSEQ of TCB) then (printout FILE " fin " (fetch TCB.FINSEQ of TCB))) (printout FILE " rto " (fetch TCB.RTO of TCB) T) (printout FILE " irs " (fetch TCB.IRS of TCB) " next " (fetch TCB.RCV.NXT of TCB) " window " (fetch TCB.RCV.NXT of TCB) ".." (IPLUS (fetch TCB.RCV.NXT of TCB) (fetch TCB.RCV.WND of TCB)) T) (\TCP.PRINT.SEGMENT.QUEUE "retransmit queue" (fetch TCB.REXMT.QUEUE of TCB) FILE) (\TCP.PRINT.SEGMENT.QUEUE "input queue" (fetch TCB.INPUT.QUEUE of TCB) FILE)))) ) (\TCP.TRACE.SEGMENT (LAMBDA (CALLER SEGMENT) (* ejs%: " 5-Feb-85 16:50") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE TCPTRACEFLG)) (if (AND \TCP.DEBUGGABLE (MEMB CALLER TCPTRACEFLG)) then (printout TCPTRACEFILE .TAB0 0 %# (\TCP.PRINT.ELAPSED.TIME TCPTRACEFILE) CALLER ": " %# (TCP.PRINT.SEGMENT SEGMENT TCPTRACEFILE NIL (MEMB (QUOTE CONTENTS) TCPTRACEFLG))))) ) (\TCP.TRACE.TRANSITION (LAMBDA (TCB NEWSTATE) (* ejs%: " 5-Feb-85 16:51") (DECLARE (GLOBALVARS \TCP.DEBUGGABLE)) (if (AND \TCP.DEBUGGABLE (MEMB (QUOTE TRANSITION) TCPTRACEFLG) (NEQ (fetch TCB.STATE of TCB) NEWSTATE)) then (printout TCPTRACEFILE .TAB0 0 %# (\TCP.PRINT.ELAPSED.TIME TCPTRACEFILE) (fetch TCB.SRC.PORT of TCB) "/" (fetch TCB.DST.PORT of TCB) ": " (fetch TCB.STATE of TCB) " ---> " NEWSTATE))) ) ) (* ;; "TCP initialization") (DEFINEQ (\TCP.INIT (LAMBDA NIL (* ; "Edited 11-Aug-88 14:32 by atm") (COND ((NULL \TCP.DEVICE) (SETQ \TCP.DEVICE (create FDEV FDBINABLE _ T FDBOUTABLE _ T BUFFERED _ T CLOSEFILE _ (FUNCTION \TCP.CLOSE) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM) OPENP _ (FUNCTION \GENERIC.OPENP) BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION \BUFFERED.BOUT) BLOCKIN _ (FUNCTION \BUFFERED.BINS) BLOCKOUT _ (FUNCTION \TCP.BOUTS) PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN) READP _ (FUNCTION \TCP.READP) FORCEOUTPUT _ (FUNCTION \TCP.FORCEOUTPUT) GETNEXTBUFFER _ (FUNCTION \TCP.GETNEXTBUFFER) BACKFILEPTR _ (FUNCTION \TCP.BACKFILEPTR) GETFILEPTR _ (FUNCTION \TCP.GETFILEPTR) EOFP _ (FUNCTION \TCP.EOFP) DEVICENAME _ (QUOTE TCP) EVENTFN _ (FUNCTION NILL))) (\DEFINEDEVICE (QUOTE TCP) \TCP.DEVICE))) (SETQ \TCP.LOCK (CREATE.MONITORLOCK)) (COND ((NULL \TCP.PSEUDOHEADER) (SETQ \TCP.PSEUDOHEADER (create TCP.PSEUDOHEADER)))) (OR \IPFLG (\IPINIT)) (\IP.ADD.PROTOCOL \TCP.PROTOCOL (FUNCTION \TCP.PORTCOMPARE) (FUNCTION \TCP.NOSOCKETFN) NIL (FUNCTION \TCP.HANDLE.ICMP)) (SETQ \TCP.MASTER.SOCKET (\IP.FIND.PROTOCOL \TCP.PROTOCOL))) ) ) (\TCP.INIT) (PUTPROPS TCP COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1901 1900 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8342 9364 (SET.IP.ADDRESS 8352 . 8622) (STRING.TO.IP.ADDRESS 8624 . 8865) ( IP.ADDRESS.TO.STRING 8867 . 9091) (\LOCAL.IP.ADDRESS 9093 . 9362)) (14232 14439 (\TCP.SELECT.ISS 14242 . 14437)) (28588 34348 (\TCP.CREATE.TCB 28598 . 29684) (\TCP.SELECT.PORT 29686 . 29968) ( \TCP.LOOKUP.TCB 29970 . 30867) (\TCP.DELETE.TCB 30869 . 32537) (\TCP.NOSOCKETFN 32539 . 33367) ( \TCP.PORTCOMPARE 33369 . 34346)) (36215 38810 (\COMPUTE.CHECKSUM 36225 . 36891) ( \TCP.CHECKSUM.INCOMING 36893 . 37989) (\TCP.CHECKSUM.OUTGOING 37991 . 38808)) (39315 77802 (\TCP.ACK# 39325 . 39782) (\TCP.PACKET.FILTER 39784 . 40055) (\TCP.SETUP.SEGMENT 40057 . 40587) ( \TCP.RELEASE.SEGMENT 40589 . 40843) (\TCP.CONNECTION 40845 . 44136) (\TCP.FIX.INCOMING.SEGMENT 44138 . 44766) (\TCP.DATA.LENGTH 44768 . 45096) (\TCP.SYN.OR.FIN 45098 . 45438) (\TCP.INPUT 45440 . 48309) (\TCP.INPUT.INITIAL 48311 . 49094) (\TCP.INPUT.UNSYNC 49096 . 49466) (\TCP.INPUT.LISTEN 49468 . 50911) (\TCP.INPUT.SYN.SENT 50913 . 52778) (\TCP.CHECK.WINDOW 52780 . 53628) (\TCP.CHECK.RESET 53630 . 54398 ) (\TCP.CHECK.SECURITY 54400 . 54600) (\TCP.CHECK.NO.SYN 54602 . 55166) (\TCP.CHECK.ACK 55168 . 55443) (\TCP.HANDLE.ACK 55445 . 56750) (\TCP.HANDLE.URG 56752 . 57345) (\TCP.QUEUE.INPUT 57347 . 61011) ( \TCP.HANDLE.FIN 61013 . 62109) (\TCP.OUR.FIN.IS.ACKED 62111 . 62378) (\TCP.SIGNAL.URGENT.DATA 62380 . 62586) (\TCP.PROCESS 62588 . 65394) (\TCP.TEMPLATE 65396 . 66104) (\TCP.SETUP.SEGMENT.OPTIONS 66106 . 67362) (\TCP.SEND.CONTROL 67364 . 68215) (\TCP.SEND.ACK 68217 . 68655) (\TCP.SEND.RESET 68657 . 69371) (\TCP.FIX.OUTGOING.SEGMENT 69373 . 70111) (\TCP.SEND.DATA 70113 . 72955) (\TCP.SEND.SEGMENT 72957 . 73305) (\TCP.NEW.TEMPLATE 73307 . 73432) (\TCP.START.PROBE.TIMER 73434 . 73897) (\TCP.RETRANSMIT 73899 . 75994) (\TCP.START.TIME.WAIT 75996 . 76281) (\TCP.CONNECTION.DROPPED 76283 . 76787) ( \TCP.CHECK.OPTIONS 76789 . 77047) (\TCP.PROCESS.OPTIONS 77049 . 77800)) (78261 78997 (\TCP.HANDLE.ICMP 78271 . 78995)) (79035 93181 (TCP.OPEN 79045 . 79822) (TCP.OTHER.STREAM 79824 . 80161) (\TCP.BOUTS 80163 . 80384) (\TCP.OTHER.BIN 80386 . 80485) (\TCP.OTHER.BOUT 80487 . 80597) (\TCP.BIN 80599 . 80952) (\TCP.BACKFILEPTR 80954 . 81210) (\TCP.GETNEXTBUFFER 81212 . 81725) (\TCP.GET.SEGMENT 81727 . 85444) (\TCP.PEEKBIN 85446 . 85802) (\TCP.GETFILEPTR 85804 . 85955) (\TCP.READP 85957 . 86354) (\TCP.EOFP 86356 . 87244) (TCP.URGENTP 87246 . 87703) (TCP.URGENT.EVENT 87705 . 87911) (\TCP.BOUT 87913 . 88223) (\TCP.FLUSH 88225 . 89779) (\TCP.FORCEOUTPUT 89781 . 90199) (TCP.URGENT.MARK 90201 . 90375) ( \TCP.FILL.IN.SEGMENT 90377 . 91122) (\TCP.CLOSE 91124 . 91604) (\TCP.RESETCLOSE 91606 . 91693) ( TCP.CLOSE.SENDER 91695 . 92828) (TCP.DESTADDRESS 92830 . 93000) (TCP.STOP 93002 . 93179)) (94939 96765 (PPTCB 94949 . 95990) (\TCP.TRACE.SEGMENT 95992 . 96350) (\TCP.TRACE.TRANSITION 96352 . 96763)) ( 96802 97966 (\TCP.INIT 96812 . 97964))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPCHAT b/obsolete/tcp/TCPCHAT deleted file mode 100644 index 0c4735fc..00000000 --- a/obsolete/tcp/TCPCHAT +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 16:10:42" {DSK}local>lde>lispcore>library>TCPCHAT.;3 11300 changes to%: (FILES TCP) (VARS TCPCHATCOMS) previous date%: "15-Feb-90 13:09:03" {DSK}local>lde>lispcore>library>TCPCHAT.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPCHATCOMS) (RPAQQ TCPCHATCOMS [(FNS TCPCHAT.BIN TCPCHAT.HOST.FILTER TCPCHAT.NEGOTIATE TCPCHAT.OPEN TCPCHAT.OPTION.COMMAND TCPCHAT.OPTION.INPUT TCPCHAT.OPTION.OUTPUT TCPCHAT.OPTION.TRACE TCPCHAT.TERMINAL.TYPE) (VARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS) (INITVARS (TCPCHAT.TRACEFLG) (TCPCHAT.TRACEFILE)) (FILES (SYSLOAD) TCP CHAT) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES CHATDECLS) (COMS (CONSTANTS * TELNET.COMMANDS) (CONSTANTS * TELNET.MARKS)) (RECORDS TELNET.OPTION TELNET.OPTIONSTATE) (GLOBALVARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS TELNET.MARKS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;; "Tell Chat we exist ") (ADDVARS (CHAT.PROTOCOLTYPES (TCP . TCPCHAT.HOST.FILTER)) (CHAT.PROTOCOL.ABBREVS (N . TCP) (T . TCP]) (DEFINEQ (TCPCHAT.BIN (LAMBDA (STREAM) (* ; "Edited 7-Jul-88 18:03 by atm") (bind CHAR while (AND (EQ (SETQ CHAR (\BUFFERED.BIN STREAM)) TELNET.IAC) (NEQ (SETQ CHAR (\BUFFERED.BIN STREAM)) TELNET.IAC)) do (TCPCHAT.NEGOTIATE CHAR STREAM) finally (RETURN CHAR))) ) (TCPCHAT.HOST.FILTER (LAMBDA (HOST) (* ; "Edited 12-Apr-88 17:14 by bvm") (COND ((AND \IPFLG (DODIP.HOSTP HOST)) (LIST HOST (FUNCTION TCPCHAT.OPEN))))) ) (TCPCHAT.NEGOTIATE (LAMBDA (COMMAND STREAM) (* ; "Edited 7-Jul-88 18:03 by atm") (TCPCHAT.OPTION.INPUT (TCP.OTHER.STREAM STREAM) COMMAND (\BUFFERED.BIN STREAM))) ) (TCPCHAT.OPEN (LAMBDA (HOST) (* ; "Edited 17-Apr-87 10:06 by jrb:") (PROG ((STREAM (TCP.OPEN (DODIP.HOSTP HOST) \TCP.TELNET.PORT NIL (QUOTE ACTIVE) (QUOTE INPUT))) (OSTYPE (OR (AND (GETHASH (U-CASE HOST) \IP.HOSTNAMES) (fetch (HOSTS.TXT.ENTRY HTE.OS.TYPE) of (GETHASH (U-CASE HOST) \IP.HOSTNAMES))) (GETHOSTINFO HOST (QUOTE OSTYPE)))) OUTPUTSTREAM) (COND (STREAM (replace (STREAM BINABLE) of STREAM with NIL) (* ; "Can't run microcoded") (replace (STREAM STRMBINFN) of STREAM with (FUNCTION TCPCHAT.BIN)) (STREAMPROP STREAM (QUOTE SETDISPLAYTYPE) (FUNCTION NILL)) (COND ((EQ OSTYPE (QUOTE INTERLISP)) (RETURN (CONS STREAM (TCP.OTHER.STREAM STREAM))))) (* ; "(STREAMPROP STREAM (QUOTE SETDISPLAYTYPE) (FUNCTION TCPCHAT.TERMINAL.TYPE))") (SETQ OUTPUTSTREAM (TCP.OTHER.STREAM STREAM)) (STREAMPROP OUTPUTSTREAM (QUOTE OPTIONSTATES) (for OPTION in TELNET.OPTIONS collect (create TELNET.OPTIONSTATE OPTION _ (fetch (TELNET.OPTION OPTION) of OPTION)))) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.ECHO) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.SUPPRESS.GOAHEAD) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.WILL TELNET.SUPPRESS.GOAHEAD) (COND ((NEQ OSTYPE (QUOTE UNIX)) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.DO TELNET.BINARY) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM TELNET.WILL TELNET.BINARY))) (RETURN (CONS STREAM OUTPUTSTREAM)))))) ) (TCPCHAT.OPTION.COMMAND (LAMBDA (OUTPUTSTREAM COMMAND OPTION TRACECAPTION) (* ; "Edited 24-Aug-87 16:58 by scp") (LET ((OPTIONSTATE (FASSOC OPTION (STREAMPROP OUTPUTSTREAM (QUOTE OPTIONSTATES)))) GO.AHEAD.WITH.COMMAND) (COND ((NULL OPTIONSTATE) (SETQ GO.AHEAD.WITH.COMMAND T)) (T (SELECTC COMMAND (TELNET.DO (COND ((NEQ (fetch (TELNET.OPTIONSTATE DOING) of OPTIONSTATE) (QUOTE YES)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE DOING) of OPTIONSTATE with (QUOTE YES))))) (TELNET.WILL (COND ((NEQ (fetch (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE) (QUOTE YES)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE with (QUOTE YES))))) (TELNET.DONT (COND ((NEQ (fetch (TELNET.OPTIONSTATE DOING) of OPTIONSTATE) (QUOTE NO)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE DOING) of OPTIONSTATE with (QUOTE NO))))) (TELNET.WONT (COND ((NEQ (fetch (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE) (QUOTE NO)) (SETQ GO.AHEAD.WITH.COMMAND T) (replace (TELNET.OPTIONSTATE WILLING) of OPTIONSTATE with (QUOTE NO))))) NIL))) (COND (GO.AHEAD.WITH.COMMAND (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM COMMAND) (BOUT OUTPUTSTREAM OPTION) (FORCEOUTPUT OUTPUTSTREAM) (TCPCHAT.OPTION.TRACE COMMAND OPTION (OR TRACECAPTION (QUOTE SEND))))))) ) (TCPCHAT.OPTION.INPUT (LAMBDA (OUTPUTSTREAM COMMAND OPTION) (* ; "Edited 16-Apr-87 13:30 by jrb:") (LET ((OPTIONRECORD (FASSOC OPTION TELNET.OPTIONS))) (COND (OPTIONRECORD (SELECTC COMMAND (TELNET.DO (TCPCHAT.OPTION.TRACE (QUOTE DO) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.DO) of OPTIONRECORD) OPTION)) (TELNET.DONT (TCPCHAT.OPTION.TRACE (QUOTE DONT) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.DONT) of OPTIONRECORD) OPTION)) (TELNET.WILL (TCPCHAT.OPTION.TRACE (QUOTE WILL) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.WILL) of OPTIONRECORD) OPTION)) (TELNET.WONT (TCPCHAT.OPTION.TRACE (QUOTE WONT) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.WONT) of OPTIONRECORD) OPTION)) (TELNET.SB (TCPCHAT.OPTION.TRACE (QUOTE SB) OPTION (QUOTE RECV)) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (fetch (TELNET.OPTION ON.SB) of OPTIONRECORD) OPTION)) COMMAND)) (T (TCPCHAT.OPTION.TRACE COMMAND OPTION) (TCPCHAT.OPTION.OUTPUT OUTPUTSTREAM (QUOTE WONT) OPTION))))) ) (TCPCHAT.OPTION.OUTPUT (LAMBDA (OUTPUTSTREAM COMMAND OPTION) (* ; "Edited 17-Apr-87 16:34 by jrb:") (LET (CMDNUM) (COND ((NULL COMMAND)) ((SETQ CMDNUM (CDR (FASSOC COMMAND (BQUOTE ((WILL \, TELNET.WILL) (WONT \, TELNET.WONT) (DO \, TELNET.DO) (DONT \, TELNET.DONT)))))) (TCPCHAT.OPTION.COMMAND OUTPUTSTREAM CMDNUM OPTION (QUOTE SENDBACK))) (T (APPLY* COMMAND (TCP.OTHER.STREAM OUTPUTSTREAM)))))) ) (TCPCHAT.OPTION.TRACE (LAMBDA (COMMAND OPTION PREFIX) (* ejs%: "22-Apr-85 16:41") (DECLARE (GLOBALVARS TCPCHAT.TRACEFLG TCPCHAT.TRACEFILE)) (COND (TCPCHAT.TRACEFLG (COND ((SMALLP COMMAND) (SETQ COMMAND (SELECTC COMMAND (TELNET.DO (QUOTE DO)) (TELNET.DONT (QUOTE DONT)) (TELNET.WILL (QUOTE WILL)) (TELNET.WONT (QUOTE WONT)) COMMAND)))) (printout TCPCHAT.TRACEFILE PREFIX ": " COMMAND " ") (PRINTCONSTANT OPTION TELNET.MARKS TCPCHAT.TRACEFILE) (TERPRI TCPCHAT.TRACEFILE)))) ) (TCPCHAT.TERMINAL.TYPE (LAMBDA (INPUTSTREAM) (* ; "Edited 20-Apr-87 13:42 by jrb:") (LET ((COMMAND)) (SELECTC (\BUFFERED.BIN INPUTSTREAM) (TELNET.SEND (* ; "OK, should be followed by IAC SE") (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS SEND")) (IF (EQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.IAC) THEN (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " IAC")) ELSE (IF TCPCHAT.TRACEFLG THEN (printout " EXPECTED IAC, GOT " COMMAND))) (IF (EQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.SE) THEN (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " SE")) ELSE (IF TCPCHAT.TRACEFLG THEN (printout " EXPECTED SE, GOT " COMMAND))) (IF TCPCHAT.TRACEFLG THEN (TERPRI TCPCHAT.TRACEFILE)) (LET* ((OUTPUTSTREAM (TCP.OTHER.STREAM INPUTSTREAM)) (DISPLAYTYPE (OR (CDR (FASSOC (fetch (CHATDISPLAYTYPE DPYNAME) of (STREAMPROP INPUTSTREAM (QUOTE DISPLAYTYPE))) TCPCHAT.TELNET.TTY.TYPES)) (CDR (FASSOC (fetch (CHATDISPLAYTYPE DPYNAME) of (STREAMPROP OUTPUTSTREAM (QUOTE DISPLAYTYPE))) TCPCHAT.TELNET.TTY.TYPES))))) (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM TELNET.SB) (BOUT OUTPUTSTREAM TELNET.TERMINAL.TYPE) (BOUT OUTPUTSTREAM TELNET.IS) (PRIN1 DISPLAYTYPE OUTPUTSTREAM) (BOUT OUTPUTSTREAM TELNET.IAC) (BOUT OUTPUTSTREAM TELNET.SE) (FORCEOUTPUT OUTPUTSTREAM) (COND (TCPCHAT.TRACEFLG (printout TCPCHAT.TRACEFILE "SEND(BACK) IAC SB TERMINAL-TYPE IS " DISPLAYTYPE " IAC SE" T))))) (TELNET.IS (* ; "We told them we couldn't handle this - or would have had they asked...") (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS IS, which is an error: rest of command is:" T)) (WHILE (NEQ (SETQ COMMAND (\BUFFERED.BIN INPUTSTREAM)) TELNET.SE) DO (IF TCPCHAT.TRACEFLG THEN (PRIN1 (CHARACTER COMMAND) TCPCHAT.TRACEFILE))) (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE " SE" T))) (IF TCPCHAT.TRACEFLG THEN (printout TCPCHAT.TRACEFILE "REQUEST IS " COMMAND ", which is an error" T))))) ) ) (RPAQQ TCPCHAT.TELNET.TTY.TYPES ((DM2500 . DATAMEDIA-2500) (VT100 . DEC-VT100))) (RPAQQ TELNET.OPTIONS ((94 WONT WONT DONT DONT) (0 WILL WONT NIL DONT) (1 WONT WONT DO DO) (3 WILL WILL NIL NIL) (5 WONT WONT DONT DONT) (6 WILL NIL NIL NIL) (24 WILL NIL DONT NIL TCPCHAT.TERMINAL.TYPE))) (RPAQ? TCPCHAT.TRACEFLG ) (RPAQ? TCPCHAT.TRACEFILE ) (FILESLOAD (SYSLOAD) TCP CHAT) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD CHATDECLS) (RPAQQ TELNET.COMMANDS ((TELNET.SE 240) (TELNET.SB 250) (TELNET.WILL 251) (TELNET.WONT 252) (TELNET.DO 253) (TELNET.DONT 254) (TELNET.IAC 255) (TELNET.SEND 1) (TELNET.IS 0))) (DECLARE%: EVAL@COMPILE (RPAQQ TELNET.SE 240) (RPAQQ TELNET.SB 250) (RPAQQ TELNET.WILL 251) (RPAQQ TELNET.WONT 252) (RPAQQ TELNET.DO 253) (RPAQQ TELNET.DONT 254) (RPAQQ TELNET.IAC 255) (RPAQQ TELNET.SEND 1) (RPAQQ TELNET.IS 0) (CONSTANTS (TELNET.SE 240) (TELNET.SB 250) (TELNET.WILL 251) (TELNET.WONT 252) (TELNET.DO 253) (TELNET.DONT 254) (TELNET.IAC 255) (TELNET.SEND 1) (TELNET.IS 0)) ) (RPAQQ TELNET.MARKS ((TELNET.BINARY 0) (TELNET.ECHO 1) (TELNET.SUPPRESS.GOAHEAD 3) (TELNET.STATUS 5) (TELNET.TIMING.MARK 6) (TELNET.TERMINAL.TYPE 24))) (DECLARE%: EVAL@COMPILE (RPAQQ TELNET.BINARY 0) (RPAQQ TELNET.ECHO 1) (RPAQQ TELNET.SUPPRESS.GOAHEAD 3) (RPAQQ TELNET.STATUS 5) (RPAQQ TELNET.TIMING.MARK 6) (RPAQQ TELNET.TERMINAL.TYPE 24) (CONSTANTS (TELNET.BINARY 0) (TELNET.ECHO 1) (TELNET.SUPPRESS.GOAHEAD 3) (TELNET.STATUS 5) (TELNET.TIMING.MARK 6) (TELNET.TERMINAL.TYPE 24)) ) (DECLARE%: EVAL@COMPILE (RECORD TELNET.OPTION (OPTION ON.DO ON.DONT ON.WILL ON.WONT ON.SB)) (RECORD TELNET.OPTIONSTATE (OPTION WILLING DOING)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TCPCHAT.TELNET.TTY.TYPES TELNET.OPTIONS TELNET.MARKS) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR CHAT.PROTOCOLTYPES (TCP . TCPCHAT.HOST.FILTER)) (ADDTOVAR CHAT.PROTOCOL.ABBREVS (N . TCP) (T . TCP)) ) (PUTPROPS TCPCHAT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1430 8610 (TCPCHAT.BIN 1440 . 1698) (TCPCHAT.HOST.FILTER 1700 . 1857) ( TCPCHAT.NEGOTIATE 1859 . 2027) (TCPCHAT.OPEN 2029 . 3387) (TCPCHAT.OPTION.COMMAND 3389 . 4679) ( TCPCHAT.OPTION.INPUT 4681 . 5785) (TCPCHAT.OPTION.OUTPUT 5787 . 6188) (TCPCHAT.OPTION.TRACE 6190 . 6667) (TCPCHAT.TERMINAL.TYPE 6669 . 8608))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPCONFIG b/obsolete/tcp/TCPCONFIG deleted file mode 100644 index 257f8dd5..00000000 --- a/obsolete/tcp/TCPCONFIG +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP") (FILECREATED "12-Jun-90 16:11:50" {DSK}local>lde>lispcore>library>TCPCONFIG.;2 18742 changes to%: (VARS TCPCONFIGCOMS) previous date%: "18-Apr-88 21:05:32" {DSK}local>lde>lispcore>library>TCPCONFIG.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPCONFIGCOMS) (RPAQQ TCPCONFIGCOMS ((PROP MAKEFILE-ENVIRONMENT TCPCONFIG) (DECLARE%: EVAL@COMPILE DONTCOPY (COMS (RECORDS IPINIT)) (GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST)) (COMS (* TCP configuration module) (EXPORT (RECORDS IPINIT)) (INITVARS (\IP.DEFAULT.CONFIGURATION (create IPINIT)) (\IPFLG NIL)) (FILES TCPLLIP) (FNS TCP.CONFIGURE TCP.LIMITCHARS \TCPCONFIG.RESETFN \TCPCONFIG.QUITFN TCP.ALPHA.LIMITCHARS \TCPCONFIG.APPLYFN)))) (PUTPROPS TCPCONFIG MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP")) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST) ) ) (* TCP configuration module) (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER)) ) (* "END EXPORTED DEFINITIONS") (RPAQ? \IP.DEFAULT.CONFIGURATION (create IPINIT)) (RPAQ? \IPFLG NIL) (FILESLOAD TCPLLIP) (DEFINEQ (TCP.CONFIGURE [LAMBDA NIL (DECLARE (GLOBALVARS \IP.DEFAULT.CONFIGURATION)) (* ; "Edited 18-Mar-88 15:41 by bvm") (LET* ((CONFIG (OR (AND (INFILEP '{DSK}IP.INIT) (\IP.READ.INIT.FILE '{DSK}IP.INIT)) \IP.DEFAULT.CONFIGURATION (create IPINIT))) (TCP.FREEMENU (FREEMENU `((PROPS FONT (GACHA 12 BOLD)) ((PROPS BOX 2) (LABEL " " TYPE DISPLAY) (LABEL "Apply!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.APPLYFN) (LABEL " " TYPE DISPLAY) (LABEL "Reset!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.RESETFN) (LABEL " " TYPE DISPLAY) (LABEL "Quit!" TYPE MOMENTARY SELECTEDFN \TCPCONFIG.QUITFN) (LABEL " " TYPE DISPLAY)) ((LABEL "" TYPE DISPLAY)) ((LABEL " Host Name:" TYPE EDITSTART MESSAGE "Enter the name of this host" LINKS (EDIT HOST.NAME)) (LABEL ,(OR (fetch (IPINIT HOSTNAME) of CONFIG) "") FONT (GACHA 12) TYPE EDIT ID HOST.NAME LIMITCHARS TCP.ALPHA.LIMITCHARS)) ((LABEL " Host Address:" TYPE EDITSTART MESSAGE "Enter the IP address of this host. Format: 13.0.10.5" LINKS (EDIT ADDRESS)) (LABEL ,(OR (CAR (fetch (IPINIT LOCAL.ADDRESSES) of CONFIG)) "") FONT (GACHA 12) TYPE EDIT ID ADDRESS LIMITCHARS TCP.LIMITCHARS)) ((LABEL "Network Address:" TYPE EDITSTART MESSAGE "Enter the IP address of the local network. Format: 13.0.0.0 Leave the host address fields 0." LINKS (EDIT NETWORK.ADDRESS)) (LABEL ,(OR (CAAR (fetch (IPINIT LOCAL.NETWORKS) of CONFIG)) "") FONT (GACHA 12) TYPE EDIT ID NETWORK.ADDRESS LIMITCHARS TCP.LIMITCHARS)) ((LABEL " Subnet mask:" TYPE EDITSTART MESSAGE "Enter the subnet mask. Format: 13.255.252.0 If the bitwise-AND of this address and any destination IP address is not equal to the bitwise-AND of this address and the host's local IP address, the destination IP address will be considered to be on another (sub)network" LINKS (EDIT SUBNET.MASK)) (LABEL ,(OR (CAR (fetch (IPINIT SUBNETMASK) of CONFIG)) "") FONT (GACHA 12) TYPE EDIT ID SUBNET.MASK LIMITCHARS TCP.LIMITCHARS)) ((LABEL "Default Gateway:" TYPE EDITSTART MESSAGE "Enter the IP address of the default gateway for this host. Format 13.0.10.34" LINKS (EDIT DEFAULT.GATEWAY)) (LABEL ,(OR (fetch (IPINIT DEFAULT.GATEWAY) of CONFIG) "") FONT (GACHA 12) TYPE EDIT ID DEFAULT.GATEWAY LIMITCHARS TCP.ALPHA.LIMITCHARS)) ((LABEL " Local Domain:" TYPE EDITSTART MESSAGE "Enter the name of the Internet domain in which this host resides" LINKS (EDIT LOCAL.DOMAIN)) (LABEL ,(OR (fetch (IPINIT LOCAL.DOMAIN) of CONFIG) "") FONT (GACHA 12) TYPE EDIT ID LOCAL.DOMAIN LIMITCHARS TCP.ALPHA.LIMITCHARS)) ((LABEL " Domain servers:" TYPE EDITSTART MESSAGE "Enter the IP addresses of the local domain servers. Format 13.0.10.21 12.0.15.22 ..." LINKS (EDIT DOMAIN.SERVERS)) (LABEL ,(if (fetch (IPINIT DOMAIN.SERVERS) of CONFIG) then (for ADDRESS in (fetch (IPINIT DOMAIN.SERVERS ) of CONFIG) bind (STRING _ "") do (SETQ STRING (CONCAT STRING ADDRESS " ")) finally (RETURN (SUBSTRING STRING 1 -2))) else "") FONT (GACHA 12) TYPE EDIT ID DOMAIN.SERVERS LIMITCHARS TCP.ALPHA.LIMITCHARS)) ((LABEL " Hosts.txt file:" TYPE EDITSTART MESSAGE "Enter the name of the Hosts.txt file to be used for translating IP hostnames to IP host addresses." LINKS (EDIT HOSTS.FILE)) (LABEL ,(OR (fetch (IPINIT HTE.FILE) of CONFIG) "") FONT (GACHA 12) TYPE EDIT ID HOSTS.FILE LIMITCHARS TCP.ALPHA.LIMITCHARS))) "TCP Configuration")) (REG (WINDOWPROP TCP.FREEMENU 'REGION)) (WIDTH (fetch (REGION WIDTH) of REG)) (HEIGHT (fetch (REGION HEIGHT) of REG))) (WINDOWPROP TCP.FREEMENU 'MINSIZE (CONS WIDTH HEIGHT)) (WINDOWPROP TCP.FREEMENU 'MAXSIZE (CONS 65535 HEIGHT)) (MOVEW TCP.FREEMENU (GETBOXPOSITION WIDTH HEIGHT)) (OPENW TCP.FREEMENU) NIL]) (TCP.LIMITCHARS [LAMBDA (ITEM WINDOW CHARACTER) (* ; "Edited 20-Jan-88 15:37 by Snow") (* ;; "allows numbers or periods until a CR then skips to the next item in the menu.") (COND ((FMEMB CHARACTER '(0 1 2 3 4 5 6 7 8 9 %.)) T) ((EQ (CHARACTER (CHARCODE EOL)) CHARACTER) (FM.SKIPNEXT WINDOW)) (T NIL]) (\TCPCONFIG.RESETFN (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 18-Jan-88 18:32 by Briggs") (AND (GETPROMPTWINDOW WINDOW) (CLEARW (GETPROMPTWINDOW WINDOW))) (FM.RESETMENU WINDOW)) ) (\TCPCONFIG.QUITFN (LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 18-Jan-88 15:40 by Briggs") (FM.ENDEDIT WINDOW) (CLOSEW WINDOW)) ) (TCP.ALPHA.LIMITCHARS [LAMBDA (ITEM WINDOW CHAR) (* ; "Edited 20-Jan-88 15:32 by Snow") (* ;; "This function will allow all characters until a CR then call Fm.Skipnext to move on to the next entry in the table.") (IF (EQ (CHARACTER (CHARCODE CR)) CHAR) THEN (FM.SKIPNEXT WINDOW) ELSE T]) (\TCPCONFIG.APPLYFN [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 18-Mar-88 18:37 by bvm") (* ;; "Before reseting any of the parameters, verify their validity") (FM.ENDEDIT WINDOW) (PROG ((STATE (FM.GETSTATE WINDOW)) (FMPROMPTWINDOW (GETPROMPTWINDOW WINDOW 3)) (CONFIG (create IPINIT LOCAL.NSHOSTNUMBER _ \MY.NSHOSTNUMBER)) IPADDRESS SCRATCH) (* ;; "Before reseting any of the parameters, verify their validity") (CLEARW FMPROMPTWINDOW) (* ;; "So we don't have to check later...") (if (NOT (OR \10MBLOCALNDB \3MBLOCALNDB)) then (printout FMPROMPTWINDOW "This machine doesn't appear to be on any networks!") (RETURN)) (* ;; "") (* ;; "Host name is required") (* ;; "") (SETQ SCRATCH (LISTGET STATE 'HOST.NAME)) (if (STRING-EQUAL SCRATCH "") then (printout FMPROMPTWINDOW "Host name is required!") (FM.EDITITEM (FM.GETITEM 'HOST.NAME NIL WINDOW) WINDOW) (RETURN)) (replace (IPINIT HOSTNAME) of CONFIG with SCRATCH) (* ;; "") (* ;; " Verify host address") (* ;; "") (SETQ SCRATCH (LISTGET STATE 'ADDRESS)) (if (STRING-EQUAL SCRATCH "") then (printout FMPROMPTWINDOW "Host address is required!") (FM.EDITITEM (FM.GETITEM 'ADDRESS NIL WINDOW) WINDOW) (RETURN) elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH))) (ZEROP (\IPNETADDRESS IPADDRESS))) then (printout FMPROMPTWINDOW "Malformed host address: " SCRATCH) (FM.EDITITEM (FM.GETITEM 'ADDRESS NIL WINDOW) WINDOW) (RETURN)) (replace (IPINIT LOCAL.ADDRESSES) of CONFIG with (LIST (\IP.ADDRESS.TO.STRING IPADDRESS))) (* ;; "") (* ;; "Verify network address. The list is an alist keyed by network address, and containing the atom 10 or 3 indicating the kind of network. We assume the host is only on one network.") (* ;; "") (SETQ SCRATCH (LISTGET STATE 'NETWORK.ADDRESS)) (if (STRING-EQUAL SCRATCH "") then (printout FMPROMPTWINDOW "Network address is required!") (FM.EDITITEM (FM.GETITEM 'NETWORK.ADDRESS NIL WINDOW) WINDOW) (RETURN) elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH))) (ZEROP (\IPNETADDRESS IPADDRESS))) then (printout FMPROMPTWINDOW "Malformed network address: " SCRATCH) (FM.EDITITEM (FM.GETITEM 'NETWORK.ADDRESS NIL WINDOW) WINDOW) (RETURN)) [replace (IPINIT LOCAL.NETWORKS) of CONFIG with (LIST (CONS (\IP.ADDRESS.TO.STRING IPADDRESS) (if \10MBLOCALNDB then 10 else 3] (* ;; "") (* ;; " Verify subnet mask") (* ;; "") (SETQ SCRATCH (LISTGET STATE 'SUBNET.MASK)) (if (STRING-EQUAL SCRATCH "") then (printout FMPROMPTWINDOW "Subnet mask is required!") (FM.EDITITEM (FM.GETITEM 'SUBNET.MASK NIL WINDOW) WINDOW) (RETURN) elseif (OR (NULL (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH))) (ZEROP (\IPNETADDRESS IPADDRESS))) then (printout FMPROMPTWINDOW "Malformed subnet mask: " SCRATCH) (FM.EDITITEM (FM.GETITEM 'SUBNET.MASK NIL WINDOW) WINDOW) (RETURN)) (replace (IPINIT SUBNETMASK) of CONFIG with (LIST (\IP.ADDRESS.TO.STRING IPADDRESS))) (* ;; "") (* ;; "Verify default gateway, may be empty if none.") (* ;; "") (SETQ SCRATCH (LISTGET STATE 'DEFAULT.GATEWAY)) (if (STRING-EQUAL SCRATCH "") then (SETQ IPADDRESS NIL) elseif (NOT (SETQ IPADDRESS (\IP.READ.STRING.ADDRESS SCRATCH))) then (printout FMPROMPTWINDOW "Malformed default gateway address: " SCRATCH) (FM.EDITITEM (FM.GETITEM 'DEFAULT.GATEWAY NIL WINDOW) WINDOW) (RETURN)) (replace (IPINIT DEFAULT.GATEWAY) of CONFIG with (AND IPADDRESS ( \IP.ADDRESS.TO.STRING IPADDRESS))) (* ;; "") (* ;; "Local domain. May be empty.") (* ;; "") (SETQ SCRATCH (LISTGET STATE 'LOCAL.DOMAIN)) (if (STRING-EQUAL SCRATCH "") then (SETQ SCRATCH NIL)) (replace (IPINIT LOCAL.DOMAIN) of CONFIG with SCRATCH) (* ;; "") (* ;; "Verify domain server address(es) are well formed.") (* ;; "") (SETQ SCRATCH (LISTGET STATE 'DOMAIN.SERVERS)) (if (STRING-EQUAL SCRATCH "") then (SETQ IPADDRESS NIL) else [SETQ IPADDRESS (bind (END _ 0) (BITTABLE _ (MAKEBITTABLE (LIST (CHARCODE SPACE)) T)) (START _ NIL) eachtime [SETQ START (STRPOSL BITTABLE SCRATCH (ADD1 (OR END 65534] (SETQ END (STRPOS " " SCRATCH START)) until (NULL START) collect (\IP.READ.STRING.ADDRESS (SUBSTRING SCRATCH (OR START 1) END] (if (FMEMB NIL IPADDRESS) then (printout FMPROMPTWINDOW "Malformed domain server addresses: " SCRATCH ) (FM.EDITITEM (FM.GETITEM 'DOMAIN.SERVERS NIL WINDOW) WINDOW) (RETURN))) [replace (IPINIT DOMAIN.SERVERS) of CONFIG with (AND IPADDRESS (for ADDR in IPADDRESS collect ( \IP.ADDRESS.TO.STRING ADDR] (* ;; "") (* ;; "Hosts.txt file (may not yet exist)") (* ;; "") (SETQ SCRATCH (LISTGET STATE 'HOSTS.FILE)) (if (if (NOT (STRING-EQUAL SCRATCH "")) elseif (NOT *IP-DEFAULT-HOSTS-FILE*) then (* ;  "If there's a site default, we can leave this empty for flexibility") (FM.CHANGESTATE (FM.GETITEM 'HOSTS.FILE NIL WINDOW) (SETQ SCRATCH "{DSK}HOSTS.TXT") WINDOW) T) then (replace (IPINIT HTE.FILE) of CONFIG with SCRATCH)) (* ;; "") (* ;; "write the information back on the IP.INIT file") (* ;; "") (printout FMPROMPTWINDOW "Writing {dsk}ip.init... ") [LET ((*UPPER-CASE-FILE-NAMES* NIL)) (CL:WITH-OPEN-FILE (STREAM '{DSK}IP.INIT :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (PRIN2 CONFIG STREAM (FIND-READTABLE "INTERLISP"] (printout FMPROMPTWINDOW "done.") (* ;; "") (* ;; "See if they want to restart TCP with the new configuration.") (* ;; "") (COND ((AND \IPFLG (MOUSECONFIRM "Restart TCP with the new values?" NIL FMPROMPTWINDOW T)) (* ;  "tcp is running and they want it restarted.") (PRINTOUT FMPROMPTWINDOW T "Restarting...") (STOPIP) (SETQ \IP.DEFAULT.CONFIGURATION NIL) (\IPINIT) (* ;; "let the user know we are done.") (PRINTOUT FMPROMPTWINDOW "done."]) ) (PUTPROPS TCPCONFIG COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2032 18633 (TCP.CONFIGURE 2042 . 7956) (TCP.LIMITCHARS 7958 . 8375) (\TCPCONFIG.RESETFN 8377 . 8561) (\TCPCONFIG.QUITFN 8563 . 8695) (TCP.ALPHA.LIMITCHARS 8697 . 9098) (\TCPCONFIG.APPLYFN 9100 . 18631))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPDEBUG b/obsolete/tcp/TCPDEBUG deleted file mode 100644 index 1b0b73dd..00000000 --- a/obsolete/tcp/TCPDEBUG +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "23-Aug-90 17:10:14" {DSK}TCP>TCPDEBUG.;2 27328 changes to%: (VARS TCPDEBUGCOMS) previous date%: "15-Feb-89 13:41:39" {DSK}TCP>TCPDEBUG.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPDEBUGCOMS) (RPAQQ TCPDEBUGCOMS ((COMS (* ;; "standard TCP small servers") (FNS TCP.SINK.SERVER TCP.TELNET.SERVER \TCP.SINK.PROCESS TCP.ECHO.SERVER \TCP.ECHO.PROCESS)) (COMS (* ;; "TCP tracing and debugging info") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) TCP) (CONSTANTS LIGHTGRAYSHADE)) (GLOBALVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME \TCP.DEBUGGABLE) (INITVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME NETTRACETITLEREG) (VARS (\TCP.DEBUGGABLE T)) (BITMAPS NETTRACEICON NETTRACEMASK) (FILES (SYSLOAD) TCP) (FNS TCP.PRINT.SEGMENT \TCP.PRINT.OPTIONS \TCP.PRINT.ELAPSED.TIME \TCP.PRINT.SEGMENT.QUEUE TCPTRACE \TCPTRACEMENU.ITEMFN \TCPTRACEMENU.DISPLAYFN TCP.DRIBBLE)) (COMS (* ;; "miscellaneous TCP debugging") (GLOBALVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT \TCP.MASTER.SOCKET) (INITVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT) (FNS TCP.DEBUG TCP.WATCHER DUMMY\IP\Transmit\Packet \TCP.CHECK.INPUT.QUEUE TCP.FAUCET TCP.ECHOTEST TCP.QUIET.ECHOTEST TCP.SINKTEST GENERATE.RANDOM.CHARS COPYBYTESTREAM TCP.COPYTOWINDOW TEST.CHECKSUM)))) (* ;; "standard TCP small servers") (DEFINEQ (TCP.SINK.SERVER [LAMBDA (PORT) (* ecc "14-May-84 16:32") (bind STREAM do (if (SETQ STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT) 'PASSIVE 'INPUT T)) then (ADD.PROCESS `(\TCP.SINK.PROCESS %, STREAM) 'NAME "TCP Sink"]) (TCP.TELNET.SERVER [LAMBDA NIL (* ejs%: "20-Jun-85 12:38") (LET ((INSTREAM (TCP.OPEN NIL NIL \TCP.TELNET.PORT 'PASSIVE 'INPUT)) OUTSTREAM) (COND (INSTREAM (SETQ OUTSTREAM (TCP.OTHER.STREAM INSTREAM)) (ADD.PROCESS (LIST '\TCP.ECHO.PROCESS (KWOTE INSTREAM) (KWOTE OUTSTREAM)) 'NAME "Telnet echo") (ADD.PROCESS '(TCP.TELNET.SERVER)) (GENERATE.RANDOM.CHARS OUTSTREAM]) (\TCP.SINK.PROCESS [LAMBDA (STREAM) (* ejs%: " 7-Jun-85 13:11") (RESETSAVE NIL (LIST (FUNCTION CLOSEF) STREAM)) (replace (STREAM ENDOFSTREAMOP) of STREAM with (FUNCTION NILL)) (until (EOFP STREAM) do (BIN STREAM]) (TCP.ECHO.SERVER [LAMBDA (PORT) (* ecc "14-May-84 16:35") (bind STREAM do (if (SETQ STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.ECHO.PORT) 'PASSIVE 'INPUT T)) then (ADD.PROCESS `(\TCP.ECHO.PROCESS %, STREAM %, (TCP.OTHER.STREAM STREAM)) 'NAME "TCP Echo"]) (\TCP.ECHO.PROCESS [LAMBDA (INSTR OUTSTR) (* ejs%: "25-Mar-86 18:07") (RESETSAVE NIL (LIST (FUNCTION CLOSEF) INSTR)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF) OUTSTR)) (bind C until (OR (NOT (OPENP INSTR 'INPUT)) (EOFP INSTR)) do [COND [(CAR (NLSETQ (READP INSTR))) (SETQ C (CAR (NLSETQ (BIN INSTR] (T (FORCEOUTPUT OUTSTR) (SETQ C (CAR (NLSETQ (BIN INSTR] [COND (C (NLSETQ (BOUT OUTSTR C] (if (OR (NOT (NLSETQ (READP INSTR))) (NOT (OPENP INSTR 'INPUT)) (EOFP INSTR)) then (NLSETQ (FORCEOUTPUT OUTSTR]) ) (* ;; "TCP tracing and debugging info") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) TCP) (DECLARE%: EVAL@COMPILE (RPAQQ LIGHTGRAYSHADE 1025) (CONSTANTS LIGHTGRAYSHADE) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TCPTRACEFLG TCPTRACEFILE TCPTRACEMENU \TCP.ELAPSED.TIME \TCP.DEBUGGABLE) ) (RPAQ? TCPTRACEFLG NIL) (RPAQ? TCPTRACEFILE NIL) (RPAQ? TCPTRACEMENU NIL) (RPAQ? \TCP.ELAPSED.TIME NIL) (RPAQ? NETTRACETITLEREG NIL) (RPAQQ \TCP.DEBUGGABLE T) (RPAQQ NETTRACEICON #*(72 72)AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@G@@@@@@@@@@@@@@@G@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@F@@@@@@@@@@@@@@@C@@@G@@@@@@@@@@@@@@@G@@@COOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@F@@@DIBDL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@@@@@L@@@@@L@@@@@F@@@@@@@L@@@@@N@@@@@F@@@@@@@L@@@@@K@@@@@GH@@@@@CLCOOOOIH@@@@F@@@@@@@LGOOOOHL@@@@F@@@@@@@LD@@@@@F@@@@F@@@@@@@LD@@@@@C@@@@GOOOOOOOLD@@@@@A@@@@F@@@@@@@LD@@@@@B@@@@F@@@@@@@LD@@@@@D@@@@F@@@@@@@LGOOOOHH@@@@GH@@@@@CL@@@@@I@@@@@F@@@@@@@L@@@@@J@@@@@F@@@@@@@L@@@@@L@@@@@F@@@@@@@L@@@@@H@@@@@GH@@@@@CL@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@D@@@@@@@@F@@@@@@@L@@L@@@@@@@@F@@@@@@@L@AL@@@@@@@@F@@@@@@@L@BL@@@@@@@@GH@@@@@CL@DOOOOOH@@@F@@@@@@@L@HOOOOOH@@@F@@@@@@@LA@@@@@AH@@@F@@@@@@@LB@@@@@AH@@@GOOOOOOOLD@@@@@AH@@@F@@@@@@@LB@@@@@AH@@@F@@@D@@@LA@@@@@AH@@@F@@@D@@@L@HOOOOO@@@@F@@@@@@@L@DL@@@@@@@@F@@@D@@@L@BL@@@@@@@@F@@@D@@@L@AL@@@@@@@@F@@@@@@@L@@H@@@@@@@@F@@@D@@@L@@@@@@@@@@@F@@@D@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@F@@@@@@@L@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@ ) (RPAQQ NETTRACEMASK #*(72 72)AOOOOOOOOOOOOOOOL@@@COOOOOOOOOOOOOOON@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@GOOOOOOOOOOOOOOOO@@@COOOOOOOOOOOOOOON@@@AOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@L@@@@@GOOOOOOOL@@@@@N@@@@@GOOOOOOOL@@@@@O@@@@@GOOOOOOOLCOOOOOH@@@@GOOOOOOOLGOOOOOL@@@@GOOOOOOOLGOOOOON@@@@GOOOOOOOLGOOOOOO@@@@GOOOOOOOLGOOOOOO@@@@GOOOOOOOLGOOOOON@@@@GOOOOOOOLGOOOOOL@@@@GOOOOOOOLGOOOOOH@@@@GOOOOOOOL@@@@@O@@@@@GOOOOOOOL@@@@@N@@@@@GOOOOOOOL@@@@@L@@@@@GOOOOOOOL@@@@@H@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@D@@@@@@@@GOOOOOOOL@@L@@@@@@@@GOOOOOOOL@AL@@@@@@@@GOOOOOOOL@CL@@@@@@@@GOOOOOOOL@GOOOOOH@@@GOOOOOOOL@OOOOOOH@@@GOOOOOOOLAOOOOOOH@@@GOOOOOOOLCOOOOOOH@@@GOOOOOOOLGOOOOOOH@@@GOOOOOOOLCOOOOOOH@@@GOOOOOOOLAOOOOOOH@@@GOOOOOOOL@OOOOOO@@@@GOOOOOOOL@GL@@@@@@@@GOOOOOOOL@CL@@@@@@@@GOOOOOOOL@AL@@@@@@@@GOOOOOOOL@@H@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@GOOOOOOOL@@@@@@@@@@@ ) (FILESLOAD (SYSLOAD) TCP) (DEFINEQ (TCP.PRINT.SEGMENT [LAMBDA (SEGMENT FILE NOFROMTOFLG DATAFLG) (* ejs%: "20-Jun-85 16:06") (PROG ((SEPR "") (COMMA ",") (SEQ (fetch TCP.SEQ of SEGMENT)) (LEN (\TCP.DATA.LENGTH SEGMENT)) (FLAGS (fetch TCP.CTRL of SEGMENT)) TOP BASE) (if (NOT NOFROMTOFLG) then (printout FILE "from " %# (\IP.PRINT.ADDRESS (fetch TCP.SRC.ADDR of SEGMENT) FILE) ":" (fetch TCP.SRC.PORT of SEGMENT) " to " %# (\IP.PRINT.ADDRESS (fetch TCP.DST.ADDR of SEGMENT) FILE) ":" (fetch TCP.DST.PORT of SEGMENT) T)) (printout FILE SEQ) [SETQ TOP (SUB1 (IPLUS SEQ LEN (\TCP.SYN.OR.FIN FLAGS T] (if (\32BIT.LT SEQ TOP) then (printout FILE ".." TOP)) (printout FILE "/" (fetch TCP.ACK of SEGMENT) " [") (if (BITTEST FLAGS \TCP.CTRL.URG) then (printout FILE SEPR "URG") (SETQ SEPR COMMA)) (if (BITTEST FLAGS \TCP.CTRL.ACK) then (printout FILE SEPR "ACK") (SETQ SEPR COMMA)) (if (BITTEST FLAGS \TCP.CTRL.PSH) then (printout FILE SEPR "PSH") (SETQ SEPR COMMA)) (if (BITTEST FLAGS \TCP.CTRL.RST) then (printout FILE SEPR "RST") (SETQ SEPR COMMA)) (if (BITTEST FLAGS \TCP.CTRL.SYN) then (printout FILE SEPR "SYN") (SETQ SEPR COMMA)) (if (BITTEST FLAGS \TCP.CTRL.FIN) then (printout FILE SEPR "FIN") (SETQ SEPR COMMA)) (printout FILE "] window = " (fetch TCP.WINDOW of SEGMENT) " checksum = " (fetch TCP.CHECKSUM of SEGMENT) " length = " LEN T) (if (IGREATERP (fetch TCP.DATA.OFFSET of SEGMENT) \TCP.MIN.DATA.OFFSET) then (\TCP.PRINT.OPTIONS SEGMENT FILE)) (if (AND DATAFLG (NOT (ZEROP LEN))) then (printout FILE "Contents:") (SETQ BASE (fetch TCP.CONTENTS of SEGMENT)) (for (I _ 0) to (SUB1 LEN) do (PRIN1 (CHARACTER (\GETBASEBYTE BASE I)) FILE)) (TERPRI FILE]) (\TCP.PRINT.OPTIONS [LAMBDA (SEGMENT FILE) (* ejs%: "20-Jun-85 13:22") (* * Process the options in a TCP header) (printout FILE "Options: ") (bind (OPTIONBASE _ (fetch (TCPSEGMENT TCP.OPTIONS) of SEGMENT)) (OPTIONOFFSET _ 0) OPTION eachtime (SETQ OPTION (\GETBASEBYTE OPTIONBASE OPTIONOFFSET)) until (EQ OPTION \TCPOPT.END) do (SELECTC OPTION (\TCPOPT.END (printout FILE "end") (add OPTIONOFFSET 1)) (\TCPOPT.NOP (printout FILE "nop") (add OPTIONOFFSET 1)) (\TCPOPT.MAXSEG [printout FILE "maxseg: " (LOGOR (LLSH (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 2)) BITSPERBYTE) (\GETBASEBYTE OPTIONBASE (IPLUS OPTIONOFFSET 3] (add OPTIONOFFSET (\GETBASEBYTE OPTIONBASE (ADD1 OPTIONOFFSET)))) (RETURN)) (printout FILE " "]) (\TCP.PRINT.ELAPSED.TIME [LAMBDA (FILE) (* ecc "23-Apr-84 12:32") (if (MEMB 'TIME TCPTRACEFLG) then (PROG ((NOW (SETUPTIMER 0 NIL 'MILLISECONDS)) INTERVAL) (SETQ INTERVAL (IDIFFERENCE NOW (OR \TCP.ELAPSED.TIME NOW))) (SETQ \TCP.ELAPSED.TIME NOW) (printout FILE (IQUOTIENT INTERVAL 1000) "." |.I3..T| (IMOD INTERVAL 1000) " "]) (\TCP.PRINT.SEGMENT.QUEUE [LAMBDA (CALLER QUEUE FILE) (* ecc "18-Apr-84 14:38") (PROG ((SEGMENT (fetch SYSQUEUEHEAD of QUEUE))) (printout FILE .TAB0 0 CALLER ":" T) (while SEGMENT do (TCP.PRINT.SEGMENT SEGMENT FILE T) (SETQ SEGMENT (fetch QLINK of SEGMENT]) (TCPTRACE [LAMBDA NIL (* ; "Edited 15-Apr-87 15:22 by jrb:") (PROG (MW) (if (WINDOWP TCPTRACEFILE) then (TOTOPW TCPTRACEFILE) (RETURN)) (SETQ TCPTRACEFILE (CREATEW)) [WINDOWADDPROP TCPTRACEFILE 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) (if (EQ WINDOW TCPTRACEFILE) then (SETQ TCPTRACEFLG NIL) (SETQ TCPTRACEFILE T] (DSPFONT (FONTCREATE 'GACHA 8) TCPTRACEFILE) (DSPSCROLL T TCPTRACEFILE) [if (NOT (type? MENU TCPTRACEMENU)) then (SETQ TCPTRACEMENU (create MENU TITLE _ "TCP Trace Window" ITEMS _ '(("Incoming" RECV "Trace incoming segments") ("Time" TIME "Print elapsed time between events") ("Transitions" TRANSITION "Trace connection state transitions") ("Outgoing" SEND "Trace outgoing segments") ("Contents" CONTENTS "Print contents of segments when tracing" ) ("Checksums" CHECKSUM "Trace segments with bad checksums")) MENUROWS _ 2 CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION \TCPTRACEMENU.ITEMFN))) else (FOR ITEM IN (FETCH (MENU ITEMS) OF TCPTRACEMENU) DO (IF (MEMB (CADR ITEM) TCPTRACEFLG) THEN (SHADEITEM ITEM TCPTRACEMENU LIGHTGRAYSHADE) ELSE (SHADEITEM ITEM TCPTRACEMENU WHITESHADE] (ATTACHMENU TCPTRACEMENU TCPTRACEFILE 'TOP) [SETQ MW (CAR (WINDOWPROP TCPTRACEFILE 'ATTACHEDWINDOWS] (WINDOWADDPROP MW 'REPAINTFN (FUNCTION \TCPTRACEMENU.DISPLAYFN)) (WINDOWADDPROP MW 'RESHAPEFN (FUNCTION \TCPTRACEMENU.DISPLAYFN]) (\TCPTRACEMENU.ITEMFN [LAMBDA (ITEM MENU MOUSEKEY) (* ecc "23-Apr-84 13:37") (PROG (FLG) (if (NULL ITEM) then (RETURN)) (SETQ FLG (CADR ITEM)) (if (MEMB FLG TCPTRACEFLG) then (SHADEITEM ITEM MENU WHITESHADE) (SETQ TCPTRACEFLG (DREMOVE FLG TCPTRACEFLG)) else (SHADEITEM ITEM MENU LIGHTGRAYSHADE) (SETQ TCPTRACEFLG (CONS FLG TCPTRACEFLG]) (\TCPTRACEMENU.DISPLAYFN [LAMBDA (WINDOW) (* ecc "23-Apr-84 13:49") (PROG [(MENU (CAR (WINDOWPROP WINDOW 'MENU] (for ITEM in (fetch ITEMS of MENU) when (MEMB (CADR ITEM) TCPTRACEFLG) do (SHADEITEM ITEM MENU LIGHTGRAYSHADE]) (TCP.DRIBBLE [LAMBDA (FORM FILE) (* ecc "18-Apr-84 14:39") (if (NULL FILE) then (SETQ FILE '{DSK}TCP.Transcript)) (RESETLST (RESETSAVE TCPTRACEFILE (OPENFILE FILE 'OUTPUT)) (RESETSAVE TCPTRACEFLG T) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) TCPTRACEFILE)) (PRINT FORM TCPTRACEFILE) (TERPRI TCPTRACEFILE) (EVAL FORM]) ) (* ;; "miscellaneous TCP debugging") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TCP.LOSSAGE \TCP.LOOPBACK.QUEUE \TCP.LOOPBACK.EVENT \TCP.MASTER.SOCKET) ) (RPAQ? \TCP.LOSSAGE NIL) (RPAQ? \TCP.LOOPBACK.QUEUE NIL) (RPAQ? \TCP.LOOPBACK.EVENT NIL) (DEFINEQ (TCP.DEBUG [LAMBDA (ON?) (* edited%: "21-May-84 13:56") (if ON? then (TCP.STOP) (if (NOT (DEFINEDP 'REAL\IP\Transmit\Packet)) then (MOVD 'IP\Transmit\Packet 'REAL\IP\Transmit\Packet)) (MOVD 'DUMMY\IP\Transmit\Packet 'IP\Transmit\Packet) (if (NULL \TCP.LOOPBACK.EVENT) then (SETQ \TCP.LOOPBACK.EVENT (CREATE.EVENT))) (if (NULL \TCP.LOOPBACK.QUEUE) then (SETQ \TCP.LOOPBACK.QUEUE (create SYSQUEUE))) [if (NOT (FIND.PROCESS 'TCP.WATCHER)) then (ADD.PROCESS '(TCP.WATCHER] else (if (DEFINEDP 'REAL\IP\Transmit\Packet) then (MOVD 'REAL\IP\Transmit\Packet 'IP\Transmit\Packet)) (DEL.PROCESS 'TCP.WATCHER) (\TCP.INIT]) (TCP.WATCHER [LAMBDA NIL (* ecc " 3-May-84 11:10") (* process to handle software loopback  of segments) (RESETSAVE NIL (LIST (FUNCTION \FLUSH.PACKET.QUEUE) \TCP.LOOPBACK.QUEUE)) (bind SEGMENT do (SETQ SEGMENT (\DEQUEUE \TCP.LOOPBACK.QUEUE)) (if SEGMENT then (\TCP.PACKET.FILTER SEGMENT \TCP.PROTOCOL) else (AWAIT.EVENT \TCP.LOOPBACK.EVENT]) (DUMMY\IP\Transmit\Packet [LAMBDA (EPKT) (* ejs%: " 5-Jan-85 16:57") (* Software loopback.) (PROG ([OK (NOT (AND \TCP.LOSSAGE (EQ (RAND 1 \TCP.LOSSAGE) 1] SEGMENT) (CHECK (OR (NULL (fetch QLINK of EPKT)) (SHOULDNT "transmitting queued segment"))) (if OK then (SETQ SEGMENT (\ALLOCATE.ETHERPACKET)) (\BLT (\IPDATABASE SEGMENT) (\IPDATABASE EPKT) (FOLDHI (ADD1 (fetch (IP IPTOTALLENGTH) of EPKT)) BYTESPERWORD))) (if (EQ (fetch EPREQUEUE of EPKT) 'FREE) then (\RELEASE.ETHERPACKET EPKT) elseif (type? SYSQUEUE (fetch EPREQUEUE of EPKT)) then (\ENQUEUE (fetch EPREQUEUE of EPKT) EPKT)) (if OK then (\ENQUEUE \TCP.LOOPBACK.QUEUE SEGMENT) (NOTIFY.EVENT \TCP.LOOPBACK.EVENT]) (\TCP.CHECK.INPUT.QUEUE [LAMBDA (TCB) (* edited%: "22-May-84 15:32") (* perform consistency check on the  input queue) (PROG ((QUEUE (fetch TCB.INPUT.QUEUE of TCB)) CURSEG SEQ1 TOP1 NEXTSEG SEQ2 TOP2) (SETQ CURSEG (fetch SYSQUEUEHEAD of QUEUE)) LOOP (if (NULL CURSEG) then (RETURN T)) (SETQ SEQ1 (fetch TCP.SEQ of CURSEG)) (SETQ TOP1 (IPLUS SEQ1 (fetch TCP.DATA.LENGTH of CURSEG))) (if (AND (\32BIT.LEQ SEQ1 (fetch TCB.RCV.NXT of TCB)) (\32BIT.GT TOP1 (fetch TCB.RCV.NXT of TCB))) then (SHOULDNT "incorrect RCV.NXT") (RETURN NIL)) (SETQ NEXTSEG (fetch QLINK of CURSEG)) (if (NULL NEXTSEG) then (RETURN T)) (SETQ SEQ2 (fetch TCP.SEQ of NEXTSEG)) (SETQ TOP2 (IPLUS SEQ2 (fetch TCP.DATA.LENGTH of NEXTSEG))) (if (\32BIT.LT SEQ2 SEQ1) then (SHOULDNT "input queue out of order") (RETURN NIL)) (SETQ CURSEG NEXTSEG) (GO LOOP]) (TCP.FAUCET [LAMBDA (HOST PORT NLINES) (* ejs%: "20-Jun-85 12:20") (PROG [(STREAM (if HOST then (TCP.OPEN HOST (OR PORT \TCP.SINK.PORT) NIL 'ACTIVE 'OUTPUT) else (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT) 'PASSIVE 'OUTPUT] (RESETLST (RESETSAVE NIL (LIST (FUNCTION CLOSEF) STREAM)) (GENERATE.RANDOM.CHARS STREAM NLINES]) (TCP.ECHOTEST [LAMBDA (HOST NLINES) (* ecc "14-May-84 17:07") (PROG [(STREAM (TCP.OPEN HOST \TCP.ECHO.PORT NIL 'ACTIVE 'OUTPUT] (ADD.PROCESS (BQUOTE (TCP.COPYTOWINDOW %, (TCP.OTHER.STREAM STREAM)) 'NAME "TCP Echo Tester")) (GENERATE.RANDOM.CHARS STREAM NLINES) (TCP.CLOSE.SENDER STREAM]) (TCP.QUIET.ECHOTEST [LAMBDA (HOST NLINES) (* ecc "25-May-84 13:24") (PROG [(STREAM (TCP.OPEN HOST \TCP.ECHO.PORT NIL 'ACTIVE 'OUTPUT] (ADD.PROCESS (BQUOTE (\TCP.SINK.PROCESS %, (TCP.OTHER.STREAM STREAM)) 'NAME "TCP Echo Tester")) (GENERATE.RANDOM.CHARS STREAM NLINES) (TCP.CLOSE.SENDER STREAM]) (TCP.SINKTEST [LAMBDA (PORT VISIBLEFLG) (* ecc "14-May-84 17:28") (TCP.COPYTOWINDOW (TCP.OPEN NIL NIL (OR PORT \TCP.SINK.PORT) 'PASSIVE 'INPUT) VISIBLEFLG]) (GENERATE.RANDOM.CHARS [LAMBDA (STREAM NLINES) (* ejs%: " 7-Jun-85 12:34") (bind (N _ 0) while (NEQ N NLINES) do (add N 1) (printout STREAM "This is byte number " (GETFILEPTR STREAM) "." T) (BLOCK]) (COPYBYTESTREAM [LAMBDA (INSTR OUTSTR VISIBLEFLG) (* ejs%: " 7-Jun-85 13:44") (if VISIBLEFLG then (bind (N _ 1) (C _ NIL) while (OPENP INSTR 'INPUT) do (SETQ C (BIN INSTR)) (printout OUTSTR N ": " C) (if (AND (ILEQ C 127) (IGEQ C 32)) then (printout OUTSTR " (" %# (BOUT OUTSTR C) ")")) (TERPRI OUTSTR) (add N 1)) else (bind C while (AND (OPENP INSTR 'INPUT) (NOT (EOFP INSTR))) do (COND ((SETQ C (BIN INSTR)) (BOUT OUTSTR C]) (TCP.COPYTOWINDOW [LAMBDA (STREAM VISIBLEFLG) (* ejs%: "13-Apr-85 16:01") (RESETLST (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) STREAM)) (PROG ((WIN (CREATEW NIL "Stream Output"))) (DSPSCROLL T WIN) (COPYBYTESTREAM STREAM WIN VISIBLEFLG) (printout WIN .TAB0 0 "[End of stream]"]) (TEST.CHECKSUM [LAMBDA (STR STR2) (* ecc "24-Apr-84 13:11") (if (NULL STR2) then (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE) of STR) (fetch (STRINGP OFFST) of STR)) (fetch (STRINGP LENGTH) of STR)) else (\16BIT.COMPLEMENT (\16BIT.1C.PLUS (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE) of STR) (fetch (STRINGP OFFST) of STR)) (fetch (STRINGP LENGTH) of STR) T) (\COMPUTE.CHECKSUM (\ADDBASE (fetch (STRINGP BASE) of STR2) (fetch (STRINGP OFFST) of STR2)) (fetch (STRINGP LENGTH) of STR2) T]) ) (PUTPROPS TCPDEBUG COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2530 5441 (TCP.SINK.SERVER 2540 . 2955) (TCP.TELNET.SERVER 2957 . 3546) ( \TCP.SINK.PROCESS 3548 . 3874) (TCP.ECHO.SERVER 3876 . 4356) (\TCP.ECHO.PROCESS 4358 . 5439)) (8951 18060 (TCP.PRINT.SEGMENT 8961 . 11702) (\TCP.PRINT.OPTIONS 11704 . 13026) (\TCP.PRINT.ELAPSED.TIME 13028 . 13561) (\TCP.PRINT.SEGMENT.QUEUE 13563 . 13945) (TCPTRACE 13947 . 16678) (\TCPTRACEMENU.ITEMFN 16680 . 17190) (\TCPTRACEMENU.DISPLAYFN 17192 . 17578) (TCP.DRIBBLE 17580 . 18058)) (18333 27228 ( TCP.DEBUG 18343 . 19261) (TCP.WATCHER 19263 . 19916) (DUMMY\IP\Transmit\Packet 19918 . 21136) ( \TCP.CHECK.INPUT.QUEUE 21138 . 22505) (TCP.FAUCET 22507 . 23175) (TCP.ECHOTEST 23177 . 23587) ( TCP.QUIET.ECHOTEST 23589 . 24006) (TCP.SINKTEST 24008 . 24288) (GENERATE.RANDOM.CHARS 24290 . 24690) ( COPYBYTESTREAM 24692 . 25563) (TCP.COPYTOWINDOW 25565 . 25990) (TEST.CHECKSUM 25992 . 27226))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPDOMAIN b/obsolete/tcp/TCPDOMAIN deleted file mode 100644 index 1e9b8354..00000000 --- a/obsolete/tcp/TCPDOMAIN +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 16:18:18" {DSK}local>lde>lispcore>library>TCPDOMAIN.;3 66928 changes to%: (VARS TCPDOMAINCOMS) previous date%: "28-Feb-89 18:35:51" {DSK}local>lde>lispcore>library>TCPDOMAIN.;2) (* ; " Copyright (c) 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPDOMAINCOMS) (RPAQQ TCPDOMAINCOMS ((COMS (* ;; "TCP/IP Domain resolver implementation. RFC882, RFC883, RFC973") ) (COMS (* ;; "UDP protocol functions") (DECLARE%: DONTCOPY (EXPORT (CONSTANTS (\UDPDOMAIN.WDS 6)) (RECORDS DOMAIN.HEADER))) (INITVARS (\UDPDOMAIN.IPSOCKET)) (GLOBALVARS \UDPDOMAIN.IPSOCKET) (FILES (SYSLOAD) TCPUDP) (FNS \UDPDOM.PROCESS.RESPONSE \UDPDOM.QUERY \UDPDOM.IPSOCKET)) (COMS (* ;; "Protocol independent functions") [DECLARE%: DONTCOPY (EXPORT (CONSTANTS * DOMAIN.OPCODES) (CONSTANTS * DOMAIN.RCODES) (CONSTANTS * DOMAIN.RRTYPES) (CONSTANTS * DOMAIN.CLASSTYPES) (CONSTANTS (\DOMAIN.PORT 53] (INITVARS (\DOMAIN.DEFAULT.SERVER)) (GLOBALVARS \DOMAIN.DEFAULT.SERVER) (FNS \DOMAIN.NAME \DOMAIN.PACK.NAME.LIST \DOMAIN.PARSE.NAME \DOMAIN.RCODE.ERROR \DOMAIN.PROCESS.REDIRECT \DOMAIN.PROCESS.RESPONSE \DOMAIN.PROCESS.RR \DOMAIN.READ.ADDRESS \DOMAIN.READ.NAME.FROM.STREAM \DOMAIN.READ.STRING.FROM.STREAM \DOMAIN.SEARCH.FOR.CANONICAL.NAME \DOMAIN.SKIP.NAME.IN.STREAM \DOMAIN.SKIP.QUESTION \DOMAIN.SKIP.RR)) (COMS (* ;; "Functions to maintain the domain tree structure") (RECORDS DOMAIN.TREE.NODE DOMAIN.SERVER) (INITRECORDS DOMAIN.TREE.NODE) (FNS USTRINGHASHBITS) (INITVARS (\DOMAIN.ROOT (create DOMAIN.TREE.NODE NAME _ "")) (\DOMAIN.NAMESERVERS (HASHARRAY 50 1.2 (FUNCTION USTRINGHASHBITS) (FUNCTION STRING-EQUAL))) (\DOMAIN.UNKNOWN.DOMAINS) (\DOMAIN.GC.INTERVAL 600000) (\DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL))) (GLOBALVARS \DOMAIN.ROOT \DOMAIN.NAMESERVERS \DOMAIN.UNKNOWN.DOMAINS \DOMAIN.GC.TIMER \DOMAIN.GC.INTERVAL) (FNS \DOMAIN.ADD.NEW.DOMAIN \DOMAIN.ADD.NAMESERVER \DOMAIN.AUGMENT.TREE \DOMAIN.CHOOSE.BEST.SERVERS \DOMAIN.FIND.DOMAIN.IN.TREE \DOMAIN.INIT \DOMAIN.INSERT.IN.TREE \DOMAIN.PATH \DOMAIN.SEARCH.RESOURCE.LIST \DOMAIN.DELETE.NAMESERVER \DOMAIN.AROUND.EXIT \DOMAIN.DELETE.TREE \DOMAIN.BACKGROUND \DOMAIN.GC.NAMESERVERS \DOMAIN.SORT.BY.SVC.TIME) (ADDVARS (BACKGROUNDFNS \DOMAIN.BACKGROUND))) (COMS (* ;; "Programmer's interface") (INITVARS (DOMAIN.TRACE.FLG) (DOMAIN.TRACE.FILE) (INTERNET.LOCAL.DOMAIN)) (GLOBALVARS DOMAIN.TRACE.FLG DOMAIN.TRACE.FILE INTERNET.LOCAL.DOMAIN) (FNS DOMAIN.INIT DOMAIN.LOOKUP.ADDRESS DOMAIN.LOOKUP.NAMESERVER DOMAIN.LOOKUP.OSTYPE DOMAIN.LOOKUP DOMAIN.GRAPH DOMAIN.NAME.EQUAL DOMAIN.TRACE DOMAIN.TRACEWINDOW.BUTTONFN)) (P (DOMAIN.INIT)))) (* ;; "TCP/IP Domain resolver implementation. RFC882, RFC883, RFC973") (* ;; "UDP protocol functions") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (RPAQQ \UDPDOMAIN.WDS 6) (CONSTANTS (\UDPDOMAIN.WDS 6)) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD DOMAIN.HEADER ((ID WORD) (RESPONSEFLG FLAG) (OPCODE BITS 4) (AUTHORITYFLG FLAG) (TRUNCATEDFLG FLAG) (WANTRECURSEFLG FLAG) (CANRECURSEFLG FLAG) (NIL BITS 3) (RESPONSECODE BITS 4) (QDCOUNT WORD) (ANCOUNT WORD) (NSCOUNT WORD) (ARCOUNT WORD))) ) (* "END EXPORTED DEFINITIONS") ) (RPAQ? \UDPDOMAIN.IPSOCKET ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \UDPDOMAIN.IPSOCKET) ) (FILESLOAD (SYSLOAD) TCPUDP) (DEFINEQ (\UDPDOM.PROCESS.RESPONSE [LAMBDA (DOMAIN.PATH RESPONSE) (* ejs%: " 5-Nov-86 13:38") (* * This function parses a query reponse packet) (LET ((RESPONSEBASE (fetch (UDP UDPCONTENTS) of RESPONSE))) (COND ((NEQ 0 (fetch (DOMAIN.HEADER ANCOUNT) of RESPONSEBASE)) (* * The response packet has the information we requested) (PROG1 (\DOMAIN.PROCESS.RESPONSE (\MAKEBASEBYTESTREAM RESPONSEBASE 0 (IDIFFERENCE (fetch (UDP UDPLENGTH) of RESPONSE) \UDPOVLEN) 'INPUT)) (\RELEASE.ETHERPACKET RESPONSE))) ((OR (NEQ 0 (fetch (DOMAIN.HEADER NSCOUNT) of RESPONSEBASE)) (NEQ 0 (fetch (DOMAIN.HEADER ARCOUNT) of RESPONSEBASE))) (* * The server we asked didn't know, but did tell us the name of a server  which might know) (PROG1 (\DOMAIN.PROCESS.REDIRECT (\MAKEBASEBYTESTREAM RESPONSEBASE 0 (IDIFFERENCE (fetch (UDP UDPLENGTH) of RESPONSE) \UDPOVLEN) 'INPUT)) (\RELEASE.ETHERPACKET RESPONSE))) (T (\RELEASE.ETHERPACKET RESPONSE) 'FAILED]) (\UDPDOM.QUERY [LAMBDA (DOMAIN TYPE CLASS SERVER) (* ejs%: " 5-Nov-86 13:40") (* * Make a domain query. Argument semantics should be self-evident if you've  read RFC882 and RFC883. Returns a list of answers, or atoms to indicate  failure--USE.TCP, etc) (LET* ((QUERY (\ALLOCATE.ETHERPACKET)) (ID (RAND 1 65534)) ANSWER DOMAINBASE) (* * Do basic QUERY initialization) (UDP.SETUP QUERY (OR SERVER \DOMAIN.DEFAULT.SERVER) \DOMAIN.PORT ID (\UDPDOM.IPSOCKET)) (SETQ DOMAINBASE (fetch (UDP UDPCONTENTS) of QUERY)) (* * Format header section) (replace (DOMAIN.HEADER ID) of DOMAINBASE with ID) (replace (DOMAIN.HEADER RESPONSEFLG) of DOMAINBASE with NIL) (replace (DOMAIN.HEADER AUTHORITYFLG) of DOMAINBASE with NIL) (replace (DOMAIN.HEADER TRUNCATEDFLG) of DOMAINBASE with NIL) (replace (DOMAIN.HEADER WANTRECURSEFLG) of DOMAINBASE with NIL) (replace (DOMAIN.HEADER CANRECURSEFLG) of DOMAINBASE with NIL) (replace (DOMAIN.HEADER OPCODE) of DOMAINBASE with DOMAIN.QUERY) (replace (DOMAIN.HEADER RESPONSECODE) of DOMAINBASE with 0) (replace (DOMAIN.HEADER QDCOUNT) of DOMAINBASE with 1) (replace (DOMAIN.HEADER ANCOUNT) of DOMAINBASE with 0) (replace (DOMAIN.HEADER NSCOUNT) of DOMAINBASE with 0) (replace (DOMAIN.HEADER ARCOUNT) of DOMAINBASE with 0) (UDP.INCREMENT.LENGTH QUERY (UNFOLD \UDPDOMAIN.WDS BYTESPERWORD)) (* * Add Query) [COND ((AND (NOT (NULL DOMAIN)) (NLISTP DOMAIN)) (SETQ DOMAIN (\DOMAIN.PARSE.NAME DOMAIN] (for NAME in DOMAIN do (UDP.APPEND.BYTE QUERY (NCHARS NAME)) (UDP.APPEND.STRING QUERY (MKSTRING NAME)) finally (UDP.APPEND.BYTE QUERY 0)) (UDP.APPEND.WORD QUERY TYPE) (UDP.APPEND.WORD QUERY CLASS) (* * Do the query) (bind RESPONSE RESPONSEBASE for I from 1 to \MAXETHERTRIES do (COND [(SETQ RESPONSE (UDP.EXCHANGE (\UDPDOM.IPSOCKET) QUERY 10000)) (SETQ RESPONSEBASE (fetch (UDP UDPCONTENTS) of RESPONSE)) (COND [(AND (EQ (fetch (DOMAIN.HEADER ID) of RESPONSEBASE) ID) (fetch (DOMAIN.HEADER RESPONSEFLG) of RESPONSEBASE)) (COND ((AND (fetch (DOMAIN.HEADER TRUNCATEDFLG) of RESPONSEBASE) (EQ (fetch (DOMAIN.HEADER ANCOUNT) of RESPONSEBASE) 0) (EQ (fetch (DOMAIN.HEADER NSCOUNT) of RESPONSEBASE) 0) (EQ (fetch (DOMAIN.HEADER RESPONSECODE) of RESPONSEBASE) RCODE.OK)) (SETQ ANSWER 'USE.TCP) (\RELEASE.ETHERPACKET RESPONSE) (GO $$OUT)) ((NEQ (fetch (DOMAIN.HEADER RESPONSECODE) of RESPONSEBASE) RCODE.OK) (SETQ ANSWER (\DOMAIN.RCODE.ERROR (fetch (DOMAIN.HEADER RESPONSECODE) of RESPONSEBASE))) (COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE "Error on query: " ANSWER))) (\RELEASE.ETHERPACKET RESPONSE) (GO $$OUT)) (T (SETQ ANSWER (\UDPDOM.PROCESS.RESPONSE DOMAIN RESPONSE)) (GO $$OUT] (T (\RELEASE.ETHERPACKET RESPONSE] (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE "Query to " (\IP.ADDRESS.TO.STRING (fetch (IP IPDESTINATIONADDRESS ) of QUERY) ) " timed out."))) finally (\RELEASE.ETHERPACKET QUERY) (RETURN ANSWER]) (\UDPDOM.IPSOCKET [LAMBDA NIL (* ejs%: "12-Apr-86 20:39") [COND ((NULL \UDPDOMAIN.IPSOCKET) (SETQ \UDPDOMAIN.IPSOCKET (UDP.OPEN.SOCKET))) ((NOT (\IP.FIND.SOCKET (fetch (IPSOCKET IPSOCKET) of \UDPDOMAIN.IPSOCKET) (\IP.FIND.PROTOCOL \UDP.PROTOCOL))) (SETQ \UDPDOMAIN.IPSOCKET (UDP.OPEN.SOCKET NIL 'ACCEPT] \UDPDOMAIN.IPSOCKET]) ) (* ;; "Protocol independent functions") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ DOMAIN.OPCODES ((DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3))) (DECLARE%: EVAL@COMPILE (RPAQQ DOMAIN.QUERY 0) (RPAQQ DOMAIN.IQUERY 1) (RPAQQ DOMAIN.CQUERYM 2) (RPAQQ DOMAIN.CQUERYU 3) (CONSTANTS (DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3)) ) (RPAQQ DOMAIN.RCODES ((RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) (RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5))) (DECLARE%: EVAL@COMPILE (RPAQQ RCODE.OK 0) (RPAQQ RCODE.FORMATERROR 1) (RPAQQ RCODE.SERVERFAILED 2) (RPAQQ RCODE.NAMEERROR 3) (RPAQQ RCODE.NOTIMPLEMENTED 4) (RPAQQ RCODE.REFUSED 5) (CONSTANTS (RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) (RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5)) ) (RPAQQ DOMAIN.RRTYPES ((RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (RRTYPE.SOA 6) (RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 12) (RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15))) (DECLARE%: EVAL@COMPILE (RPAQQ RRTYPE.A 1) (RPAQQ RRTYPE.NS 2) (RPAQQ RRTYPE.MD 3) (RPAQQ RRTYPE.MF 4) (RPAQQ RRTYPE.CNAME 5) (RPAQQ RRTYPE.SOA 6) (RPAQQ RRTYPE.MB 7) (RPAQQ RRTYPE.MG 8) (RPAQQ RRTYPE.MR 9) (RPAQQ RRTYPE.NULL 10) (RPAQQ RRTYPE.WKS 11) (RPAQQ RRTYPE.PTR 12) (RPAQQ RRTYPE.HINFO 13) (RPAQQ RRTYPE.MINFO 14) (RPAQQ RRTYPE.MX 15) (CONSTANTS (RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (RRTYPE.SOA 6) (RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 12) (RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15)) ) (RPAQQ DOMAIN.CLASSTYPES ((CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3))) (DECLARE%: EVAL@COMPILE (RPAQQ CLASSTYPE.IN 1) (RPAQQ CLASSTYPE.CSNET 2) (RPAQQ CLASSTYPE.CHAOS 3) (CONSTANTS (CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \DOMAIN.PORT 53) (CONSTANTS (\DOMAIN.PORT 53)) ) (* "END EXPORTED DEFINITIONS") ) (RPAQ? \DOMAIN.DEFAULT.SERVER ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DOMAIN.DEFAULT.SERVER) ) (DEFINEQ (\DOMAIN.NAME [LAMBDA (DOMAIN.TREE.NODE) (* ejs%: "13-Apr-86 15:38") (* * Generate a list of domain names along the path to the root of the domain  tree) (COND ((NULL (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE)) NIL) (T (LET [(SUFFIX (\DOMAIN.NAME (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE ] (COND (SUFFIX (CONCAT (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE) "." SUFFIX)) (T (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE]) (\DOMAIN.PACK.NAME.LIST [LAMBDA (LIST) (* ejs%: "12-Apr-86 20:29") (COND ((LISTP LIST) (LET [(DOMAIN.NAME (ALLOCSTRING (IPLUS (SUB1 (LENGTH LIST)) (for NAME in LIST sum (NCHARS NAME] [bind (I _ 1) for NAME in LIST do (RPLSTRING DOMAIN.NAME I NAME) (add I (NCHARS NAME)) (COND ((ILESSP I (NCHARS DOMAIN.NAME)) (RPLCHARCODE DOMAIN.NAME I (CHARCODE %.)) (add I 1] DOMAIN.NAME)) (T (ALLOCSTRING 0]) (\DOMAIN.PARSE.NAME [LAMBDA (NAME) (* ejs%: "12-Apr-86 18:11") (* * This function parses a domain name  (e.g. SUMEX.STANFORD.EDU)%, and returns a list of domain labels  (SUMEX STANFORD EDU)) (bind (SCRATCHSTRING _ (CONSTANT (ALLOCSTRING 63))) NAMELIST (LENGTH _ 0) for CHAR instring (MKSTRING NAME) do (COND [(EQ CHAR (CHARCODE %.)) (COND ((NEQ 0 LENGTH) [SETQ NAMELIST (NCONC1 NAMELIST (CONCAT (SUBSTRING SCRATCHSTRING 1 LENGTH] (SETQ LENGTH 0] ((IGREATERP LENGTH 63) (ERROR "Domain name too long" SCRATCHSTRING)) (T (RPLCHARCODE SCRATCHSTRING (add LENGTH 1) CHAR))) finally (RETURN (COND [(NEQ LENGTH 0) (NCONC1 NAMELIST (CONCAT (SUBSTRING SCRATCHSTRING 1 LENGTH] (T NAMELIST]) (\DOMAIN.RCODE.ERROR [LAMBDA (CODE) (* ejs%: "12-Apr-86 19:15") (SELECTC CODE (RCODE.OK 'OK) (RCODE.FORMATERROR 'FORMAT.ERROR) (RCODE.SERVERFAILED 'SERVER.FAILED) (RCODE.NAMEERROR 'NAME.ERROR) (RCODE.NOTIMPLEMENTED 'NOT.IMPLEMENTED) (RCODE.REFUSED 'REFUSED) NIL]) (\DOMAIN.PROCESS.REDIRECT [LAMBDA (STREAM) (* ejs%: "12-Apr-86 21:04") (* * Skip past the header and query section to get to the answer section) (* * Past ID and flags in header) (\WIN STREAM) (\WIN STREAM) (LET ((%#QUESTIONS (\WIN STREAM)) (%#ANSWERS (\WIN STREAM)) (%#NSERVERS (\WIN STREAM)) (%#ADDITIONAL (\WIN STREAM))) (* * Past questions) (for I from 1 to %#QUESTIONS do (\DOMAIN.SKIP.QUESTION STREAM)) (* * Collect answers) (for I from 1 to %#ANSWERS collect (\DOMAIN.SKIP.RR STREAM)) (* * Collect rest) (APPEND (for I from 1 to %#NSERVERS collect (\DOMAIN.PROCESS.RR STREAM)) (for I from 1 to %#ADDITIONAL collect (\DOMAIN.PROCESS.RR STREAM]) (\DOMAIN.PROCESS.RESPONSE [LAMBDA (STREAM) (* ejs%: "12-Apr-86 19:58") (* * Skip past the header and query section to get to the answer section) (* * Past ID and flags in header) (\WIN STREAM) (\WIN STREAM) (LET ((%#QUESTIONS (\WIN STREAM)) (%#ANSWERS (\WIN STREAM))) (* * Past rest of header) (\WIN STREAM) (\WIN STREAM) (* * Past questions) (for I from 1 to %#QUESTIONS do (\DOMAIN.SKIP.QUESTION STREAM)) (* * Collect answers) (for I from 1 to %#ANSWERS collect (\DOMAIN.PROCESS.RR STREAM]) (\DOMAIN.PROCESS.RR [LAMBDA (STREAM) (* ejs%: "13-Apr-86 17:09") (* * Process a resource record beginning at the current point in the stream) (LET ((NAME (\DOMAIN.READ.NAME.FROM.STREAM STREAM)) (TYPE (\WIN STREAM)) (CLASS (\WIN STREAM)) (TTL (\MAKENUMBER (\WIN STREAM) (\WIN STREAM))) (RDLEN (\WIN STREAM)) ANSWER) [SETQ ANSWER `(NAME %, NAME TYPE %, TYPE CLASS %, CLASS TTL %, TTL DATA %, (SELECTC TYPE (RRTYPE.A (\DOMAIN.READ.ADDRESS STREAM CLASS (FOLDLO RDLEN BYTESPERCELL ))) ((LIST RRTYPE.CNAME RRTYPE.NS) (\DOMAIN.READ.NAME.FROM.STREAM STREAM)) (RRTYPE.HINFO (CONS (\DOMAIN.READ.STRING.FROM.STREAM STREAM) (\DOMAIN.READ.STRING.FROM.STREAM STREAM))) (PROGN (for I from 1 to RDLEN do (BIN STREAM)) NIL] [COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE (printout DOMAIN.TRACE.FILE "Answer received: " ANSWER] ANSWER]) (\DOMAIN.READ.ADDRESS [LAMBDA (STREAM CLASS %#ADDRESSES) (* ejs%: "12-Apr-86 20:56") (SELECTC CLASS (CLASSTYPE.IN [COND ((EQ %#ADDRESSES 0) NIL) [(NEQ %#ADDRESSES 1) (for I from 1 to %#ADDRESSES collect (\MAKENUMBER (\WIN STREAM) (\WIN STREAM] (T (\MAKENUMBER (\WIN STREAM) (\WIN STREAM]) NIL]) (\DOMAIN.READ.NAME.FROM.STREAM [LAMBDA (STREAM) (* ejs%: "12-Apr-86 20:54") (bind NAMELEN NAMELST until (EQ 0 (SETQ NAMELEN (BIN STREAM))) do [COND [(EQ 3 (LRSH NAMELEN 6)) (* * Process a pointer redirection) (LET ((CONTINUATIONADDR (create WORD HIBYTE _ (LOGAND NAMELEN (MASK.1'S 0 6)) LOBYTE _ (BIN STREAM))) (STREAMPTR (GETFILEPTR STREAM))) (SETFILEPTR STREAM CONTINUATIONADDR) (RETURN (PROG1 (COND (NAMELST (CONCAT (\DOMAIN.PACK.NAME.LIST (DREVERSE NAMELST)) "." (\DOMAIN.READ.NAME.FROM.STREAM STREAM))) (T (\DOMAIN.READ.NAME.FROM.STREAM STREAM))) (SETFILEPTR STREAM STREAMPTR] (T (* * Normal name segment) (LET ((NAME (ALLOCSTRING NAMELEN))) (\BINS STREAM (fetch (STRINGP BASE) of NAME) (fetch (STRINGP OFFST) of NAME) NAMELEN) (push NAMELST NAME] finally (RETURN (\DOMAIN.PACK.NAME.LIST (DREVERSE NAMELST]) (\DOMAIN.READ.STRING.FROM.STREAM [LAMBDA (STREAM) (* ejs%: "13-Apr-86 02:33") (LET* ((NAMELEN (BIN STREAM)) (STRING (ALLOCSTRING NAMELEN))) (for I from 1 to NAMELEN do (RPLCHARCODE STRING I (BIN STREAM))) STRING]) (\DOMAIN.SEARCH.FOR.CANONICAL.NAME [LAMBDA (NAME RRLST) (* ejs%: "14-Nov-86 14:44") (bind FOUNDIT DATA for RR in RRLST thereis (AND (EQ RRTYPE.CNAME (LISTGET RR 'TYPE)) (DOMAIN.NAME.EQUAL (LISTGET RR 'NAME) NAME) (SETQ FOUNDIT T)) finally (RETURN (AND FOUNDIT (LISTGET RR 'DATA]) (\DOMAIN.SKIP.NAME.IN.STREAM [LAMBDA (STREAM) (* ejs%: "12-Apr-86 21:06") (bind NAMELEN NAMELST until (EQ 0 (SETQ NAMELEN (BIN STREAM))) do (COND ((EQ 3 (LRSH NAMELEN 6)) (* * Process a pointer redirection) (BIN STREAM)) (T (* * Normal name segment) (for I from 1 to NAMELEN do (BIN STREAM]) (\DOMAIN.SKIP.QUESTION [LAMBDA (STREAM) (* ejs%: "12-Apr-86 21:06") (* * Skip over a question section--composed of compressed name, QTYPE, and  QCLASS fields) (\DOMAIN.SKIP.NAME.IN.STREAM STREAM) (\WIN STREAM) (\WIN STREAM]) (\DOMAIN.SKIP.RR [LAMBDA (STREAM) (* ejs%: "12-Apr-86 21:10") (* * Skip a resource record beginning at the current point in the stream) (* * Name) (\DOMAIN.SKIP.NAME.IN.STREAM STREAM) (* * Type) (\WIN STREAM) (* * Class) (\WIN STREAM) (* * Time to Live) (\WIN STREAM) (\WIN STREAM) (* * RDATA Length) (for I from 0 to (\WIN STREAM) do (BIN STREAM]) ) (* ;; "Functions to maintain the domain tree structure") (DECLARE%: EVAL@COMPILE (DATATYPE DOMAIN.TREE.NODE ((NAME POINTER) (* The name of this domain) (SUBDOMAINS POINTER) (* List of domains inferior to this  one) (SUPERDOMAIN POINTER) (* The domain of which this domain  is a part) (NAMESERVERS POINTER) (* The list of designated name  servers for this domain) )) (RECORD DOMAIN.SERVER (NAME ADDRESSES EXPIRATION.DATE FOR.DOMAINS AVG.SVC.TIME) AVG.SVC.TIME _ 0) ) (/DECLAREDATATYPE 'DOMAIN.TREE.NODE '(POINTER POINTER POINTER POINTER) '((DOMAIN.TREE.NODE 0 POINTER) (DOMAIN.TREE.NODE 2 POINTER) (DOMAIN.TREE.NODE 4 POINTER) (DOMAIN.TREE.NODE 6 POINTER)) '8) (/DECLAREDATATYPE 'DOMAIN.TREE.NODE '(POINTER POINTER POINTER POINTER) '((DOMAIN.TREE.NODE 0 POINTER) (DOMAIN.TREE.NODE 2 POINTER) (DOMAIN.TREE.NODE 4 POINTER) (DOMAIN.TREE.NODE 6 POINTER)) '8) (DEFINEQ (USTRINGHASHBITS [LAMBDA (STRING) (* ejs%: " 5-Nov-86 13:20") (for C inthinstring (MKSTRING STRING) bind (HASHBITS _ 0) do [SETQ HASHBITS (IPLUS16 (ELT UPPERCASEARRAY C) (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS (LLSH (LOGAND HASHBITS 4095) 2))) (LLSH (LOGAND HASHBITS 255) 8] finally (RETURN HASHBITS]) ) (RPAQ? \DOMAIN.ROOT (create DOMAIN.TREE.NODE NAME _ "")) (RPAQ? \DOMAIN.NAMESERVERS (HASHARRAY 50 1.2 (FUNCTION USTRINGHASHBITS) (FUNCTION STRING-EQUAL))) (RPAQ? \DOMAIN.UNKNOWN.DOMAINS ) (RPAQ? \DOMAIN.GC.INTERVAL 600000) (RPAQ? \DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DOMAIN.ROOT \DOMAIN.NAMESERVERS \DOMAIN.UNKNOWN.DOMAINS \DOMAIN.GC.TIMER \DOMAIN.GC.INTERVAL) ) (DEFINEQ (\DOMAIN.ADD.NEW.DOMAIN [LAMBDA (NODE DOMAIN NAMESERVER ADDRESSES TTL) (* ejs%: "25-Apr-86 12:25") (* * Add DOMAIN as a subdomain of NODE, with name service by NAMESERVER, at  addresses ADDRESSES, with expiration TTL seconds from now) (LET ((SUBDOMAIN (create DOMAIN.TREE.NODE SUPERDOMAIN _ NODE NAME _ DOMAIN))) (push (fetch (DOMAIN.TREE.NODE SUBDOMAINS) of NODE) SUBDOMAIN) [COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE "Adding " DOMAIN " as subdomain of " (\DOMAIN.NAME NODE] (COND (NAMESERVER (* Add name server information to  new subdomain) (COND (DOMAIN.TRACE.FLG (printout DOMAIN.TRACE.FILE " with name server " NAMESERVER)) ) (\DOMAIN.ADD.NAMESERVER SUBDOMAIN NAMESERVER ADDRESSES TTL]) (\DOMAIN.ADD.NAMESERVER [LAMBDA (NODE NAMESERVER ADDRESSES TTL) (* ejs%: "25-Apr-86 12:34") (* * Function called to add name server information to a node in the domain  tree. If ADDRESSES is NIL, this function will query the internet to resolve  the information) (COND (NAMESERVER (LET [(DOMAIN.SERVER (OR (GETHASH NAMESERVER \DOMAIN.NAMESERVERS) (PUTHASH NAMESERVER (create DOMAIN.SERVER NAME _ NAMESERVER ADDRESSES _ ADDRESSES EXPIRATION.DATE _ (IPLUS (IDATE) (OR (NUMBERP TTL) 3600))) \DOMAIN.NAMESERVERS] [COND ([AND (NULL ADDRESSES) (NULL (SETQ ADDRESSES (fetch (DOMAIN.SERVER ADDRESSES) of DOMAIN.SERVER] (SETQ ADDRESSES (replace (DOMAIN.SERVER ADDRESSES) of DOMAIN.SERVER with (OR ADDRESSES (DOMAIN.LOOKUP.ADDRESS NAMESERVER NIL T] (COND [ADDRESSES (COND ((NOT (for SERVER in (fetch (DOMAIN.TREE.NODE NAMESERVERS) of NODE) thereis (STRING-EQUAL SERVER NAMESERVER))) [COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE "Adding " NAMESERVER " as new name server for " (\DOMAIN.NAME NODE] (push (fetch (DOMAIN.TREE.NODE NAMESERVERS) of NODE) NAMESERVER) (push (fetch (DOMAIN.SERVER FOR.DOMAINS) of DOMAIN.SERVER) NODE] (T (PUTHASH NAMESERVER NIL \DOMAIN.NAMESERVERS]) (\DOMAIN.AUGMENT.TREE [LAMBDA (RRLST) (* ejs%: "14-Nov-86 14:30") (* * RRLST is a list of RRTYPE.NS and/or RRTYPE.A records.  Build up our model of the internet domain tree by processing the information  in RRLST) (bind NAMESERVER for RR in RRLST do (COND ((EQ (LISTGET RR 'TYPE) RRTYPE.NS) (SETQ NAMESERVER (LISTGET RR 'DATA)) (\DOMAIN.INSERT.IN.TREE (LISTGET RR 'NAME) NAMESERVER (\DOMAIN.SEARCH.RESOURCE.LIST RRLST NAMESERVER RRTYPE.A NIL) (LISTGET RR 'TTL]) (\DOMAIN.CHOOSE.BEST.SERVERS [LAMBDA (DOMAIN) (* ejs%: " 1-May-86 17:15") (* * This function chooses the best servers for a query to resolve DOMAIN) (LET* [(PATH (COND ((AND (NLISTP DOMAIN) DOMAIN) (DREVERSE (\DOMAIN.PARSE.NAME DOMAIN))) (T DOMAIN))) (BEST.CHOICE (bind NEXT (CURRENT _ \DOMAIN.ROOT) for NAME in PATH while [SETQ NEXT (for SUBDOMAIN in (fetch ( DOMAIN.TREE.NODE SUBDOMAINS) of CURRENT) thereis (STRING-EQUAL NAME (fetch (DOMAIN.TREE.NODE NAME) of SUBDOMAIN ] do (SETQ CURRENT NEXT) finally (RETURN CURRENT] [while BEST.CHOICE do (COND ((fetch (DOMAIN.TREE.NODE NAMESERVERS) of BEST.CHOICE ) (RETURN)) (T (SETQ BEST.CHOICE (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of BEST.CHOICE] [COND ((EQ BEST.CHOICE \DOMAIN.ROOT) (* Here we have a problem. Is the request for a subdomain of ROOT  (e.g. COM, GOV, EDU, etc)%, or for a local name in our own domain?) (COND [(AND (EQLENGTH PATH 1) (for SUBDOMAIN in (fetch (DOMAIN.TREE.NODE SUBDOMAINS) of \DOMAIN.ROOT) thereis (STRING-EQUAL (CAR PATH) (fetch (DOMAIN.TREE.NODE NAME) of SUBDOMAIN] (T (* Heuristic%: If the domain doesn't appear to be a subdomain of the root,  assume that the local domain server will know it.  If we're wrong, the local name server will tell us) (SETQ BEST.CHOICE NIL] (COND [(NULL BEST.CHOICE) (COND ((OR (EQLENGTH PATH 1) (NULL (fetch (DOMAIN.TREE.NODE NAMESERVERS) of \DOMAIN.ROOT))) (COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE "Best choice for " DOMAIN " is our local server: " \DOMAIN.DEFAULT.SERVER))) (SORT (MKLIST \DOMAIN.DEFAULT.SERVER) (FUNCTION \DOMAIN.SORT.BY.SVC.TIME))) (T (COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE "Best choice for " DOMAIN " is the root server"))) (SORT (fetch (DOMAIN.TREE.NODE NAMESERVERS) of \DOMAIN.ROOT) (FUNCTION \DOMAIN.SORT.BY.SVC.TIME] (T [COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE "Best choice(s) for " DOMAIN ": " (fetch (DOMAIN.TREE.NODE NAMESERVERS) of BEST.CHOICE] (SORT (fetch (DOMAIN.TREE.NODE NAMESERVERS) of BEST.CHOICE) (FUNCTION \DOMAIN.SORT.BY.SVC.TIME]) (\DOMAIN.FIND.DOMAIN.IN.TREE [LAMBDA (NAME) (* ejs%: "13-Apr-86 01:25") (COND ((STREQUAL NAME "") \DOMAIN.ROOT) (T (LET ([PATH (COND ((LISTP NAME) (REVERSE NAME)) (T (DREVERSE (\DOMAIN.PARSE.NAME NAME] (CURRENT \DOMAIN.ROOT)) (bind NEXT for NODE on PATH do (COND ([NOT (SETQ NEXT (for SUBDOMAIN in (fetch (DOMAIN.TREE.NODE SUBDOMAINS) of CURRENT) thereis (STRING-EQUAL (CAR NODE) (fetch (DOMAIN.TREE.NODE NAME) of SUBDOMAIN ] (RETURN (CONS CURRENT NODE))) (T (SETQ CURRENT NEXT))) finally (RETURN CURRENT]) (\DOMAIN.INIT [LAMBDA (EVENT) (* ejs%: " 1-May-86 15:46") (SETQ \DOMAIN.DEFAULT.SERVER (bind NAME for SERVER in (fetch (IPINIT DOMAIN.SERVERS) of \IP.DEFAULT.CONFIGURATION ) as SERVER# from 1 collect (SETQ NAME (CONCAT "Local-Domain-Server-" SERVER#)) (PUTHASH NAME (create DOMAIN.SERVER NAME _ NAME EXPIRATION.DATE _ MAX.FIXP ADDRESSES _ (LIST (\IP.READ.STRING.ADDRESS SERVER))) \DOMAIN.NAMESERVERS) NAME]) (\DOMAIN.INSERT.IN.TREE [LAMBDA (DOMAIN NAMESERVER ADDRESSES TTL) (* ejs%: "25-Apr-86 12:21") (* * Given information from an RRTYPE.NS record, add an entry to the domain  tree) (LET ((PARTIAL.PATH (\DOMAIN.FIND.DOMAIN.IN.TREE DOMAIN))) (COND ((type? DOMAIN.TREE.NODE PARTIAL.PATH) (* Found it) (\DOMAIN.ADD.NAMESERVER PARTIAL.PATH NAMESERVER ADDRESSES TTL)) ((EQLENGTH PARTIAL.PATH 2) (* Only one away from previous  knowledge?) (\DOMAIN.ADD.NEW.DOMAIN (CAR PARTIAL.PATH) (CADR PARTIAL.PATH) NAMESERVER ADDRESSES TTL)) (T (* Some number of domains between our deepest knowledge and the desired  domain) (\DOMAIN.ADD.NEW.DOMAIN (CAR PARTIAL.PATH) (CADR PARTIAL.PATH)) (\DOMAIN.INSERT.IN.TREE DOMAIN NAMESERVER ADDRESSES TTL]) (\DOMAIN.PATH [LAMBDA (DOMAIN.TREE.NODE) (* ejs%: "13-Apr-86 14:44") (* * Generate a list of domain names along the path to the root of the domain  tree) (COND ((NULL (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE)) NIL) (T (CONS (fetch (DOMAIN.TREE.NODE NAME) of DOMAIN.TREE.NODE) (\DOMAIN.PATH (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of DOMAIN.TREE.NODE]) (\DOMAIN.SEARCH.RESOURCE.LIST [LAMBDA (RRLST NAME TYPE OK.TO.RETURN.NAME) (* ejs%: "14-Nov-86 14:40") (LET [(ANSWER (bind DATA for RR in RRLST collect (SETQ DATA (LISTGET RR 'DATA)) (COND ((AND DATA (EQ TYPE RRTYPE.A) OK.TO.RETURN.NAME) (LISTGET RR 'NAME)) (T DATA)) when (AND (EQ TYPE (LISTGET RR 'TYPE)) (DOMAIN.NAME.EQUAL (LISTGET RR 'NAME) NAME] (COND (ANSWER) (T (LET [(CANONICAL.NAME (bind FOUNDIT DATA for RR in RRLST thereis (AND (EQ RRTYPE.CNAME (LISTGET RR 'TYPE)) (DOMAIN.NAME.EQUAL (LISTGET RR 'NAME) NAME) (SETQ FOUNDIT T)) finally (RETURN (AND FOUNDIT (LISTGET RR 'DATA] (COND (CANONICAL.NAME (\DOMAIN.SEARCH.RESOURCE.LIST RRLST CANONICAL.NAME TYPE OK.TO.RETURN.NAME]) (\DOMAIN.DELETE.NAMESERVER [LAMBDA (NAMESERVER) (* ejs%: "13-Apr-86 18:35") (LET ((DOMAIN.SERVER (GETHASH NAMESERVER \DOMAIN.NAMESERVERS))) (COND (DOMAIN.SERVER [bind NAMESERVERS for DOMAIN in (fetch (DOMAIN.SERVER FOR.DOMAINS) of DOMAIN.SERVER) do (SETQ NAMESERVERS (fetch (DOMAIN.TREE.NODE NAMESERVERS) of DOMAIN)) (bind for NAME in NAMESERVERS when (STRING-EQUAL NAME NAMESERVER) do (replace (DOMAIN.TREE.NODE NAMESERVERS) of DOMAIN with (DREMOVE NAME NAMESERVERS] (PUTHASH NAMESERVER NIL \DOMAIN.NAMESERVERS]) (\DOMAIN.AROUND.EXIT [LAMBDA (EVENT) (* ejs%: "13-Apr-86 18:30") (SELECTQ EVENT ((NIL AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\DOMAIN.DELETE.TREE)) NIL]) (\DOMAIN.DELETE.TREE [LAMBDA NIL (* ejs%: "13-Apr-86 17:39") (* * Undoes circularity in pointers between levels of the tree) (bind (OPEN _ (LIST \DOMAIN.ROOT)) CLOSED CURRENT while OPEN do (SETQ CURRENT (pop OPEN)) (SETQ OPEN (APPEND (fetch (DOMAIN.TREE.NODE SUBDOMAINS) of CURRENT) OPEN)) (replace (DOMAIN.TREE.NODE SUBDOMAINS) of CURRENT with NIL) (replace (DOMAIN.TREE.NODE NAME) of CURRENT with NIL) (replace (DOMAIN.TREE.NODE NAMESERVERS) of CURRENT with NIL) (replace (DOMAIN.TREE.NODE SUPERDOMAIN) of CURRENT with NIL)) [MAPHASH \DOMAIN.NAMESERVERS (FUNCTION (LAMBDA (DOMAIN.SERVER NAME) (replace (DOMAIN.SERVER FOR.DOMAINS) of DOMAIN.SERVER with NIL] (CLRHASH \DOMAIN.NAMESERVERS) NIL]) (\DOMAIN.BACKGROUND [LAMBDA NIL (* ejs%: "13-Apr-86 18:24") (COND ((TIMEREXPIRED? \DOMAIN.GC.TIMER) (\DOMAIN.GC.NAMESERVERS) (SETQ \DOMAIN.GC.TIMER (SETUPTIMER \DOMAIN.GC.INTERVAL \DOMAIN.GC.TIMER]) (\DOMAIN.GC.NAMESERVERS [LAMBDA NIL (* ; "Edited 11-Feb-89 12:36 by akw:") (* * This function maps over the name server hash array, and removes old  servers which have timed out) (LET ((TIME (IDATE))) (DECLARE (SPECVARS TIME)) [MAPHASH \DOMAIN.NAMESERVERS (FUNCTION (LAMBDA (DOMAIN.SERVER NAME) (DECLARE (USEDFREE TIME)) (COND ((MEMBER NAME (fetch (IPINIT DOMAIN.SERVERS) of \IP.DEFAULT.CONFIGURATION )) T) ((ILESSP (fetch (DOMAIN.SERVER EXPIRATION.DATE) of DOMAIN.SERVER) TIME) (COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE "Name server " NAME " has expired; deleting..."))) (\DOMAIN.DELETE.NAMESERVER NAME] NIL]) (\DOMAIN.SORT.BY.SVC.TIME [LAMBDA (NAME1 NAME2) (* ejs%: "13-Apr-86 18:14") (LET ((R1 (GETHASH NAME1 \DOMAIN.NAMESERVERS)) (R2 (GETHASH NAME2 \DOMAIN.NAMESERVERS))) (ILESSP (OR (fetch (DOMAIN.SERVER AVG.SVC.TIME) of R1) 0) (OR (fetch (DOMAIN.SERVER AVG.SVC.TIME) of R2) 0]) ) (ADDTOVAR BACKGROUNDFNS \DOMAIN.BACKGROUND) (* ;; "Programmer's interface") (RPAQ? DOMAIN.TRACE.FLG ) (RPAQ? DOMAIN.TRACE.FILE ) (RPAQ? INTERNET.LOCAL.DOMAIN ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DOMAIN.TRACE.FLG DOMAIN.TRACE.FILE INTERNET.LOCAL.DOMAIN) ) (DEFINEQ (DOMAIN.INIT [LAMBDA NIL (* ; "Edited 15-Feb-88 17:26 by Snow") (* ;; "Called to initialize the domain service for this host") (DECLARE (GLOBALVARS \DOMAIN.DEFAULT.SERVER INTERNET.LOCAL.DOMAIN)) (if (NOT \IP.DEFAULT.CONFIGURATION) then (PROMPTPRINT "Internet domain code is loaded, but disabled.") else (LET [(LOCAL.DOMAIN.SERVERS (fetch (IPINIT DOMAIN.SERVERS) of \IP.DEFAULT.CONFIGURATION )) (LOCAL.DOMAIN (MKSTRING (fetch (IPINIT LOCAL.DOMAIN) of \IP.DEFAULT.CONFIGURATION ] (COND ((AND LOCAL.DOMAIN.SERVERS LOCAL.DOMAIN) (SETQ \DOMAIN.DEFAULT.SERVER (for ADDR inside LOCAL.DOMAIN.SERVERS collect (MKSTRING ADDR))) (SETQ INTERNET.LOCAL.DOMAIN LOCAL.DOMAIN) (for NAMESERVER in LOCAL.DOMAIN.SERVERS do (\DOMAIN.INSERT.IN.TREE LOCAL.DOMAIN (MKSTRING NAMESERVER) (LIST (DODIP.HOSTP NAMESERVER)) MAX.FIXP))) (T (PROMPTPRINT "Internet domain code is loaded, but disabled."]) (DOMAIN.LOOKUP.ADDRESS [LAMBDA (NAME SERVER DONT.GET.OSTYPE) (* ; "Edited 15-Feb-89 15:14 by welch") (* * Programmer's interface to lookup IP Internet host name using the domain  system) (bind (OPEN _ (OR (MKLIST SERVER) (\DOMAIN.CHOOSE.BEST.SERVERS NAME))) CANONICAL.NAME CLOSED ADDRESSES THIS.SERVER ANSWER OSTYPE (ATOMIC-NAME _ (MKATOM (U-CASE NAME))) while OPEN do (SETQ THIS.SERVER (pop OPEN)) (push CLOSED THIS.SERVER) (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.A THIS.SERVER)) (COND ((SETQ ADDRESSES (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME RRTYPE.A)) (\DOMAIN.AUGMENT.TREE ANSWER) [SETQ OSTYPE (COND (DONT.GET.OSTYPE NIL) (T (DOMAIN.LOOKUP.OSTYPE NAME] (PUTHASH ATOMIC-NAME (create HOSTS.TXT.ENTRY HTE.TYPE _ 'HOST HTE.ADDRESSES _ ADDRESSES HTE.NAMES _ (LIST ATOMIC-NAME) HTE.OS.TYPE _ OSTYPE) \IP.HOSTNAMES) (RETURN ADDRESSES)) (ANSWER (COND ([SETQ CANONICAL.NAME (MKATOM (U-CASE (  \DOMAIN.SEARCH.FOR.CANONICAL.NAME NAME ANSWER] (SETQ ADDRESSES (DOMAIN.LOOKUP.ADDRESS CANONICAL.NAME SERVER)) (PUTHASH ATOMIC-NAME (GETHASH CANONICAL.NAME \IP.HOSTNAMES ) \IP.HOSTNAMES) (RETURN ADDRESSES)) (T (\DOMAIN.AUGMENT.TREE ANSWER) (SETQ OPEN (APPEND (for NEXT.SERVER in (  \DOMAIN.SEARCH.RESOURCE.LIST ANSWER '* RRTYPE.A T) when (NOT (MEMBER NEXT.SERVER CLOSED)) collect NEXT.SERVER) OPEN]) (DOMAIN.LOOKUP.NAMESERVER [LAMBDA (NAME SERVER) (* ejs%: "25-Apr-86 12:55") (* * Programmer's interface to lookup IP Internet host name using the domain  system) (bind (OPEN _ (OR (MKLIST SERVER) (\DOMAIN.CHOOSE.BEST.SERVERS NAME))) CLOSED NAMESERVERS THIS.SERVER ANSWER while OPEN do (SETQ THIS.SERVER (pop OPEN)) (push CLOSED THIS.SERVER) (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.NS THIS.SERVER)) (COND ((SETQ NAMESERVERS (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME RRTYPE.NS)) (\DOMAIN.AUGMENT.TREE ANSWER) (RETURN NAMESERVERS)) (ANSWER (\DOMAIN.AUGMENT.TREE ANSWER) (SETQ OPEN (APPEND (for NEXT.SERVER in (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER '* RRTYPE.A T) when (NOT (MEMBER NEXT.SERVER CLOSED)) collect NEXT.SERVER) OPEN]) (DOMAIN.LOOKUP.OSTYPE [LAMBDA (NAME SERVER) (* ejs%: "14-Nov-86 14:46") (* * Programmer's interface to lookup IP Internet host name using the domain  system) (bind (OPEN _ (OR (MKLIST SERVER) (\DOMAIN.CHOOSE.BEST.SERVERS NAME))) CANONICAL.NAME CLOSED CPU.OSTYPES THIS.SERVER ANSWER while OPEN do (SETQ THIS.SERVER (pop OPEN)) (push CLOSED THIS.SERVER) (SETQ ANSWER (DOMAIN.LOOKUP NAME RRTYPE.HINFO THIS.SERVER)) (COND [(SETQ CPU.OSTYPES (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER NAME RRTYPE.HINFO)) (\DOMAIN.AUGMENT.TREE ANSWER) (RETURN (MKATOM (U-CASE (CDAR CPU.OSTYPES] (ANSWER (COND ((SETQ CANONICAL.NAME (\DOMAIN.SEARCH.FOR.CANONICAL.NAME NAME ANSWER)) (RETURN (DOMAIN.LOOKUP.OSTYPE CANONICAL.NAME SERVER))) (T (\DOMAIN.AUGMENT.TREE ANSWER) (SETQ OPEN (APPEND (for NEXT.SERVER in (\DOMAIN.SEARCH.RESOURCE.LIST ANSWER '* RRTYPE.A T) when (NOT (MEMBER NEXT.SERVER CLOSED)) collect NEXT.SERVER) OPEN]) (DOMAIN.LOOKUP [LAMBDA (NAME TYPE SERVER) (* ; "Edited 15-Feb-88 17:24 by Snow") (* ;;; "Programmer's interface to lookup IP Internet host name using the domain system") (PROG ((DOMAIN.PATH (\DOMAIN.PARSE.NAME NAME)) (RETRYCOUNT 0) ANSWER ADDRESS TIMINGFLG START.TIME) (OR TYPE (SETQ TYPE RRTYPE.A)) [COND [(LISTP SERVER) (SETQ ADDRESS (COND [(LISTP (CAR SERVER)) (* ;  "Handles a list of DOMAIN.SERVER records") (CAR (fetch (DOMAIN.SERVER ADDRESSES) of (CAR SERVER] (T (* ; "Handles a list of addresses") (CAR SERVER] (SERVER (* ; "Handles a single address") (SETQ ADDRESS SERVER)) (T (SETQ SERVER \DOMAIN.DEFAULT.SERVER) (SETQ ADDRESS (CAR SERVER] [COND ((STRINGP ADDRESS) (SETQ ADDRESS (CAR (fetch (DOMAIN.SERVER ADDRESSES) of (SETQ TIMINGFLG (GETHASH ADDRESS \DOMAIN.NAMESERVERS ] (COND (DOMAIN.TRACE.FLG (FRESHLINE DOMAIN.TRACE.FILE) (PRIN1 "Type " DOMAIN.TRACE.FILE) (PRINTCONSTANT TYPE DOMAIN.RRTYPES DOMAIN.TRACE.FILE) (printout DOMAIN.TRACE.FILE " query to " (COND ((NUMBERP SERVER) (\IP.ADDRESS.TO.STRING SERVER)) (T SERVER)) " for " NAME T))) LOOP (add RETRYCOUNT 1) [COND (TIMINGFLG (SETQ START.TIME (IDATE] [SETQ ANSWER (COND ((NULL ANSWER) (\UDPDOM.QUERY DOMAIN.PATH TYPE CLASSTYPE.IN ADDRESS)) ((EQ ANSWER 'USE.TCP) (\TCPDOM.QUERY DOMAIN.PATH TYPE CLASSTYPE.IN ADDRESS] [COND (TIMINGFLG (replace (DOMAIN.SERVER AVG.SVC.TIME) of TIMINGFLG with (IDIFFERENCE (IDATE) START.TIME] (COND ((LITATOM ANSWER) (SELECTQ ANSWER (NIL (COND ((LISTP SERVER) (SETQ SERVER (CDR SERVER)) [SETQ ADDRESS (CAR (fetch (DOMAIN.SERVER ADDRESSES) of (CAR SERVER] (SETQ RETRYCOUNT 0) (GO LOOP)) (T (RETURN ANSWER)))) (NAME.ERROR (RETURN NIL)) (USE.TCP (COND ((EQ RETRYCOUNT 1) (GO LOOP)) (T (RETURN NIL)))) (RETURN ANSWER))) (T (RETURN ANSWER]) (DOMAIN.GRAPH [LAMBDA (WINDOW) (* ; "Edited 19-Mar-87 16:58 by FS") (LET ((OPENLIST (LIST \DOMAIN.ROOT)) NODELST) (bind NODE while OPENLIST do (SETQ NODE (pop OPENLIST)) (push NODELST (create GRAPHNODE NODELABEL _ (COND ((NULL (fetch (DOMAIN.TREE.NODE SUPERDOMAIN) of NODE)) "*ROOT*") (T (fetch (DOMAIN.TREE.NODE NAME) of NODE))) NODEID _ NODE TONODES _ (fetch (DOMAIN.TREE.NODE SUBDOMAINS) of NODE))) (SETQ OPENLIST (APPEND (fetch (DOMAIN.TREE.NODE SUBDOMAINS) of NODE) OPENLIST))) (SHOWGRAPH (LAYOUTGRAPH NODELST (LIST \DOMAIN.ROOT) 'HORIZONTAL) WINDOW (FUNCTION (LAMBDA (NODE W) (COND (NODE (INSPECT (fetch (GRAPHNODE NODEID) of NODE))) (T (DOMAIN.GRAPH W]) (DOMAIN.NAME.EQUAL [LAMBDA (NAME1 NAME2) (* ejs%: "13-Apr-86 17:23") (COND ((OR (EQ NAME1 '*) (EQ NAME2 '*)) T) (T (OR (LISTP NAME1) (SETQ NAME1 (\DOMAIN.PARSE.NAME NAME1))) (OR (LISTP NAME2) (SETQ NAME2 (\DOMAIN.PARSE.NAME NAME2))) (COND ((OR (AND (NULL NAME1) NAME2) (AND (NULL NAME2) NAME1)) NIL) (T (for X in NAME1 as Y in NAME2 always (STRING-EQUAL X Y]) (DOMAIN.TRACE [LAMBDA (MODE) (* ejs%: "13-Apr-86 16:12") [COND ((WINDOWP DOMAIN.TRACE.FILE) (OPENW DOMAIN.TRACE.FILE)) (T (SETQ DOMAIN.TRACE.FILE (CREATEW NIL "Domain Trace File")) (DSPSCROLL 'ON DOMAIN.TRACE.FILE) (DSPFONT '(GACHA 8) DOMAIN.TRACE.FILE) (WINDOWPROP DOMAIN.TRACE.FILE 'BUTTONEVENTFN (FUNCTION DOMAIN.TRACEWINDOW.BUTTONFN)) (WINDOWPROP DOMAIN.TRACE.FILE 'CLOSEFN (FUNCTION (LAMBDA NIL (SETQ DOMAIN.TRACE.FLG NIL) (SETQ DOMAIN.TRACE.FILE] (SETQ DOMAIN.TRACE.FLG MODE]) (DOMAIN.TRACEWINDOW.BUTTONFN [LAMBDA (WINDOW) (* ejs%: "13-Apr-86 15:49") (COND ((MOUSESTATE (NOT UP)) (SETQ DOMAIN.TRACE.FLG (SELECTQ DOMAIN.TRACE.FLG (NIL T) (T NIL) NIL)) (printout WINDOW T "[Tracing " (SELECTQ DOMAIN.TRACE.FLG (T "on") "off") "]" T]) ) (DOMAIN.INIT) (PUTPROPS TCPDOMAIN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4891 12420 (\UDPDOM.PROCESS.RESPONSE 4901 . 6651) (\UDPDOM.QUERY 6653 . 11968) ( \UDPDOM.IPSOCKET 11970 . 12418)) (15354 27202 (\DOMAIN.NAME 15364 . 16190) (\DOMAIN.PACK.NAME.LIST 16192 . 17169) (\DOMAIN.PARSE.NAME 17171 . 18511) (\DOMAIN.RCODE.ERROR 18513 . 18946) ( \DOMAIN.PROCESS.REDIRECT 18948 . 19944) (\DOMAIN.PROCESS.RESPONSE 19946 . 20717) (\DOMAIN.PROCESS.RR 20719 . 22311) (\DOMAIN.READ.ADDRESS 22313 . 22999) (\DOMAIN.READ.NAME.FROM.STREAM 23001 . 24730) ( \DOMAIN.READ.STRING.FROM.STREAM 24732 . 25048) (\DOMAIN.SEARCH.FOR.CANONICAL.NAME 25050 . 25758) ( \DOMAIN.SKIP.NAME.IN.STREAM 25760 . 26267) (\DOMAIN.SKIP.QUESTION 26269 . 26599) (\DOMAIN.SKIP.RR 26601 . 27200)) (28554 29256 (USTRINGHASHBITS 28564 . 29254)) (29754 50847 (\DOMAIN.ADD.NEW.DOMAIN 29764 . 30996) (\DOMAIN.ADD.NAMESERVER 30998 . 34156) (\DOMAIN.AUGMENT.TREE 34158 . 35305) ( \DOMAIN.CHOOSE.BEST.SERVERS 35307 . 39679) (\DOMAIN.FIND.DOMAIN.IN.TREE 39681 . 40954) (\DOMAIN.INIT 40956 . 41749) (\DOMAIN.INSERT.IN.TREE 41751 . 42869) (\DOMAIN.PATH 42871 . 43387) ( \DOMAIN.SEARCH.RESOURCE.LIST 43389 . 45139) (\DOMAIN.DELETE.NAMESERVER 45141 . 46218) ( \DOMAIN.AROUND.EXIT 46220 . 46475) (\DOMAIN.DELETE.TREE 46477 . 48201) (\DOMAIN.BACKGROUND 48203 . 48489) (\DOMAIN.GC.NAMESERVERS 48491 . 50427) (\DOMAIN.SORT.BY.SVC.TIME 50429 . 50845)) (51144 66800 ( DOMAIN.INIT 51154 . 52770) (DOMAIN.LOOKUP.ADDRESS 52772 . 56193) (DOMAIN.LOOKUP.NAMESERVER 56195 . 57556) (DOMAIN.LOOKUP.OSTYPE 57558 . 59197) (DOMAIN.LOOKUP 59199 . 62699) (DOMAIN.GRAPH 62701 . 64901) (DOMAIN.NAME.EQUAL 64903 . 65527) (DOMAIN.TRACE 65529 . 66257) (DOMAIN.TRACEWINDOW.BUTTONFN 66259 . 66798))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPEXPORTS b/obsolete/tcp/TCPEXPORTS deleted file mode 100644 index f700b47b..00000000 --- a/obsolete/tcp/TCPEXPORTS +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (LISPXPRIN1 "EXPORTS GATHERED FROM {ERIS}Library>TCP*.; ON 11-Sep-89 16:08:46" T) (LISPXTERPRI T) (RPAQQ \TCP.CTRL.ACK 16) (RPAQQ \TCP.CTRL.FIN 1) (RPAQQ \TCP.CTRL.PSH 8) (RPAQQ \TCP.CTRL.RST 4) (RPAQQ \TCP.CTRL.SYN 2) (RPAQQ \TCP.CTRL.URG 32) (CONSTANTS \TCP.CTRL.ACK \TCP.CTRL.FIN \TCP.CTRL.PSH \TCP.CTRL.RST \TCP.CTRL.SYN \TCP.CTRL.URG) (RPAQQ \TCPOPT.END 0) (RPAQQ \TCPOPT.NOP 1) (RPAQQ \TCPOPT.MAXSEG 2) (CONSTANTS \TCPOPT.END \TCPOPT.NOP \TCPOPT.MAXSEG) (RPAQQ \TCP.PROTOCOL 6) (CONSTANTS \TCP.PROTOCOL) (RPAQQ \TCP.HEADER.LENGTH 20) (CONSTANTS \TCP.HEADER.LENGTH) (RPAQQ \TCP.MIN.DATA.OFFSET 5) (CONSTANTS \TCP.MIN.DATA.OFFSET) (RPAQQ \TCP.DEFAULT.MAXSEG 536) (CONSTANTS \TCP.DEFAULT.MAXSEG) (ACCESSFNS TCPSEGMENT ((TCPHEADER (\IPDATABASE DATUM))) (BLOCKRECORD TCPHEADER ((TCP.SRC.PORT WORD) ( TCP.DST.PORT WORD) (TCP.SEQ FIXP) (TCP.ACK FIXP) (TCP.DATA.OFFSET BITS 4) (TCP.MBZ BITS 6) (TCP.CTRL BITS 6) (TCP.WINDOW WORD) (TCP.CHECKSUM WORD) (TCP.URG.PTR WORD))) (ACCESSFNS TCPSEGMENT (( TCP.DATA.LENGTH (fetch (IP IPHEADERCHECKSUM) of DATUM) (replace (IP IPHEADERCHECKSUM) of DATUM with NEWVALUE)) (TCP.SRC.ADDR (fetch (IP IPSOURCEADDRESS) of DATUM) (replace (IP IPSOURCEADDRESS) of DATUM with NEWVALUE)) (TCP.DST.ADDR (fetch (IP IPDESTINATIONADDRESS) of DATUM) (replace (IP IPDESTINATIONADDRESS) of DATUM with NEWVALUE)) (TCP.HEADER.LENGTH (LLSH (fetch TCP.DATA.OFFSET of DATUM) 2)) (TCP.CONTENTS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD (fetch TCP.DATA.OFFSET of DATUM) WORDSPERCELL))) (TCP.OPTIONS (\ADDBASE (fetch TCPHEADER of DATUM) (UNFOLD \TCP.MIN.DATA.OFFSET WORDSPERCELL)))))) (DATATYPE TCP.CONTROL.BLOCK ((TCB.LOCK POINTER) (* ; "monitor lock for synchronizing access") ( TCB.STATE POINTER) (* ; "one of CLOSED LISTEN SYN.SENT SYN.RECEIVED ESTABLISHED FIN.WAIT.1 FIN.WAIT.2 CLOSE.WAIT CLOSING LAST.ACK TIME.WAIT" ) (TCB.SND.STREAM POINTER) (* ; "user's send stream") (TCB.SND.SEGMENT POINTER) (* ; "current output packet being filled") (TCB.RCV.STREAM POINTER) (* ; "user's receive stream") ( TCB.RCV.SEGMENT POINTER) (* ; "current input packet being read") (TCB.2MSL.TIMER POINTER) (* ; "2*MSL quiet time") (TCB.MAXSEG POINTER) (* ; "maximum segment size") (TCB.CLOSEDFLG POINTER) (* ; "T if user has initiated close (no more data to send)") (TCB.FINSEQ POINTER) (* ; "one past the sequence number of the FIN we sent") (TCB.ACKFLG POINTER) (* ; "when to ACK peer: NOW or LATER") (TCB.TEMPLATE POINTER) (* ; "TCP header template") (TCB.PH POINTER) (* ; "TCP pseudo-header for checksumming") (TCB.SRC.PORT WORD) (* ; "local port") (TCB.DST.PORT WORD) (* ; "remote port") (TCB.DST.HOST FIXP) (* ; "remote host address") (TCB.INPUT.QUEUE POINTER) (* ; "queue of received segments to be read") (TCB.REXMT.QUEUE POINTER) (* ; "queue of unacked segments to be retransmitted") (TCB.SND.UNA FIXP) (* ; "first unacknowledged sequence number") (TCB.SND.NXT FIXP) (* ; "next sequence number to be sent") ( TCB.SND.UP FIXP) (* ; "send urgent pointer") (TCB.SND.WL1 FIXP) (* ; "segment sequence number used for last window update") (TCB.SND.WL2 FIXP) (* ; "segment acknowledgment number used for last window update") (TCB.ISS FIXP) (* ; "initial send sequence number") (TCB.SND.WND WORD) (* ; "send window") (TCB.RCV.WND WORD) (* ; "receive window") (TCB.RCV.NXT FIXP) (* ; "next sequence number expected") (TCB.RCV.UP FIXP) (* ; "receive urgent pointer") (TCB.IRS FIXP) (* ; "initial receive sequence number") (TCB.USER.TIMEOUT POINTER) (* ; "in milliseconds") (TCB.ESTABLISHED POINTER) (* ; "processes waiting for this event are notified when the connection becomes established") ( TCB.SND.EVENT POINTER) (* ; "processes waiting for this event are notified when the send window opens up") (TCB.RCV.EVENT POINTER) (* ; "processes waiting for this event are notified when data is received") (TCB.URGENT.EVENT POINTER ) (* ; "processes waiting for this event are notified when urgent data is received") ( TCB.FINACKED.EVENT POINTER) (* ; "processes waiting for this event are notified when our FIN has been acked") (TCB.MODE POINTER) (* ; "ACTIVE or PASSIVE") (TCB.RTFLG POINTER) (* ; "T if round trip time being measured") (TCB.RTSEQ POINTER) (* ; "sequence number being timed") (TCB.RTTIMER POINTER) (* ; "round trip timer") (TCB.SRTT POINTER) (* ; "smoothed round trip time") (TCB.RTO POINTER) (* ; "retransmission timeout based on smoothed round trip time") (TCB.PROBE.TIMER POINTER) (* ; "timer for delayed ACKs and window probes") (TCB.IPSOCKET POINTER) (* ; "Pointer to open IP socket for this connection") (TCB.PROCESS POINTER) (* ; "TCP monitor process for this connection") (TCB.SENT.ZERO FLAG) (* ; "Sent a zero allocation last time") (TCB.OUTPUT.HELD FLAG) (* ; "True if output window shut") ( TCB.NO.IDLE.PROBING FLAG) (* ; "True if we don't probe when nothing to output") (NIL BITS 5) ( TCB.OUR.MAXSEG WORD) (TCB.LAST.SENT.RCV.WND WORD) (* ; "The value of the last rcv window we sent")) TCB.LOCK _ (CREATE.MONITORLOCK) TCB.STATE _ (QUOTE CLOSED) TCB.RCV.WND _ \TCP.DEFAULT.RECEIVE.WINDOW TCB.USER.TIMEOUT _ \TCP.DEFAULT.USER.TIMEOUT TCB.ESTABLISHED _ (CREATE.EVENT) TCB.SND.EVENT _ ( CREATE.EVENT) TCB.RCV.EVENT _ (CREATE.EVENT) TCB.URGENT.EVENT _ (CREATE.EVENT) TCB.FINACKED.EVENT _ ( CREATE.EVENT) TCB.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.OUR.MAXSEG _ \TCP.DEFAULT.MAXSEG TCB.SRTT _ \TCP.INITIAL.RTO TCB.RTO _ \TCP.INITIAL.RTO) (ACCESSFNS TCPSTREAM ((TCB (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) (BYTECOUNT (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)) (ACCESS (fetch ( STREAM ACCESS) of DATUM) (replace (STREAM ACCESS) of DATUM with NEWVALUE)) (ORIGINAL.COFFSET (fetch ( STREAM FW6) of DATUM) (replace (STREAM FW6) of DATUM with NEWVALUE))) (CREATE (create STREAM DEVICE _ \TCP.DEVICE))) (PUTPROP (QUOTE TCP) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 17:01:28")) (PUTPROP (QUOTE TCPCHAT) (QUOTE IMPORTDATE) (IDATE " 7-Jul-88 18:21:44")) (RECORD IPINIT (LOCAL.ADDRESSES LOCAL.NETWORKS DEFAULT.GATEWAY HTE.FILE HOSTNAME SUBNETMASK DOMAIN.SERVERS LOCAL.DOMAIN LOCAL.NSHOSTNUMBER)) (PUTPROP (QUOTE TCPCONFIG) (QUOTE IMPORTDATE) (IDATE "18-Apr-88 21:05:32")) (PUTPROP (QUOTE TCPDEBUG) (QUOTE IMPORTDATE) (IDATE "16-Apr-87 15:16:27")) (RPAQQ \UDPDOMAIN.WDS 6) (CONSTANTS (\UDPDOMAIN.WDS 6)) (BLOCKRECORD DOMAIN.HEADER ((ID WORD) (RESPONSEFLG FLAG) (OPCODE BITS 4) (AUTHORITYFLG FLAG) ( TRUNCATEDFLG FLAG) (WANTRECURSEFLG FLAG) (CANRECURSEFLG FLAG) (NIL BITS 3) (RESPONSECODE BITS 4) ( QDCOUNT WORD) (ANCOUNT WORD) (NSCOUNT WORD) (ARCOUNT WORD))) (RPAQQ DOMAIN.OPCODES ((DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3))) (RPAQQ DOMAIN.QUERY 0) (RPAQQ DOMAIN.IQUERY 1) (RPAQQ DOMAIN.CQUERYM 2) (RPAQQ DOMAIN.CQUERYU 3) (CONSTANTS (DOMAIN.QUERY 0) (DOMAIN.IQUERY 1) (DOMAIN.CQUERYM 2) (DOMAIN.CQUERYU 3)) (RPAQQ DOMAIN.RCODES ((RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) ( RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5))) (RPAQQ RCODE.OK 0) (RPAQQ RCODE.FORMATERROR 1) (RPAQQ RCODE.SERVERFAILED 2) (RPAQQ RCODE.NAMEERROR 3) (RPAQQ RCODE.NOTIMPLEMENTED 4) (RPAQQ RCODE.REFUSED 5) (CONSTANTS (RCODE.OK 0) (RCODE.FORMATERROR 1) (RCODE.SERVERFAILED 2) (RCODE.NAMEERROR 3) ( RCODE.NOTIMPLEMENTED 4) (RCODE.REFUSED 5)) (RPAQQ DOMAIN.RRTYPES ((RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) ( RRTYPE.SOA 6) (RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 12) (RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15))) (RPAQQ RRTYPE.A 1) (RPAQQ RRTYPE.NS 2) (RPAQQ RRTYPE.MD 3) (RPAQQ RRTYPE.MF 4) (RPAQQ RRTYPE.CNAME 5) (RPAQQ RRTYPE.SOA 6) (RPAQQ RRTYPE.MB 7) (RPAQQ RRTYPE.MG 8) (RPAQQ RRTYPE.MR 9) (RPAQQ RRTYPE.NULL 10) (RPAQQ RRTYPE.WKS 11) (RPAQQ RRTYPE.PTR 12) (RPAQQ RRTYPE.HINFO 13) (RPAQQ RRTYPE.MINFO 14) (RPAQQ RRTYPE.MX 15) (CONSTANTS (RRTYPE.A 1) (RRTYPE.NS 2) (RRTYPE.MD 3) (RRTYPE.MF 4) (RRTYPE.CNAME 5) (RRTYPE.SOA 6) ( RRTYPE.MB 7) (RRTYPE.MG 8) (RRTYPE.MR 9) (RRTYPE.NULL 10) (RRTYPE.WKS 11) (RRTYPE.PTR 12) ( RRTYPE.HINFO 13) (RRTYPE.MINFO 14) (RRTYPE.MX 15)) (RPAQQ DOMAIN.CLASSTYPES ((CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3))) (RPAQQ CLASSTYPE.IN 1) (RPAQQ CLASSTYPE.CSNET 2) (RPAQQ CLASSTYPE.CHAOS 3) (CONSTANTS (CLASSTYPE.IN 1) (CLASSTYPE.CSNET 2) (CLASSTYPE.CHAOS 3)) (RPAQQ \DOMAIN.PORT 53) (CONSTANTS (\DOMAIN.PORT 53)) (PUTPROP (QUOTE tcpdomain) (QUOTE IMPORTDATE) (IDATE "15-Feb-88 17:40:22")) (PUTPROP (QUOTE tcpexports) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 17:23:47")) (ACCESSFNS TCPDATASTREAM ((TCPCONTROLDEVICE (fetch (STREAM F3) of DATUM) (replace (STREAM F3) of DATUM with NEWVALUE)) (SEENEOS (fetch (STREAM F4) of DATUM) (replace (STREAM F4) of DATUM with NEWVALUE)) ( TCPFTPCON (fetch (STREAM F5) of DATUM) (replace (STREAM F5) of DATUM with NEWVALUE)))) (RECORD TCPFTPCON (TCPIN TCPOUT DATASTREAM BUSY? IDLETIMER GENERATEFILESDIRECTORY)) (PUTPROP (QUOTE TCPFTP) (QUOTE IMPORTDATE) (IDATE "11-Sep-89 15:22:47")) (PUTPROP (QUOTE tcpftpsrv) (QUOTE IMPORTDATE) (IDATE "24-Aug-87 18:26:25")) (PUTPROP (QUOTE TCPHTE) (QUOTE IMPORTDATE) (IDATE "24-May-88 17:06:10")) (ACCESSFNS AR ((ARBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD ARBASE (( ARHARDWARESPACE WORD) (ARPROTOCOLSPACE WORD) (ARHARDWARELEN BYTE) (ARPROTOCOLLEN BYTE) (AROPCODE WORD) (AR1STWORD WORD)) (ACCESSFNS AR1STWORD ((ARCONTENTS (LOCF DATUM)))))) (ACCESSFNS ARETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE (( ARLCLHDW0 WORD) (ARLCLHDW1 WORD) (ARLCLHDW2 WORD) (ARLCLPTCL FIXP) (ARFRNHDW0 WORD) (ARFRNHDW1 WORD) ( ARFRNHDW2 WORD) (ARFRNPTCL FIXP)) (ACCESSFNS ARLCLHDW0 ((ARSENDERHDW (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)))) (ACCESSFNS ARFRNHDW0 ((ARTARGETHDW (\LOADNSHOSTNUMBER ( LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)))))) (ACCESSFNS AREXPETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE (( ARLCLHDW WORD) (ARLCLPTCL FIXP) (ARFRNHDW WORD) (ARFRNPTCL FIXP)))) (DATATYPE ARENTRY ((RECENT FLAG) (SEARCHING FLAG) (IPADDRESS POINTER) (ETHERADDRESS POINTER) (TIMER POINTER)) TIMER _ (NCREATE (QUOTE FIXP))) (RPAQQ \AR.HARDWARE.SPACE.ETHERNET 1) (RPAQQ \AR.ETHERNET.ADDRESS.LENGTH 6) (RPAQQ \AR.IP.ADDRESS.LENGTH 4) (RPAQQ \AR.REQUEST 1) (RPAQQ \AR.RESPONSE 2) (RPAQQ \AR.ETHER.PACKET.LENGTH 28) (CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET 1) (\AR.ETHERNET.ADDRESS.LENGTH 6) (\AR.IP.ADDRESS.LENGTH 4) ( \AR.REQUEST 1) (\AR.RESPONSE 2) (\AR.ETHER.PACKET.LENGTH 28)) (PUTPROP (QUOTE TCPLLAR) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 15:50:14")) (ACCESSFNS ICMPADMASK ((ICMPADMASKBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPADMASKBASE ((ICMPADMASKID WORD) (ICMPADMASKSEQNO WORD) (ICMPADMASKADMASK FIXP)))) (ACCESSFNS ICMP ((ICMPBASE (\IPDATABASE DATUM))) (BLOCKRECORD ICMPBASE ((ICMPTYPE BYTE) (ICMPCODE BYTE ) (ICMPCHECKSUM WORD) (ICMPDATASTART WORD))) (ACCESSFNS ICMP ((ICMPCONTENTS (LOCF (fetch (ICMP ICMPDATASTART) of DATUM)))))) (ACCESSFNS ICMPECHO ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE (( ICMPECHOID WORD) (ICMPECHOSEQNO WORD) (ICMPECHODATA BYTE)))) (ACCESSFNS ICMPDESTUN ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE ((NIL FIXP) (ICMPIPSTART WORD))) (ACCESSFNS ICMPDESTUN ((ICMPIPHEADER (LOCF (fetch (ICMPDESTUN ICMPIPSTART) of DATUM)))))) (ACCESSFNS ICMPREDIRECT ((ICMPREDIRECTBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPREDIRECTBASE ((ICMPGATEWAY FIXP) (ICMPIPSTART WORD))) (ACCESSFNS ICMPREDIRECT ((ICMPIPHEADER (LOCF (fetch (ICMPREDIRECT ICMPIPSTART) of DATUM)))))) (RPAQQ ICMPTYPES ((\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) ( \ICMP.REDIRECT 5) (\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) ( \ICMP.TIMESTAMP 13) (\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) ( \ICMP.ADDRESS.MASK.REQUEST 17) (\ICMP.ADDRESS.MASK.REPLY 18))) (RPAQQ \ICMP.ECHO.REPLY 0) (RPAQQ \ICMP.DEST.UNREACHABLE 3) (RPAQQ \ICMP.SOURCE.QUENCH 4) (RPAQQ \ICMP.REDIRECT 5) (RPAQQ \ICMP.ECHO 8) (RPAQQ \ICMP.TIME.EXCEEDED 11) (RPAQQ \ICMP.PARAMETER.PROBLEM 12) (RPAQQ \ICMP.TIMESTAMP 13) (RPAQQ \ICMP.TIMESTAMP.REPLY 14) (RPAQQ \ICMP.INFO.REQUEST 15) (RPAQQ \ICMP.INFO.REPLY 16) (RPAQQ \ICMP.ADDRESS.MASK.REQUEST 17) (RPAQQ \ICMP.ADDRESS.MASK.REPLY 18) (CONSTANTS (\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (\ICMP.REDIRECT 5) (\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (\ICMP.TIMESTAMP 13) ( \ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (\ICMP.ADDRESS.MASK.REQUEST 17 ) (\ICMP.ADDRESS.MASK.REPLY 18)) (RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) ( \ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5 ))) (RPAQQ \ICMP.NET.UNREACHABLE 0) (RPAQQ \ICMP.HOST.UNREACHABLE 1) (RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2) (RPAQQ \ICMP.PORT.UNREACHABLE 3) (RPAQQ \ICMP.CANT.FRAGMENT 4) (RPAQQ \ICMP.SOURCE.ROUTE 5) (CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) ( \ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5)) (RPAQQ ICMPREDIRECTS ((\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) ( \ICMP.REDIRECT.SVC.AND.HOST 3))) (RPAQQ \ICMP.REDIRECT.NET 0) (RPAQQ \ICMP.REDIRECT.HOST 1) (RPAQQ \ICMP.REDIRECT.SVC.AND.NET 2) (RPAQQ \ICMP.REDIRECT.SVC.AND.HOST 3) (CONSTANTS (\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) ( \ICMP.REDIRECT.SVC.AND.HOST 3)) (RPAQQ ICMPTIMEXS ((\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1))) (RPAQQ \ICMP.TRANSIT.TIME.EXCEEDED 0) (RPAQQ \ICMP.FRAGMENT.TIME.EXCEEDED 1) (CONSTANTS (\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1)) (RPAQQ \ICMPOVLEN 4) (CONSTANTS \ICMPOVLEN) (RPAQQ \ICMP.PROTOCOL 1) (CONSTANTS \ICMP.PROTOCOL) (PUTPROPS ICMPLENGTH MACRO (LAMBDA (ICMP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of ICMP) (LLSH (fetch (IP IPHEADERLENGTH) of ICMP) 2)))) (PUTPROP (QUOTE TCPLLICMP) (QUOTE IMPORTDATE) (IDATE " 6-Sep-89 16:28:51")) (ACCESSFNS IP ((IPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM)))) (BLOCKRECORD IPBASE ((IPVERSION BITS 4) (* ; "Protocol version") (IPHEADERLENGTH BITS 4) (* ; "Head length, in cells") (IPSERVICE BYTE ) (* ; "Service type") (IPTOTALLENGTH WORD) (* ; "Packet length, in bytes") (IPID WORD) (* ; "Packet id") (NIL BITS 1) (IPDONTFRAGMENT FLAG) (* ; "Don't fragment me") (IPMOREFRAGMENTS FLAG) (* ; "Last fragment") (IPFRAGMENTOFFSET BITS 13) (* ; "Fragment position") (IPTIMETOLIVE BYTE) (* ; "Hop limiter") (IPPROTOCOL BYTE) (* ; "Client protocol") (IPHEADERCHECKSUM WORD) (* ; "Header-only checksum") (IPSOURCEADDRESS FIXP) (IPDESTINATIONADDRESS FIXP) (IPOPTIONSSTART BYTE) (* ; "Options or data start here")) (ACCESSFNS IPSERVICE ((IPSERVICEBASE (LOCF DATUM))) (BLOCKRECORD IPSERVICEBASE ((IPPRECEDENCE BITS 3) (IPDELAY FLAG) (IPTHROUGHPUT FLAG) (IPRELIABILITY FLAG) (NIL BITS 2)))) (* ; "Replace is not supported on any of the following because there is ambiguity about the address class." ) (ACCESSFNS IPDESTINATIONADDRESS ((IPDESTBASE (LOCF DATUM))) (ACCESSFNS IPDESTBASE ((IPDESTINATIONNET (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) ( (EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) (T (* ; "Class C or error") (fetch (IPADDRESS CLASSCNET) of DATUM)))) (IPDESTINATIONHOST (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSAHOST) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBHOST) of DATUM)) (T (* ; "Class C or error") (fetch (IPADDRESS CLASSCHOST) of DATUM))))))) (ACCESSFNS IPSOURCEADDRESS (( IPSOURCEBASE (LOCF DATUM))) (ACCESSFNS IPSOURCEBASE ((IPSOURCENET (COND ((EQ \IP.CLASS.A (fetch ( IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) ((EQ \IP.CLASS.B (fetch ( IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) (T (fetch (IPADDRESS CLASSCNET) of DATUM)))) (IPSOURCEHOST (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch ( IPADDRESS CLASSAHOST) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch ( IPADDRESS CLASSBHOST) of DATUM)) (T (fetch (IPADDRESS CLASSCHOST) of DATUM)))))))) (TYPE? (type? ETHERPACKET DATUM))) (DATATYPE IPSOCKET ((PROTOCOL BYTE) (IPSLINK POINTER) (* ; "Other sockets of this protocol type") (NIL BYTE) (IPSQUEUE POINTER) (* ; "Queue of packets for this protocol") (IPSQUEUELENGTH WORD) (* ; "Count of packets of input queue") (IPSQUEUEALLOC WORD) (* ; "Max count allowed") ( IPSDESTSOCKETCOMPAREFN POINTER) (* ; "Call this to compare dest protocol socket to this socket") ( IPSOCKET POINTER) (* ; "This socket") (IPSINPUTFN POINTER) (* ; "Call to hand packet to protocol") ( IPSEVENT POINTER) (* ; "Notify me when a packet arrives") (IPSNOSOCKETFN POINTER) (* ; "Call this when no socket found") (IPSICMPFN POINTER) (* ; "Call this when an ICMP packet is received on this protocol")) IPSQUEUE _ (create SYSQUEUE) IPSQUEUEALLOC _ \IP.MAX.EPKTS.ON.QUEUE IPSEVENT _ (CREATE.EVENT) IPSINPUTFN _ (FUNCTION \IP.DEFAULT.INPUTFN) IPSICMPFN _ (FUNCTION \RELEASE.ETHERPACKET)) (BLOCKRECORD IPADDRESS ((ADDRESS FIXP)) (* ;; "Class A nets: high bit is 0") (BLOCKRECORD IPADDRESS (( CLASSA BITS 1) (CLASSANET BITS 7) (CLASSAHOST BITS 24))) (* ;; "Class B nets: high 2 bits are 10") ( BLOCKRECORD IPADDRESS ((CLASSB BITS 2))) (BLOCKRECORD IPADDRESS ((CLASSBNET BITS 16) (CLASSBHOST BITS 16))) (* ;; "Class C nets: high 3 bits are 110") (BLOCKRECORD IPADDRESS ((CLASSC BITS 3))) ( BLOCKRECORD IPADDRESS ((CLASSCNETB1 BITS 8) (CLASSCNETB2 BITS 8) (CLASSCNETB3 BITS 8) (CLASSCHOST BITS 8))) (* ; "I wish I could say just net bits 24, host bits 8, but BLOCKRECORD barfs") (BLOCKRECORD IPADDRESS ((CLASSCNETHI BITS 16))) (ACCESSFNS IPADDRESS ((CLASSCNET (\MAKENUMBER (FETCH CLASSCNETB1 OF DATUM) (LOGOR (LLSH (FETCH CLASSCNETB2 OF DATUM) 8) (FETCH CLASSCNETB3 OF DATUM))) (PROGN (REPLACE CLASSCNETHI OF DATUM WITH (LRSH NEWVALUE 8)) (REPLACE CLASSCNETB3 OF DATUM WITH (LOGAND NEWVALUE 255)) DATUM))))) (RPAQQ \IPOVLEN 20) (RPAQQ \MAX.IPDATALENGTH 556) (RPAQQ \IP.PROTOCOLVERSION 4) (RPAQQ \IP.MAX.EPKTS.ON.QUEUE 16) (RPAQQ \IP.DEFAULT.TIME.TO.LIVE 120) (RPAQQ \IP.WAKEUP.INTERVAL 15000) (CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION \IP.MAX.EPKTS.ON.QUEUE \IP.DEFAULT.TIME.TO.LIVE \IP.WAKEUP.INTERVAL) (RPAQQ IPPACKETTYPES ((\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052))) (RPAQQ \EPT.IP 2048) (RPAQQ \EPT.AR 2054) (RPAQQ \EET.IP 513) (RPAQQ \EPT.CHAOS 2052) (CONSTANTS (\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052)) (RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) ( \ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5 ))) (RPAQQ \ICMP.NET.UNREACHABLE 0) (RPAQQ \ICMP.HOST.UNREACHABLE 1) (RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2) (RPAQQ \ICMP.PORT.UNREACHABLE 3) (RPAQQ \ICMP.CANT.FRAGMENT 4) (RPAQQ \ICMP.SOURCE.ROUTE 5) (CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) ( \ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5)) (PUTPROPS \IPDATABASE MACRO (LAMBDA (IP) (* ; "Returns the LOCF of the start of the data in the packet") (\ADDBASE (fetch (IP IPBASE) of IP) (UNFOLD (fetch (IP IPHEADERLENGTH) of IP) 2)))) (PUTPROPS \IPDATALENGTH MACRO (LAMBDA (IP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of IP) (LLSH (fetch (IP IPHEADERLENGTH) of IP) 2)))) (RPAQQ IPADDRESSTYPES ((\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC ( BYTE 8 24)) (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30)) (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) ( \IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC ( BYTE 8 0)))) (RPAQQ \IP.CLASS.A 0) (RPAQ \IP.CLASS.A.BYTESPEC (BYTE 1 31)) (RPAQ \IP.CLASS.A.NET.BYTESPEC (BYTE 8 24)) (RPAQ \IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (RPAQQ \IP.CLASS.B 2) (RPAQ \IP.CLASS.B.BYTESPEC (BYTE 2 30)) (RPAQ \IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (RPAQ \IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (RPAQQ \IP.CLASS.C 6) (RPAQ \IP.CLASS.C.BYTESPEC (BYTE 3 29)) (RPAQ \IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (RPAQ \IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0)) (CONSTANTS (\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24)) ( \IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30)) ( \IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) ( \IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC ( BYTE 8 0))) (RPAQQ IPPROTOCOLTYPES ((\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17))) (RPAQQ \ICMP.PROTOCOL 1) (RPAQQ \TCP.PROTOCOL 6) (RPAQQ \UDP.PROTOCOL 17) (CONSTANTS (\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17)) (RECORD AssemblyRecord (Packet FirstHole Fragments Timeout) Packet _ (\ALLOCATE.ETHERPACKET) FirstHole _ 0) (RECORD FragmentRecord (Start Length LastFragment)) (RECORD FragmentID (AssemblyRecord SourceAddress ID Protocol . DestinationAddress)) (RPAQQ IPOPTIONTYPES ((IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4 ) (IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9))) (RPAQQ IPOPT.END 0) (RPAQQ IPOPT.NOP 1) (RPAQQ IPOPT.SECURITY 2) (RPAQQ IPOPT.LSRR 3) (RPAQQ IPOPT.TIMESTAMP 4) (RPAQQ IPOPT.RECRT 7) (RPAQQ IPOPT.STREAMID 8) (RPAQQ IPOPT.SSSR 9) (CONSTANTS (IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4) ( IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9)) (RPAQ IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0)) (CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0))) (PUTPROPS \IP.GET.BYTE DMACRO (LAMBDA (IP BYTE INHEADER) (* ;; "Retrieve a byte from an IP packet. If INHEADER is T, BYTE is an offset from the start of the packet, else it's an offset from the start of the IP data section" ) (\GETBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE))) (PUTPROPS \IP.GET.CELL DMACRO (LAMBDA (IP CELL INHEADER) (* ;; "Retrieve a cell from an IP packet. If INHEADER is not NIL, the cell is written to the header portion of the IP packet, else it's written to the data portion. CELL is the offset, in 16-bit units" ) (\GETBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL))) (PUTPROPS \IP.GET.STRING DMACRO (LAMBDA (IP BYTEOFFSET NCHARS INHEADER) (* ;; "Retrieve a string from an IP packet. If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else it's an offset from the start of the IP data section" ) (\GETBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET NCHARS)) ) (PUTPROPS \IP.GET.WORD DMACRO (LAMBDA (IP WORD INHEADER) (* ;; "Retrieve a word from an IP packet. If INHEADER is T, WORD is an offset from the start of the packet, else it's an offset from the start of the IP data section" ) (\GETBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD))) (PUTPROPS \IP.PUT.BYTE DMACRO (LAMBDA (IP BYTE VALUE INHEADER) (* ;; "Store a byte in an IP packet. If INHEADER is T, BYTE is an offset from the start of the packet, else it's an offset from the start of the IP data section" ) (\PUTBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE VALUE))) (PUTPROPS \IP.PUT.CELL DMACRO (LAMBDA (IP CELL VALUE INHEADER) (* ;; "Store a cell in an IP packet. If INHEADER is not NIL, the cell is written to the header portion of the IP packet, else it's written to the data portion. CELL is the offset, in 16-bit units" ) (\PUTBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL VALUE))) (PUTPROPS \IP.PUT.STRING DMACRO (LAMBDA (IP BYTEOFFSET STRING INHEADER) (* ;; "Store a string ib an IP packet. If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else it's an offset from the start of the IP data section" ) (\PUTBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET STRING)) ) (PUTPROPS \IP.PUT.WORD DMACRO (LAMBDA (IP WORD VALUE INHEADER) (* ;; "Store a word in an IP packet. If INHEADER is T, WORD is an offset from the start of the packet, else it's an offset from the start of the IP data section" ) (\PUTBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD VALUE))) (PUTPROP (QUOTE TCPLLIP) (QUOTE IMPORTDATE) (IDATE "11-Sep-89 15:24:32")) (PUTPROP (QUOTE TCPNAMES) (QUOTE IMPORTDATE) (IDATE " 2-Jun-88 20:58:40")) (RECORD TFTPCON (UDPSOCKET DESTSOCKET STREAM HOST)) (ACCESSFNS TFTP ((TFTPBASE (fetch (UDP UDPCONTENTS) of DATUM))) (BLOCKRECORD TFTPBASE ((OPCODE WORD) ( BLOCK# WORD))) (ACCESSFNS TFTP ((TFTPCONTENTS (\ADDBASE (fetch (UDP UDPCONTENTS) of DATUM) (FOLDHI \TFTPOVLEN BYTESPERWORD))))) (BLOCKRECORD TFTPBASE ((NIL WORD) (ERRORCODE WORD)))) (ACCESSFNS TFTPSTREAM ((TFTPCON (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) (LASTPACKETIN (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)))) (RPAQQ \TFTPOVLEN 4) (RPAQQ \TFTP.SOCKET 69) (CONSTANTS (\TFTPOVLEN 4) (\TFTP.SOCKET 69)) (RPAQQ TFTPOPCODES ((\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5))) (RPAQQ \TFTP.RRQ 1) (RPAQQ \TFTP.WRQ 2) (RPAQQ \TFTP.DATA 3) (RPAQQ \TFTP.ACK 4) (RPAQQ \TFTP.ERROR 5) (CONSTANTS (\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5)) (PUTPROP (QUOTE TCPTFTP) (QUOTE IMPORTDATE) (IDATE " 1-Jul-87 10:54:35")) (ACCESSFNS UDP ((UDPBASE (\IPDATABASE DATUM))) (BLOCKRECORD UDPBASE ((UDPSOURCEPORT WORD) (UDPDESTPORT WORD) (UDPLENGTH WORD) (UDPCHECKSUM WORD))) (ACCESSFNS UDP ((UDPCONTENTS (\ADDBASE (\IPDATABASE DATUM ) (FOLDHI \UDPOVLEN BYTESPERWORD)))))) (RPAQQ \UDPOVLEN 8) (CONSTANTS (\UDPOVLEN 8)) (PUTPROP (QUOTE TCPUDP) (QUOTE IMPORTDATE) (IDATE " 6-Jan-89 16:37:41")) (PUTPROP (QUOTE TCPEXPORTS) (QUOTE FILEDATES) (QUOTE (("11-Sep-89 16:22:57" . "{ERIS}Library>TCPEXPORTS.;8")))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPFTP b/obsolete/tcp/TCPFTP deleted file mode 100644 index 519099e2..00000000 --- a/obsolete/tcp/TCPFTP +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 16:23:19" {DSK}local>lde>lispcore>library>TCPFTP.;3 50122 changes to%: (VARS TCPFTPCOMS) previous date%: "20-Jun-89 19:47:44" {DSK}local>lde>lispcore>library>TCPFTP.;2) (* ; " Copyright (c) 1985, 1986, 1900, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPFTPCOMS) (RPAQQ TCPFTPCOMS [[COMS (* ;; "FNS from Larry's Interlisp-10 LISPUSERS package") (FNS ARPACMD FTPHELP CMDREADCODE CMDREAD DISCARDLINE GETLINE \TCPFTP.INPUT TELNET.EOL) (INITVARS (\TCPFTP.ARPACMD.LOCK (CREATE.MONITORLOCK "ARPACMD Lock"))) (GLOBALVARS \TCPFTP.ARPACMD.LOCK) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FTPHELP] (COMS (* ;; "FNS for the Interlisp-D streams facility") (FNS \TCPFTP.CONTROL.CLOSED \TCPFTP.GET.OSTYPE \TCPFTP.EVENTFN \TCPFTP.HOSTNAMEP \GET.TCPFTP.CONNECTION \TCPFTP.OPEN.CONNECTION \TCPFTP.ASSURE.CLEANUP \TCPFTP.CLEANUP \TCPFTP.RELEASE.CONNECTION \TCPFTP.LOGIN \TCPFTP.DELETEFILE \TCPFTP.DIRECTORYNAMEP \TCPFTP.ENDOFSTREAMOP \TCPFTP.GENERATEFILES \TCPFTP.GENERATENEXTFILE \TCPFTP.GETFILENAME \TCPFTP.GETFILEINFO \TCPFTP.SETFILEINFO \TCPFTP.RENAMEFILE \TCPFTP.CONNECT \TCPFTP.OPENFILE \TCPFTP.CLOSE \TCPFTP.FLUSH \TCPFTP.INIT SET.TCP.EOL.CONVENTION) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS TCPDATASTREAM TCPFTPCON))) (ADDVARS (TCPFTP.DEFAULT.FILETYPES (NIL . TEXT) (DFASL . BINARY) (dfasl . BINARY) (LCOM . BINARY) (lcom . BINARY) (DCOM . BINARY) (dcom . BINARY) (LISP . TEXT) (lisp . TEXT) (LSP . TEXT) (lsp . TEXT) (RST . BINARY) (rst . BINARY) (BIN . BINARY) (bin . BINARY))) (INITVARS (TCP.DEFAULTFILETYPE 'BINARY) (TCP.USE.STANDARD.EOL T) (\TCPFTP.DEVICES) (\TCPFTP.CLEANUP.PROCESS)) (GLOBALVARS \TCPFTP.DEVICES \TCPFTP.CLEANUP.PROCESS TCP.DEFAULTFILETYPE TCP.USE.STANDARD.EOL)) (COMS (* ;; "Data connection handling") (FNS \TCP.BYE \TCPFTP.MAYBE.ABORT \TCPFTP.DATA.CLOSED \TCPFTP.OPEN.DATA.CONNECTION \TCPFTP.PORT.STRING \TCPFTP.SPAWN.DATACONNECTION \TCPFTP.READ.UNTIL.EOF \TCPFTP.TRANSFER.COMPLETE \TCPFTP.WAIT.FOR.DATACONNECTION \TCPFTP.DELETE.CONNECTION) (INITVARS (\TCPFTP.DATACONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Data Connection Lock")) (\TCPFTP.CONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Connection Lock")) (\TCPFTP.IDLE.TIMEOUT (TIMES 10 60 1000))) (GLOBALVARS \TCPFTP.DATACONNECTION.LOCK \TCPFTP.CONNECTION.LOCK \TCPFTP.IDLE.TIMEOUT)) (FILES (SYSLOAD) TCPNAMES TCP) (P (\TCPFTP.INIT)) (VARS TCPFTP.DEFAULT.FILETYPES) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; "FNS from Larry's Interlisp-10 LISPUSERS package") (DEFINEQ (ARPACMD (LAMBDA (TCPFTPCON CMD ARG WANT DISCARD WANTARG) (* ejs%: "15-Nov-86 15:09") (* lmm "16-OCT-78 02:57") (DECLARE (GLOBALVARS \TCPFTP.ARPACMD.LOCK)) (WITH.MONITOR \TCPFTP.ARPACMD.LOCK (LET ((INC (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (OUTC (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (RESETLST (RESETSAVE NIL (BQUOTE (COND (RESETSTATE (AND (OPENP %, INC (QUOTE INPUT)) (CLOSEF %, INC)) (AND (OPENP %, OUTC (QUOTE OUTPUT)) (CLOSEF %, OUTC)))))) (PROG NIL (COND (CMD (COND (FTPDEBUGFLG (printout FTPDEBUGLOG CMD) (COND (ARG (printout FTPDEBUGLOG " " ARG))))) (PRIN3 CMD OUTC) (COND (ARG (PRIN3 " " OUTC) (PRIN3 ARG OUTC))) (TELNET.EOL OUTC) (FORCEOUTPUT OUTC) (* flush) (COND (FTPDEBUGFLG (TERPRI FTPDEBUGLOG))))) LP (COND (FTPDEBUGFLG (printout FTPDEBUGLOG "< "))) (SETQ CMD (\TCPFTP.INPUT INC)) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG CMD " "))) (COND ((EQMEMB CMD WANTARG) (AND (EQ (BIN INC) (CHARCODE -)) (FTPHELP CMD)) (RETURN CMD))) (COND ((EQ (BIN INC) (CHARCODE -)) (do (DISCARDLINE INC) repeatuntil (EQ (\TCPFTP.INPUT INC) CMD)))) (COND ((EQMEMB CMD WANT) (DISCARDLINE INC) (RETURN CMD)) ((EQMEMB CMD DISCARD) (DISCARDLINE INC) (GO LP))) (SELECTQ (AND (FIXP CMD) (IQUOTIENT CMD 100)) ((2 3) (FTPHELP CMD)) ((4 5) (ERROR (GETLINE INC T))) NIL) (DISCARDLINE INC) (GO LP)))))) ) (FTPHELP (LAMBDA (ARG) (* ejs%: "29-Jan-85 17:02") (ERROR ARG " unrecognized response from remote FTP server")) ) (CMDREADCODE (LAMBDA (IN) (* lmm "31-MAY-78 00:45") (PACK* (CMDREAD IN) (CMDREAD IN) (CMDREAD IN)))) (CMDREAD (LAMBDA (IN) (* ejs%: "12-Jan-85 14:28") ((LAMBDA (CH) (COND (FTPDEBUGFLG (BOUT CH FTPDEBUGLOG))) CH) (BIN IN))) ) (DISCARDLINE (LAMBDA (IN) (* ejs%: " 3-Feb-86 16:16") (* lmm "31-MAY-78 00:45") (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG)) (COND (FTPDEBUGFLG (\BACKFILEPTR IN) (bind CH until (FMEMB (SETQ CH (BIN IN)) (CONSTANT (LIST (CHARCODE LF) (CHARCODE NULL)))) do (BOUT FTPDEBUGLOG CH) finally (TERPRI FTPDEBUGLOG))) (T (until (FMEMB (BIN IN) (CONSTANT (LIST (CHARCODE LF) (CHARCODE NULL)))))))) ) (GETLINE (LAMBDA (IN FLG) (* ejs%: "12-Jan-85 14:40") (* lmm "31-MAY-78 00:46") (bind CH (STRING _ (ALLOCSTRING 80)) for POS from 1 while (NEQ (SETQ CH (BIN IN)) (CHARCODE LF)) do (COND ((LEQ POS 80) (RPLCHARCODE STRING POS CH))) finally (RETURN (SUBSTRING STRING 1 (SUB1 POS))))) ) (\TCPFTP.INPUT (LAMBDA (STREAM) (* ; "Edited 17-Nov-88 15:16 by cdl") (DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG)) (LET (CCODE (RESULT 0)) (to 3 do (SETQ CCODE (BIN STREAM)) (if (AND (GEQ CCODE (CHARCODE 0)) (LEQ CCODE (CHARCODE 9))) then (SETQ RESULT (PLUS (TIMES RESULT 10) (DIFFERENCE CCODE (CHARCODE 0))))) repeatuntil (OR (EQ CCODE (CHARCODE SPACE)) (EQ CCODE (CHARCODE -)) (EQ CCODE 0)) finally (if (EQ CCODE (CHARCODE -)) then (if FTPDEBUGFLG then (printout FTPDEBUGLOG T "< " RESULT)) (DISCARDLINE STREAM) (\TCPFTP.INPUT STREAM))) RESULT)) ) (TELNET.EOL (LAMBDA (STREAM) (* ejs%: " 5-Jan-85 18:44") (BOUT STREAM (CHARCODE CR)) (BOUT STREAM (CHARCODE LF)) (FORCEOUTPUT STREAM)) ) ) (RPAQ? \TCPFTP.ARPACMD.LOCK (CREATE.MONITORLOCK "ARPACMD Lock")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TCPFTP.ARPACMD.LOCK) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FTPHELP) ) (* ;; "FNS for the Interlisp-D streams facility") (DEFINEQ (\TCPFTP.CONTROL.CLOSED (LAMBDA (INSTREAM OUTSTREAM) (* ejs%: "28-Jul-86 14:30") (LET* ((DEVICE (fetch (STREAM DEVICE) of INSTREAM)) (TCPFTPCON (for CONN in (fetch (FDEV DEVICEINFO) of DEVICE) thereis (EQ (fetch (TCPFTPCON TCPIN) of CONN) INSTREAM)))) (COND (TCPFTPCON (replace (STREAM ACCESS) of INSTREAM with (replace (STREAM ACCESS) of OUTSTREAM with NIL)) (replace (FDEV DEVICEINFO) of DEVICE with (DREMOVE TCPFTPCON (fetch (FDEV DEVICEINFO) of DEVICE))))))) ) (\TCPFTP.GET.OSTYPE [LAMBDA (DEVICE) (* ; "Edited 12-May-89 14:10 by welch") (LET* ((HOST (fetch (FDEV DEVICENAME) of DEVICE)) ENTRY) (GETHOSTINFO HOST 'OSTYPE]) (\TCPFTP.EVENTFN (LAMBDA (FDEV FLG) (* ejs%: "23-Apr-85 18:56") (* * Called when a major event happens) (SELECTQ FLG ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS) (bind TCPIN TCPOUT DATASTREAM for TCPFTPCON in (fetch (FDEV DEVICEINFO) of FDEV) do (SETQ TCPIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SETQ TCPOUT (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (SETQ DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)) (COND ((OPENP TCPIN (QUOTE INPUT)) (CLOSEF TCPIN))) (COND ((OPENP TCPOUT (QUOTE OUTPUT)) (CLOSEF TCPOUT))) (COND ((OPENP DATASTREAM) (CLOSEF DATASTREAM))))) NIL)) ) (\TCPFTP.HOSTNAMEP [LAMBDA (HOST DEVICE) (* ejs%: "24-Mar-86 14:36") (DECLARE (GLOBALVARS \TCP.DEVICE \TCPFTP.DEVICES)) (PROG ((SERVER (OR (DODIP.HOSTP HOST) (\IP.READ.STRING.ADDRESS HOST))) FULLHOSTNAME FILINGNAME) (RETURN (COND ((NOT SERVER) NIL) ((\GETDEVICEFROMNAME (SETQ FULLHOSTNAME (MKATOM (U-CASE HOST))) T T)) (T (SETQ FILINGNAME (PACK* HOST " Filing")) (\DEFINEDEVICE FULLHOSTNAME (SETQ DEVICE (create FDEV using \TCP.DEVICE DEVICENAME _ FULLHOSTNAME OPENFILE _ (FUNCTION \TCPFTP.OPENFILE) RENAMEFILE _ (FUNCTION \TCPFTP.RENAMEFILE) REOPENFILE _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION \TCPFTP.GETFILEINFO) SETFILEINFO _ (FUNCTION \TCPFTP.SETFILEINFO) GETEOFPTR _ (FUNCTION \TCPFTP.GETEOFPTR ) DELETEFILE _ (FUNCTION \TCPFTP.DELETEFILE) HOSTNAMEP _ (FUNCTION NILL) GETFILENAME _ (FUNCTION \TCPFTP.GETFILENAME) DIRECTORYNAMEP _ (FUNCTION \TCPFTP.DIRECTORYNAMEP ) GENERATEFILES _ (FUNCTION \TCPFTP.GENERATEFILES) EVENTFN _ (FUNCTION NILL) DEVICEINFO _ NIL))) (push \TCPFTP.DEVICES DEVICE) DEVICE]) (\GET.TCPFTP.CONNECTION (LAMBDA (DEVICE) (* ejs%: " 4-Jun-85 17:54") (LET ((CONNECTIONS (fetch (FDEV DEVICEINFO) of DEVICE)) TCPFTPCON INSTREAM OUTSTREAM) (WITH.MONITOR \TCPFTP.CONNECTION.LOCK (COND ((SETQ TCPFTPCON (for TCPFTPCON in CONNECTIONS thereis (NULL (fetch (TCPFTPCON BUSY?) of TCPFTPCON)))) (COND ((AND (SETQ INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SETQ OUTSTREAM (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (OPENP INSTREAM (QUOTE INPUT)) (OPENP OUTSTREAM (QUOTE OUTPUT)) (NOT (EOFP INSTREAM))) (while (READP INSTREAM) do (BIN INSTREAM)) (replace (TCPFTPCON BUSY?) of TCPFTPCON with T) TCPFTPCON) (T (\TCPFTP.DELETE.CONNECTION TCPFTPCON DEVICE) (\TCPFTP.OPEN.CONNECTION DEVICE)))) (T (\TCPFTP.OPEN.CONNECTION DEVICE)))))) ) (\TCPFTP.OPEN.CONNECTION (LAMBDA (DEVICE) (* ; "Edited 24-Apr-87 16:09 by FS") (LET* ((HOST (DODIP.HOSTP (fetch (FDEV DEVICENAME) of DEVICE))) (TCPFTPCON (create TCPFTPCON BUSY? _ T)) (INSTREAM (TCP.OPEN HOST \TCP.FTP.PORT NIL (QUOTE ACTIVE) (QUOTE INPUT) NIL (QUOTE (WHENCLOSEDFN \TCPFTP.CONTROL.CLOSED)))) (OUTSTREAM (COND (INSTREAM (TCP.OTHER.STREAM INSTREAM))))) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (CON DEV) (COND (RESETSTATE (COND ((AND (EQ (\TCPFTP.GET.OSTYPE DEV) (QUOTE UNIX)) (READP (fetch (TCPFTPCON TCPIN) of CON))) (\TCPFTP.INPUT (fetch (TCPFTPCON TCPIN) of CON)))) (ARPACMD CON "QUIT" NIL (QUOTE (221 500))) (\TCPFTP.DELETE.CONNECTION CON DEV))))) TCPFTPCON DEVICE)) (COND (INSTREAM (replace (STREAM ENDOFSTREAMOP) of INSTREAM with (FUNCTION (LAMBDA (STREAM) (ZERO)))) (replace (STREAM DEVICE) of INSTREAM with DEVICE) (replace (STREAM DEVICE) of OUTSTREAM with DEVICE) (replace (TCPFTPCON TCPIN) of TCPFTPCON with INSTREAM) (replace (TCPFTPCON TCPOUT) of TCPFTPCON with OUTSTREAM) (SELECTQ (\TCPFTP.INPUT INSTREAM) (220 (COND (FTPDEBUGFLG (printout FTPDEBUGLOG T "< 220 ") (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))) (\TCPFTP.LOGIN DEVICE TCPFTPCON) (push (fetch (FDEV DEVICEINFO) of DEVICE) TCPFTPCON) TCPFTPCON) (PROGN (\TCPFTP.DELETE.CONNECTION TCPFTPCON DEVICE) NIL))))))) ) (\TCPFTP.ASSURE.CLEANUP (LAMBDA NIL (* ejs%: "27-Apr-85 14:08") (* * Spawn a cleanup function if necessary) (COND ((AND (PROCESSP \TCPFTP.CLEANUP.PROCESS) (NOT (PROCESS.FINISHEDP \TCPFTP.CLEANUP.PROCESS)))) (T (SETQ \TCPFTP.CLEANUP.PROCESS (ADD.PROCESS (QUOTE (\TCPFTP.CLEANUP)) (QUOTE RESTARTABLE) (QUOTE NO)))))) ) (\TCPFTP.CLEANUP (LAMBDA NIL (* ejs%: "28-Jul-86 12:26") (DECLARE (GLOBALVARS \TCPFTP.IDLE.TIMEOUT \TCPFTP.DEVICES \TCPFTP.CONNECTION.LOCK)) (LET ((INTERVAL (QUOTIENT \TCPFTP.IDLE.TIMEOUT 4)) CONNECTIONSP) (repeatwhile (NOT (ZEROP CONNECTIONSP)) do (SETQ CONNECTIONSP 0) (for DEVICE in \TCPFTP.DEVICES do (for CONNECTION in (APPEND (fetch (FDEV DEVICEINFO) of DEVICE)) do (add CONNECTIONSP 1) (WITH.MONITOR \TCPFTP.CONNECTION.LOCK (NLSETQ (COND ((AND (NULL (fetch (TCPFTPCON BUSY?) of CONNECTION)) (TIMEREXPIRED? (fetch (TCPFTPCON IDLETIMER) of CONNECTION))) (CLOSEF? (fetch (TCPFTPCON TCPIN) of CONNECTION)) (CLOSEF? (fetch (TCPFTPCON TCPOUT) of CONNECTION)) (COND ((fetch (TCPFTPCON DATASTREAM) of CONNECTION) (CLOSEF? (fetch (TCPFTPCON DATASTREAM) of CONNECTION)))) (add CONNECTIONSP -1) (\TCPFTP.DELETE.CONNECTION CONNECTION DEVICE T)) ((OR (NOT (OPENP (fetch (TCPFTPCON TCPIN) of CONNECTION) (QUOTE INPUT))) (NEQ (QUOTE ESTABLISHED) (fetch (TCP.CONTROL.BLOCK TCB.STATE) of (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of CONNECTION))))) (add CONNECTIONSP -1) (\TCPFTP.DELETE.CONNECTION CONNECTION DEVICE))))) (BLOCK))) (COND ((NOT (ZEROP CONNECTIONSP)) (BLOCK INTERVAL)))))) ) (\TCPFTP.RELEASE.CONNECTION (LAMBDA (TCPFTPCON) (* jmh "11-Oct-85 13:43") (COND (TCPFTPCON (replace (TCPFTPCON BUSY?) of TCPFTPCON with NIL) (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL) (replace (TCPFTPCON IDLETIMER) of TCPFTPCON with (SETUPTIMER \TCPFTP.IDLE.TIMEOUT)) (\TCPFTP.ASSURE.CLEANUP)))) ) (\TCPFTP.LOGIN (LAMBDA (DEVICE TCPFTPCON) (* ; "Edited 24-Apr-87 16:17 by FS") (* * Log us in) (PROG ((OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) (HOST (fetch (FDEV DEVICENAME) of DEVICE)) (LOGINRETRYCOUNT 0) INFO) RETRY (SETQ INFO (\INTERNAL/GETPASSWORD HOST)) (* * Loop through this label if the server rejected the our name) (COND ((OR (NULL INFO) (EQ 0 (NCHARS (CAR INFO))) (EQ 0 (NCHARS (CDR INFO)))) (* Need to login. Can't send Unix hosts a string of no chars as name or password!) (LOGIN HOST) (GO RETRY))) RETRY1 (* * Loop through this label if the server rejected something else) (SELECTQ (ARPACMD TCPFTPCON "USER" (COND ((AND (EQ OSTYPE (QUOTE UNIX)) (EQ (CAR INFO) (U-CASE (CAR INFO))) (EQ LOGINRETRYCOUNT 0)) (L-CASE (CAR INFO))) (T (CAR INFO))) (QUOTE (202 230 331 332 500 503 530))) ((230 202) (* We're logged in) (RETURN T)) (331 (* Needs a password) (SELECTQ (ARPACMD TCPFTPCON "PASS" (\DECRYPT.PWD (CDR INFO)) (QUOTE (230 331 332 530))) (230 (RETURN T)) (332 (SELECTQ (ARPACMD TCPFTPCON "ACCT" (PROMPTFORWORD (CONCAT "Account for logging into " HOST)) (QUOTE (230 202 530))) (230 (RETURN T)) (GO RETRY1))) ((331 530) (LOGIN HOST) (add LOGINRETRYCOUNT 1) (GO RETRY)) (FTPHELP))) (332 (SELECTQ (ARPACMD TCPFTPCON "ACCT" (PROMPTFORWORD (CONCAT "Account for logging into " HOST)) (QUOTE (230 202 530))) (230 (RETURN T)) (GO RETRY1))) (503 (COND ((EQ OSTYPE (QUOTE UNIX)) (* ;; "Well, the sequence of events to get here was probably that the D-machine sent an illegal name/password pair, such that the name was not a registered user on the Unix machine. There's a bug in the Unix FTP server which causes it to send a 530 error--illegal user name--immediately after it sent a 331 to prompt us for the password. This is blatantly in violation of the FTP specification, which states that only 100 class errors can have multiple responses. Now we're out of sync with the server, and need somehow to reinitialize our state") (\PEEKBIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (\TCPFTP.INPUT (fetch (TCPFTPCON TCPIN) of TCPFTPCON)))) (GO RETRY1)) ((500 530) (* No such user?) (LOGIN HOST) (add LOGINRETRYCOUNT 1) (GO RETRY)) (FTPHELP)))) ) (\TCPFTP.DELETEFILE (LAMBDA (NAME DEVICE) (* ejs%: " 7-Apr-86 11:52") (* * FTP delete request) (LET* ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE)) (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) (CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "DELE" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) NAME) OSTYPE) (QUOTE (200 226 250 450 550))))))) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) (SELECTQ CODE ((250 226 200) NAME) NIL))) ) (\TCPFTP.DIRECTORYNAMEP (LAMBDA (HOST/DIR DEVICE) (* ejs%: "27-Apr-85 14:04") (LET ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE))) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (TCPFTPCON) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) (COND (RESETSTATE (AND (OPENP (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (CLOSEF (fetch (TCPFTPCON TCPIN) of TCPFTPCON))) (replace (TCPFTPCON TCPIN) of TCPFTPCON with NIL) (AND (OPENP (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (CLOSEF (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (replace (TCPFTPCON TCPOUT) of TCPFTPCON with NIL))))) TCPFTPCON)) (\TCPFTP.CONNECT DEVICE TCPFTPCON (FILENAMEFIELD HOST/DIR (QUOTE DIRECTORY)))))) ) (\TCPFTP.ENDOFSTREAMOP (LAMBDA (STREAM SILENTLY) (* ejs%: " 3-Feb-85 17:01") (\TCPFTP.TRANSFER.COMPLETE STREAM) (OR SILENTLY (\EOSERROR STREAM))) ) (\TCPFTP.GENERATEFILES [LAMBDA (DEVICE PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 12-May-89 14:00 by welch") (* * FTP directory request) (LET* ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE)) (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) DATASTREAMEVENT DATASTREAM CODE) (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON 'INPUT)) (BLOCK) [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "NLST" [COND [(EQ OSTYPE 'UNIX) (COND ((AND (EQ (FILENAMEFIELD PATTERN 'VERSION) '*) (EQ (FILENAMEFIELD PATTERN 'EXTENSION) '*) (EQ (FILENAMEFIELD PATTERN 'NAME) '*)) (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'VERSION NIL 'EXTENSION NIL 'NAME "*" 'BODY PATTERN) 'UNIX)) ((EQ (FILENAMEFIELD PATTERN 'VERSION) '*) (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'VERSION NIL 'BODY PATTERN) 'UNIX)) (T (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY PATTERN) 'UNIX] (T (COND ((EQ OSTYPE 'INTERLISP) (PACKFILENAME.STRING 'HOST NIL 'BODY PATTERN)) (T (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY PATTERN) OSTYPE] 150] (SELECTQ CODE (150 (* * Here we go) (COND ((SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION DEVICE TCPFTPCON DATASTREAMEVENT 'INPUT)) (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON with (FILENAMEFIELD PATTERN 'DIRECTORY)) (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \TCPFTP.GENERATENEXTFILE) FILEINFOFN _ (FUNCTION NILL) GENFILESTATE _ TCPFTPCON)) (T (ERROR "Couldn't open data connection to remote TCPFTP server")))) (PROGN (DEL.PROCESS (CAR DATASTREAMEVENT)) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) (\NULLFILEGENERATOR]) (\TCPFTP.GENERATENEXTFILE [LAMBDA (TCPFTPCON NAMEONLY) (* ; "Edited 8-Mar-89 22:54 by akw:") (PROG ((DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)) [OSTYPE (\TCPFTP.GET.OSTYPE (fetch (STREAM DEVICE) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON] [FILENAMERDTBL (DEFERREDCONSTANT (PROG [(R (COPYREADTABLE 'ORIG] (SETBRK NIL NIL R) (SETSYNTAX '%% 'OTHER R) (SETSEPR '(13 10 31) NIL R) (RETURN R] CODE NAME) LOOP (RETURN (COND [[AND (OPENP DATASTREAM 'INPUT) (NOT (EOFP DATASTREAM)) (SETQ NAME (CAR (NLSETQ (READ DATASTREAM FILENAMERDTBL] (COND ((AND (OR (EQ OSTYPE 'TOPS-20) (EQ OSTYPE 'TOPS20)) (STRPOS "? Not found" NAME NIL NIL NIL NIL UPPERCASEARRAY)) (NLSETQ (until (EOFP DATASTREAM) do (READ DATASTREAM FILENAMERDTBL) )) (AND (OPENP DATASTREAM) (CLOSEF DATASTREAM)) (SELECTQ [SETQ CODE (ARPACMD TCPFTPCON NIL NIL '(226 250] ((250 226) (AND (OPENP DATASTREAM) (CLOSEF DATASTREAM)) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) NIL) (FTPHELP CODE))) ((AND (EQ OSTYPE 'UNIX) (STREQUAL ":" (SUBSTRING NAME -1))) (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON with (REPACKFILENAME.STRING (SUBSTRING NAME 1 -2) 'INTERLISP)) (GO LOOP)) (NAMEONLY (REPACKFILENAME.STRING NAME 'INTERLISP)) (T (if (STRPOS "*" (fetch (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON)) then (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME) of (fetch (STREAM DEVICE) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON) )) 'BODY (REPACKFILENAME.STRING NAME 'INTERLISP)) else (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME) of (fetch (STREAM DEVICE) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON))) 'DIRECTORY (fetch (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON) 'BODY (REPACKFILENAME.STRING NAME 'INTERLISP] (T (AND (OPENP DATASTREAM) (CLOSEF DATASTREAM)) (SELECTQ [SETQ CODE (ARPACMD TCPFTPCON NIL NIL '(226 250] ((250 226) (AND (OPENP DATASTREAM) (CLOSEF DATASTREAM)) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) NIL) (FTPHELP CODE]) (\TCPFTP.GETFILENAME [LAMBDA (NAME RECOG DEVICE) (* ; "Edited 12-May-89 13:35 by welch") (* * FTP directory request) (COND ((EQ RECOG 'NEW) NAME) (T (PROG ((TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE)) (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) DATASTREAMEVENT DATASTREAM CODE GENERATOR ALLPOSSIBILITIES) (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON 'INPUT)) (BLOCK) [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "NLST" (COND ((EQ OSTYPE 'INTERLISP) (PACKFILENAME.STRING 'HOST NIL 'BODY NAME)) (T (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY NAME) OSTYPE))) 150] (RETURN (SELECTQ CODE (150 (* * Here we go) (COND ((AND (SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION DEVICE TCPFTPCON DATASTREAMEVENT 'INPUT)) (SETQ GENERATOR (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \TCPFTP.GENERATENEXTFILE ) FILEINFOFN _ (FUNCTION NILL) GENFILESTATE _ TCPFTPCON))) (replace (TCPFTPCON GENERATEFILESDIRECTORY) of TCPFTPCON with (FILENAMEFIELD NAME 'DIRECTORY)) (SETQ ALLPOSSIBILITIES (bind FILE while (SETQ FILE ( \GENERATENEXTFILE GENERATOR)) collect FILE)) (MKATOM (CAR ALLPOSSIBILITIES))) (T (ERROR "Couldn't open data connection to remote TCPFTP server." )))) (PROGN (DEL.PROCESS (CAR DATASTREAMEVENT)) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) NIL]) (\TCPFTP.GETFILEINFO (LAMBDA (STREAM ATTRIB DEVICE) (* ejs%: "20-Mar-86 21:01") (COND ((type? STREAM STREAM) (STREAMPROP STREAM ATTRIB)) ((EQ ATTRIB (QUOTE EOL)) (QUOTE CRLF)))) ) (\TCPFTP.SETFILEINFO (LAMBDA (STREAM ATTRIB VALUE DEVICE) (* ejs%: " 9-Nov-85 14:20") (STREAMPROP STREAM ATTRIB VALUE))) (\TCPFTP.RENAMEFILE (LAMBDA (OLDDEVICE OLDNAME NEWDEVICE NEWNAME) (* ; "Edited 15-Jun-88 13:41 by atm") (* * FTP delete request) (COND ((NEQ OLDDEVICE NEWDEVICE) (\GENERIC.RENAMEFILE OLDDEVICE OLDNAME NEWDEVICE NEWNAME)) (T (LET ((OSTYPE (\TCPFTP.GET.OSTYPE OLDDEVICE)) (TCPFTPCON (\GET.TCPFTP.CONNECTION OLDDEVICE)) CODE) (RESETLST (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (CON) (\TCPFTP.RELEASE.CONNECTION CON))) TCPFTPCON)) (PROG NIL RETRY (SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "RNFR" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) OLDNAME) OSTYPE) (QUOTE (350 450 550)))))) (SELECTQ CODE (350 (SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON "RNTO" (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE HOST) NIL (QUOTE BODY) NEWNAME) OSTYPE) (QUOTE (200 250 553)))))) (SELECTQ CODE ((200 250) (RETURN NEWNAME)) NIL)) (PROGN (SETQ OLDNAME (LISPERROR "FILE NOT FOUND" OLDNAME T)) (GO RETRY))))))))) ) (\TCPFTP.CONNECT (LAMBDA (DEVICE TCPFTPCON DIRECTORY) (* ejs%: "24-Jun-85 17:10") (LET ((DIRECTORYNAME (REPACKFILENAME.STRING (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY) (\TCPFTP.GET.OSTYPE DEVICE)))) (COND ((NEQ 0 (NCHARS DIRECTORYNAME)) (SELECTQ (ARPACMD TCPFTPCON "CWD" DIRECTORYNAME (QUOTE (200 250 450 550))) ((200 250) T) NIL)) (T (* The user specified no connect directory. We'll have to assume he or she meant his or her own login directory, whose name we can't even accurately guess. Thus, we leave it at this) T)))) ) (\TCPFTP.OPENFILE [LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE) (* ; "Edited 22-Mar-89 22:31 by welch") (DECLARE (GLOBALVARS TCP.DEFAULTFILETYPE TCP.USE.STANDARD.EOL TCPFTP.EOL.CONVENTION TCPFTP.DEFAULT.FILETYPES)) (LET* ((HOST (fetch (FDEV DEVICENAME) of DEVICE)) (OSTYPE (\TCPFTP.GET.OSTYPE DEVICE)) [FILENAME (COND ((EQ OSTYPE 'INTERLISP) (PACKFILENAME.STRING 'HOST NIL 'BODY NAME)) (T (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY NAME) OSTYPE] (FILENAME.EXTENSION (FILENAMEFIELD FILENAME 'EXTENSION)) (TCPFTPCON (\GET.TCPFTP.CONNECTION DEVICE)) (TYPE (OR (CADR (FASSOC 'TYPE PARAMETERS)) (CDR (FASSOC FILENAME.EXTENSION TCPFTP.DEFAULT.FILETYPES)) (CDR (FASSOC (U-CASE FILENAME.EXTENSION) TCPFTP.DEFAULT.FILETYPES)) TCP.DEFAULTFILETYPE)) DATASTREAMEVENT DATASTREAM CODE FTPCMD STREAMDEV) (SELECTQ TYPE (TEXT (ARPACMD TCPFTPCON "TYPE" "A N" 200)) (ARPACMD TCPFTPCON "TYPE" "L 8" 200)) (SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON (COND ((EQ ACCESS 'OUTPUT) 'APPEND) (T ACCESS)) T)) (BLOCK) (PROG NIL LOOP (SETQ FTPCMD (SELECTQ ACCESS (INPUT '"RETR") (OUTPUT '"STOR") (APPEND '"APPE") (ERROR "ACCESS must be one of INPUT, OUTPUT, or APPEND" ACCESS))) [SETQ CODE (CAR (NLSETQ (ARPACMD TCPFTPCON FTPCMD FILENAME '(125 150 226 250 425 426 450 451 550] (SELECTQ CODE ((125 150) (* * Here we go) (COND ([SETQ DATASTREAM (\TCPFTP.WAIT.FOR.DATACONNECTION DEVICE TCPFTPCON DATASTREAMEVENT (COND ((EQ ACCESS 'OUTPUT) 'APPEND) (T ACCESS] (replace (STREAM ENDOFSTREAMOP) of DATASTREAM with (FUNCTION \TCPFTP.ENDOFSTREAMOP)) (replace (STREAM FULLFILENAME) of DATASTREAM with NAME) [replace (STREAM EOLCONVENTION) of DATASTREAM with (COND (TCP.USE.STANDARD.EOL CRLF.EOLC) (T (OR TCPFTP.EOL.CONVENTION (SELECTQ OSTYPE (UNIX LF.EOLC) (TOPS-20 CRLF.EOLC) CR.EOLC] (STREAMPROP DATASTREAM 'TYPE TYPE) (replace (TCPDATASTREAM TCPFTPCON) of DATASTREAM with TCPFTPCON ) (SETQ STREAMDEV (fetch (STREAM DEVICE) of DATASTREAM)) (replace (FDEV GETFILENAME) of STREAMDEV with (FUNCTION NILL)) (replace (FDEV GETFILEINFO) of STREAMDEV with (FUNCTION \TCPFTP.GETFILEINFO)) (STREAMADDPROP DATASTREAM 'AFTERCLOSE (FUNCTION \TCPFTP.TRANSFER.COMPLETE)) (STREAMADDPROP DATASTREAM 'BEFORECLOSE (FUNCTION \TCPFTP.READ.UNTIL.EOF) ) (RETURN DATASTREAM)) (T (ERROR "Couldn't open data connection to remote TCPFTP server")))) (425 (* The foreign port is busy) (PROMPTPRINT "TCPFTP: Please wait; the remote ftp server is busy.") (DEL.PROCESS (CAR DATASTREAMEVENT)) (DISMISS 5000) [SETQ DATASTREAMEVENT (\TCPFTP.SPAWN.DATACONNECTION TCPFTPCON (COND ((EQ ACCESS 'OUTPUT) 'APPEND) (T ACCESS] (BLOCK) (GO LOOP)) ((450 550) (DEL.PROCESS (CAR DATASTREAMEVENT)) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON) NIL) (FTPHELP CODE]) (\TCPFTP.CLOSE (LAMBDA (DEVICE) (* ejs%: "23-Apr-85 18:41") (* * This needs work) (PROG ((DEVINFO (fetch (FDEV DEVICEINFO) of DEVICE))) (AND (OPENP (fetch (TCPFTPCON TCPOUT) of DEVINFO) (QUOTE OUTPUT)) (CLOSEF (fetch (TCPFTPCON TCPOUT) of DEVINFO))) (AND (OPENP (fetch (TCPFTPCON TCPIN) of DEVINFO) (QUOTE INPUT)) (CLOSEF (fetch (TCPFTPCON TCPIN) of DEVINFO))))) ) (\TCPFTP.FLUSH (LAMBDA (DEVICE) (* ejs%: "23-Apr-85 18:56") (* * This needs work) (PROG ((INSTREAM (fetch (TCPFTPCON TCPIN) of (fetch (FDEV DEVICEINFO) of DEVICE)))) (COND ((READP INSTREAM) (until (NOT (READP INSTREAM)) do (BIN INSTREAM)))))) ) (\TCPFTP.INIT (LAMBDA NIL (* ejs%: "10-Apr-85 19:25") (\DEFINEDEVICE NIL (create FDEV DEVICENAME _ (QUOTE TCPFTP) HOSTNAMEP _ (FUNCTION \TCPFTP.HOSTNAMEP) EVENTFN _ (FUNCTION \TCPFTP.EVENTFN)))) ) (SET.TCP.EOL.CONVENTION [LAMBDA (EOLTYPE) (* ; "Edited 22-Mar-89 22:31 by welch") (* ; "Sets the EOL convention to use") (DECLARE (GLOBALVARS TCP.USE.STANDARD.EOL TCPFTP.EOL.CONVENTION)) (SELECTQ EOLTYPE (CR (SETQ TCP.USE.STANDARD.EOL NIL) (SETQ TCPFTP.EOL.CONVENTION CR.EOLC)) (LF (SETQ TCP.USE.STANDARD.EOL NIL) (SETQ TCPFTP.EOL.CONVENTION LF.EOLC)) (CRLF (SETQ TCP.USE.STANDARD.EOL NIL) (SETQ TCPFTP.EOL.CONVENTION CRLF.EOLC)) (OS (SETQ TCP.USE.STANDARD.EOL NIL) (SETQ TCPFTP.EOL.CONVENTION NIL)) (SETQ TCP.USE.STANDARD.EOL T]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (ACCESSFNS TCPDATASTREAM ((TCPCONTROLDEVICE (fetch (STREAM F3) of DATUM) (replace (STREAM F3) of DATUM with NEWVALUE)) (SEENEOS (fetch (STREAM F4) of DATUM) (replace (STREAM F4) of DATUM with NEWVALUE)) (TCPFTPCON (fetch (STREAM F5) of DATUM) (replace (STREAM F5) of DATUM with NEWVALUE)))) (RECORD TCPFTPCON (TCPIN TCPOUT DATASTREAM BUSY? IDLETIMER GENERATEFILESDIRECTORY)) ) (* "END EXPORTED DEFINITIONS") ) (ADDTOVAR TCPFTP.DEFAULT.FILETYPES (NIL . TEXT) (DFASL . BINARY) (dfasl . BINARY) (LCOM . BINARY) (lcom . BINARY) (DCOM . BINARY) (dcom . BINARY) (LISP . TEXT) (lisp . TEXT) (LSP . TEXT) (lsp . TEXT) (RST . BINARY) (rst . BINARY) (BIN . BINARY) (bin . BINARY)) (RPAQ? TCP.DEFAULTFILETYPE 'BINARY) (RPAQ? TCP.USE.STANDARD.EOL T) (RPAQ? \TCPFTP.DEVICES ) (RPAQ? \TCPFTP.CLEANUP.PROCESS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TCPFTP.DEVICES \TCPFTP.CLEANUP.PROCESS TCP.DEFAULTFILETYPE TCP.USE.STANDARD.EOL) ) (* ;; "Data connection handling") (DEFINEQ (\TCP.BYE (LAMBDA (HOST) (* ejs%: "15-Nov-86 15:05") (LET* ((DEVICE (\GETDEVICEFROMNAME HOST NIL T)) (CONNECTIONS (AND DEVICE (fetch (FDEV DEVICEINFO) of DEVICE)))) (bind INSTREAM for TCPFTPCON in CONNECTIONS do (SETQ INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (while (AND (OPENP INSTREAM (QUOTE INPUT)) (READP INSTREAM)) do (BIN INSTREAM)) (NLSETQ (ARPACMD TCPFTPCON "QUIT" NIL (QUOTE (221 500)))) (CLOSEF? (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)) (CLOSEF? INSTREAM) (CLOSEF? (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) T) (replace (FDEV DEVICEINFO) of DEVICE with NIL))) ) (\TCPFTP.MAYBE.ABORT [LAMBDA (DATASTREAM) (* ; "Edited 18-Mar-89 13:43 by welch") (LET* ((TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM)) (TCPOUTSTREAM (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (STREAMPROP DATASTREAM 'BEFORECLOSE NIL) (COND ((AND (NOT (fetch (TCPDATASTREAM SEENEOS) of DATASTREAM)) (OPENP DATASTREAM 'INPUT)) (TCP.CLOSE.SENDER (TCP.OTHER.STREAM DATASTREAM)) (BLOCK) (BOUT TCPOUTSTREAM 244) (BOUT TCPOUTSTREAM 242) (TCP.URGENT.MARK TCPOUTSTREAM) (ARPACMD TCPFTPCON "ABOR" NIL '(226 426 250]) (\TCPFTP.DATA.CLOSED (LAMBDA (INSTREAM OUTSTREAM) (* ejs%: "28-Jul-86 14:03") (LET* ((STREAM (OR INSTREAM OUTSTREAM))) (replace (STREAM ACCESS) of STREAM with NIL))) ) (\TCPFTP.OPEN.DATA.CONNECTION (LAMBDA (TCPFTPCON ACCESS EVENT FOR.FILE.TRANSFER) (* ejs%: "26-Sep-86 18:27") (DECLARE (GLOBALVARS \TCPFTP.DATACONNECTION.LOCK)) (* * Tell the FTP control connection on what port we're expecting the data connection to made, and try up to five times to accept a connection. Each time, select a new port (this hopefully a workaround to a Unix bug in which ports sometimes tend to appear busy for 2 minute timeout intervals)) (WITH.MONITOR \TCPFTP.DATACONNECTION.LOCK (bind PORT STREAM for I from 1 to 5 do (SETQ PORT (\TCP.SELECT.PORT)) (ARPACMD TCPFTPCON "PORT" (\TCPFTP.PORT.STRING PORT) (QUOTE (200))) (SETQ STREAM (TCP.OPEN NIL NIL PORT (QUOTE PASSIVE) ACCESS NIL (COND (FOR.FILE.TRANSFER (CONSTANT (BQUOTE (MAXSEG %, BYTESPERPAGE WHENCLOSEDFN \TCPFTP.DATA.CLOSED))))))) (COND (STREAM (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with STREAM) (RETURN))) finally (* * We give up. Place a NIL in the datastream field so the client who was trying to accept the data connection will realize we couldn't succeed) (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL)) (AND (TYPENAMEP EVENT (QUOTE EVENT)) (NOTIFY.EVENT EVENT)) (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))) ) (\TCPFTP.PORT.STRING (LAMBDA (PORT) (* ejs%: "26-Apr-85 11:54") (* * Returns "h1,h2,h3,h4,p1,p3" corresponding to bytes of local IP host and PORT for port command) (LET ((IPADDRESS (\LOCAL.IP.ADDRESS))) (CONCAT (LOADBYTE IPADDRESS 24 8) "," (LOADBYTE IPADDRESS 16 8) "," (LOADBYTE IPADDRESS 8 8) "," (LOADBYTE IPADDRESS 0 8) "," (LOADBYTE PORT 8 8) "," (LOADBYTE PORT 0 8)))) ) (\TCPFTP.SPAWN.DATACONNECTION (LAMBDA (TCPFTPCON ACCESS FOR.FILE.TRANSFER) (* ejs%: "26-Sep-86 19:21") (* * Called from TCPFTP device methods like \TCPFTP.OPENFILE. Spawns a process to wait for the server program to open a data connection to us. Returns a CONS consisting of the spawned process handle and an event which will be notified when the server has connected to us. This function MUST be called prior to any TCPFTP operations which would cause the server to try to open a data connection to us (otherwise, the server might try to open the connection before we're prepared to accept it)) (LET* ((EVENT (CREATE.EVENT)) (PROCESS (ADD.PROCESS (BQUOTE (\TCPFTP.OPEN.DATA.CONNECTION (QUOTE %, TCPFTPCON) (QUOTE %, ACCESS) %, EVENT %, FOR.FILE.TRANSFER))))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (PROCESS INSTREAM OUTSTREAM) (DEL.PROCESS PROCESS) (* CLOSEF? INSTREAM) (* CLOSEF? OUTSTREAM) NIL)) PROCESS (fetch (TCPFTPCON TCPIN) of TCPFTPCON) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (CONS PROCESS EVENT))) ) (\TCPFTP.READ.UNTIL.EOF [LAMBDA (DATASTREAM) (* ; "Edited 20-Jun-89 19:41 by welch") (* ;;; "This function is used to avoid possible deadlock in the case where the stream is opened and closed immediately. ") (PROG ((TCB (fetch (TCPSTREAM TCB) of DATASTREAM)) (TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM))) (WITH.MONITOR \TCPFTP.DATACONNECTION.LOCK (if (NOT (EOFP DATASTREAM)) then (while (\QUEUEHEAD (fetch TCB.INPUT.QUEUE of TCB)) do (\TCP.GET.SEGMENT DATASTREAM)) (* ;; "read to the end of the file.") (while (NOT (EOFP DATASTREAM)) do (BIN DATASTREAM))))]) (\TCPFTP.TRANSFER.COMPLETE [LAMBDA (DATASTREAM) (* ; "Edited 24-May-89 14:12 by welch") (LET ((TCPFTPCON (fetch (TCPDATASTREAM TCPFTPCON) of DATASTREAM))) (STREAMPROP DATASTREAM 'AFTERCLOSE NIL) (COND ((AND TCPFTPCON (NOT (fetch (TCPDATASTREAM SEENEOS) of DATASTREAM))) [COND ((OPENP DATASTREAM 'INPUT) (TCP.CLOSE.SENDER (TCP.OTHER.STREAM DATASTREAM] (replace (TCPDATASTREAM SEENEOS) of DATASTREAM with T) (replace (TCPDATASTREAM TCPCONTROLDEVICE) of DATASTREAM with NIL) (replace (TCPDATASTREAM TCPFTPCON) of DATASTREAM with NIL) (\TCPFTP.RELEASE.CONNECTION TCPFTPCON]) (\TCPFTP.WAIT.FOR.DATACONNECTION (LAMBDA (DEVICE TCPFTPCON PROCESS.AND.EVENT ACCESS) (* ejs%: "26-Sep-86 18:30") (* * EVENT is a cons of PROCESS and a real event. PROCESS is the process trying to open the connection; EVENT is an event which is notified when the process succeeds or fails to open the connection to the server) (LET (STREAM) (AWAIT.EVENT (CDR PROCESS.AND.EVENT) 120000) (COND ((NULL (SETQ STREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON))) (* * A NIL in this field means the local client code was unable to open the connection to the server program.) NIL) ((OPENP STREAM ACCESS) (replace (TCPDATASTREAM TCPCONTROLDEVICE) of STREAM with DEVICE) STREAM)))) ) (\TCPFTP.DELETE.CONNECTION (LAMBDA (TCPFTPCON DEVICE SENDBYE) (* ejs%: "15-Nov-86 15:09") (LET ((INSTREAM (fetch (TCPFTPCON TCPIN) of TCPFTPCON))) (COND (SENDBYE (NLSETQ (ARPACMD TCPFTPCON "BYE" NIL (QUOTE (221 500)))))) (COND (INSTREAM (DEL.PROCESS (fetch (TCP.CONTROL.BLOCK TCB.PROCESS) of (fetch (TCPSTREAM TCB) of INSTREAM))))) (replace (FDEV DEVICEINFO) of DEVICE with (DREMOVE TCPFTPCON (fetch (FDEV DEVICEINFO) of DEVICE))))) ) ) (RPAQ? \TCPFTP.DATACONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Data Connection Lock")) (RPAQ? \TCPFTP.CONNECTION.LOCK (CREATE.MONITORLOCK "TCPFTP Connection Lock")) (RPAQ? \TCPFTP.IDLE.TIMEOUT (TIMES 10 60 1000)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TCPFTP.DATACONNECTION.LOCK \TCPFTP.CONNECTION.LOCK \TCPFTP.IDLE.TIMEOUT) ) (FILESLOAD (SYSLOAD) TCPNAMES TCP) (\TCPFTP.INIT) (RPAQQ TCPFTP.DEFAULT.FILETYPES ((NIL . TEXT) (DFASL . BINARY) (dfasl . BINARY) (LCOM . BINARY) (lcom . BINARY) (DCOM . BINARY) (dcom . BINARY) (LISP . TEXT) (lisp . TEXT) (LSP . TEXT) (lsp . TEXT) (RST . BINARY) (rst . BINARY) (BIN . BINARY) (bin . BINARY) (TXT . TEXT) (txt . TEXT) (TEXT . TEXT) (text . TEXT) (c . TEXT) (h . TEXT) (o . BINARY) (TEDIT . BINARY) (tedit . BINARY) (DISPLAYFONT . BINARY) (WD . BINARY))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS TCPFTP COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1900 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4143 7185 (ARPACMD 4153 . 5446) (FTPHELP 5448 . 5565) (CMDREADCODE 5567 . 5671) ( CMDREAD 5673 . 5800) (DISCARDLINE 5802 . 6196) (GETLINE 6198 . 6484) (\TCPFTP.INPUT 6486 . 7041) ( TELNET.EOL 7043 . 7183)) (7526 40072 (\TCPFTP.CONTROL.CLOSED 7536 . 8004) (\TCPFTP.GET.OSTYPE 8006 . 8252) (\TCPFTP.EVENTFN 8254 . 8834) (\TCPFTP.HOSTNAMEP 8836 . 11823) (\GET.TCPFTP.CONNECTION 11825 . 12570) (\TCPFTP.OPEN.CONNECTION 12572 . 13893) (\TCPFTP.ASSURE.CLEANUP 13895 . 14215) (\TCPFTP.CLEANUP 14217 . 15408) (\TCPFTP.RELEASE.CONNECTION 15410 . 15723) (\TCPFTP.LOGIN 15725 . 17870) ( \TCPFTP.DELETEFILE 17872 . 18309) (\TCPFTP.DIRECTORYNAMEP 18311 . 18965) (\TCPFTP.ENDOFSTREAMOP 18967 . 19118) (\TCPFTP.GENERATEFILES 19120 . 22881) (\TCPFTP.GENERATENEXTFILE 22883 . 27772) ( \TCPFTP.GETFILENAME 27774 . 30946) (\TCPFTP.GETFILEINFO 30948 . 31131) (\TCPFTP.SETFILEINFO 31133 . 31257) (\TCPFTP.RENAMEFILE 31259 . 32187) (\TCPFTP.CONNECT 32189 . 32726) (\TCPFTP.OPENFILE 32728 . 38498) (\TCPFTP.CLOSE 38500 . 38868) (\TCPFTP.FLUSH 38870 . 39118) (\TCPFTP.INIT 39120 . 39320) ( SET.TCP.EOL.CONVENTION 39322 . 40070)) (41953 48826 (\TCP.BYE 41963 . 42548) (\TCPFTP.MAYBE.ABORT 42550 . 43295) (\TCPFTP.DATA.CLOSED 43297 . 43468) (\TCPFTP.OPEN.DATA.CONNECTION 43470 . 44677) ( \TCPFTP.PORT.STRING 44679 . 45060) (\TCPFTP.SPAWN.DATACONNECTION 45062 . 46078) ( \TCPFTP.READ.UNTIL.EOF 46080 . 46897) (\TCPFTP.TRANSFER.COMPLETE 46899 . 47705) ( \TCPFTP.WAIT.FOR.DATACONNECTION 47707 . 48384) (\TCPFTP.DELETE.CONNECTION 48386 . 48824))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPFTPSRV b/obsolete/tcp/TCPFTPSRV deleted file mode 100644 index 1e95bbcd..00000000 --- a/obsolete/tcp/TCPFTPSRV +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "13-Sep-90 15:07:59" {DSK}TCP>TCPFTPSRV.;6 55339 changes to%: (FNS TCPFTP.SERVER.MERGE.PATHNAMES TCPFTP.SERVER.PATH TCPFTP.SERVER.LIST TCPFTP.SERVER.RETRIEVE) previous date%: "11-Sep-90 13:34:33" {DSK}TCP>TCPFTPSRV.;5) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPFTPSRVCOMS) (RPAQQ TCPFTPSRVCOMS ((FNS TCPFTP.SERVER TCPFTP.SERVER.ABORTED TCPFTP.SERVER.ACCOUNT TCPFTP.SERVER.APPEND TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTP.SERVER.COMMAND.LOOP TCPFTP.SERVER.CONNECTED.INFO TCPFTP.SERVER.DELETE TCPFTP.SERVER.DIRECTORY TCPFTP.SERVER.EXIT TCPFTP.SERVER.IDLE.INFO TCPFTP.SERVER.LIST TCPFTP.SERVER.MERGE.PATHNAMES TCPFTP.SERVER.MODE TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTP.SERVER.PARSE.PORT TCPFTP.SERVER.PASSWORD TCPFTP.SERVER.PATH TCPFTP.SERVER.PORT TCPFTP.SERVER.PROCESS TCPFTP.SERVER.RENAME.FROM TCPFTP.SERVER.RENAME.TO TCPFTP.SERVER.RESPONSE TCPFTP.SERVER.RETRIEVE TCPFTP.SERVER.RETURN.FILE TCPFTP.SERVER.STORE TCPFTP.SERVER.STRUCTURE TCPFTP.SERVER.TYPE TCPFTP.SERVER.USER TCPFTP.SERVER.VERBOSE.LIST TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTP.UNIX.LS.DATE) (INITVARS (TCPFTP.SERVER.HERALD.STRING "Venue Medley FTP Service 1.0 at your service") (TCPFTP.SERVER.USE.TOPS20.SYNTAX NIL) (TCPFTP.SERVER.RETRYCOUNT 5)) (GLOBALVARS TCPFTP.SERVER.HERALD.STRING TCPFTP.SERVER.USE.TOPS20.SYNTAX TCPFTP.SERVER.RETRYCOUNT) (FILES (SYSLOAD) TCPFTP))) (DEFINEQ (TCPFTP.SERVER [LAMBDA (PORT DEFAULT.FILE.PATH) (* ; "Edited 24-Aug-87 17:57 by scp") (* * This is the TCP-based FTP server top-level) (ADD.PROCESS `(TCPFTP.SERVER.PROCESS ,PORT ,DEFAULT.FILE.PATH) 'RESTARTABLE 'HARDRESET]) (TCPFTP.SERVER.ABORTED [LAMBDA (INSTREAM OUTSTREAM) (* ejs%: "20-Mar-86 19:53") (TCPFTP.SERVER.EXIT INSTREAM OUTSTREAM]) (TCPFTP.SERVER.ACCOUNT [LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 11:40") (* * This function parses USER commands) (LET ((ACCT (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL))) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG ACCT T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (TCPFTP.SERVER.RESPONSE 230 "You sure are formal!" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.APPEND [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH) (* ejs%: "24-Mar-86 14:07") (* * This function parses USER commands) (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T)) (TRUENAME (CAR (NLSETQ (OR (INFILEP PACKED.FILENAME) (OUTFILEP PACKED.FILENAME] (COND (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (COND [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'APPEND NIL `((TYPE %, TYPE] (COND [FILESTREAM (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for append to " (FULLNAME FILESTREAM)) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT T ))) (COND (DATASTREAM [replace (STREAM ENDOFSTREAMOP) of DATASTREAM with (FUNCTION (LAMBDA (STREAM) (ERROR!] (RESETLST (RESETSAVE (COND ((EQ TYPE 'BINARY) (COPYBYTES DATASTREAM FILESTREAM)) (T (COPYCHARS DATASTREAM FILESTREAM ))) (LIST [FUNCTION (LAMBDA (FILESTREAM TCPFTPCON) (CLOSEF? FILESTREAM) (  TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTPCON) (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON] FILESTREAM TCPFTPCON] (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON] (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "Unable to create output filename - " PACKED.FILENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.CLOSE.DATA.CONNECTION [LAMBDA (TCPFTPCON) (* ejs%: "20-Mar-86 17:53") (LET ((DATASTREAM (fetch (TCPFTPCON DATASTREAM) of TCPFTPCON)) (EVENT (fetch (TCPFTPCON BUSY?) of TCPFTPCON))) (CLOSEF? DATASTREAM) (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with NIL) (replace (TCPFTPCON BUSY?) of TCPFTPCON with NIL) (NOTIFY.EVENT EVENT) T]) (TCPFTP.SERVER.COMMAND.LOOP [LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM PATH) (* ; "Edited 31-Aug-90 17:15 by gadener") (DECLARE (SPECVARS TCPFTPCON COMMAND)) (LET ([COMMAND.RDTBL (DEFERREDCONSTANT (PROG [(R (COPYREADTABLE 'ORIG] (SETBRK NIL NIL R) (SETSYNTAX '%% 'OTHER R) (SETSEPR '(13 10 31 32) NIL R) (RETURN R] (TCPFTPCON (create TCPFTPCON TCPIN _ CONTROL.INPUT.STREAM TCPOUT _ CONTROL.OUTPUT.STREAM)) (TYPE TCP.DEFAULTFILETYPE) RENAME.FROM.FILE LAST.COMMAND USERPORT) (OR PATH (SETQ PATH "{DSK}")) (while (AND (OPENP CONTROL.INPUT.STREAM 'INPUT) (OPENP CONTROL.OUTPUT.STREAM 'OUTPUT) (NOT (EOFP CONTROL.INPUT.STREAM))) first [PROCESSPROP (THIS.PROCESS) 'NAME (CONCAT "FTP#" (\IP.ADDRESS.TO.STRING (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of (fetch (TCPSTREAM TCB) of CONTROL.INPUT.STREAM ] do (LET [(COMMAND (U-CASE (CAR (NLSETQ (READ CONTROL.INPUT.STREAM COMMAND.RDTBL] [COND ((AND (OPENP CONTROL.INPUT.STREAM 'INPUT) (NOT (EOFP CONTROL.INPUT.STREAM))) (COND ([NOT (FMEMB COMMAND '(QUIT REIN ABOR NOOP NIL] (BIN CONTROL.INPUT.STREAM] (* Advance past the space preceding  the argument) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG T "> " COMMAND " "))) (SELECTQ COMMAND (USER (TCPFTP.SERVER.USER TCPFTPCON COMMAND.RDTBL)) (PASS (TCPFTP.SERVER.PASSWORD TCPFTPCON COMMAND.RDTBL)) (ACCT (TCPFTP.SERVER.ACCOUNT TCPFTPCON COMMAND.RDTBL)) (CWD (SETQ PATH (OR (TCPFTP.SERVER.PATH TCPFTPCON COMMAND.RDTBL PATH) PATH))) (PWD (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Default pathname is " PATH) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (PORT (SETQ USERPORT (OR (TCPFTP.SERVER.PORT TCPFTPCON COMMAND.RDTBL) USERPORT))) (TYPE (SETQ TYPE (OR (TCPFTP.SERVER.TYPE TCPFTPCON COMMAND.RDTBL) TYPE))) (MODE (TCPFTP.SERVER.MODE TCPFTPCON COMMAND.RDTBL)) (STRU (TCPFTP.SERVER.STRUCTURE TCPFTPCON COMMAND.RDTBL)) (* ;; "Depending on the COMMAND (LIST -> verbose), TCPFTP.SERVER.LIST will return a verbose listing or a simple list of file names ") ((NLST LIST) (* ;  "Depending on the COMMAND, TCPFTP.SERVER.LIST will return") (TCPFTP.SERVER.LIST TCPFTPCON COMMAND.RDTBL USERPORT PATH COMMAND)) (RETR (TCPFTP.SERVER.RETRIEVE TCPFTPCON COMMAND.RDTBL USERPORT TYPE PATH)) (STOR (TCPFTP.SERVER.STORE TCPFTPCON COMMAND.RDTBL USERPORT TYPE PATH )) (APPE (TCPFTP.SERVER.APPEND TCPFTPCON COMMAND.RDTBL USERPORT TYPE PATH)) (DELE (TCPFTP.SERVER.DELETE TCPFTPCON COMMAND.RDTBL PATH)) (RNFR (SETQ RENAME.FROM.FILE (TCPFTP.SERVER.RENAME.FROM TCPFTPCON COMMAND.RDTBL PATH))) (RNTO (COND ((EQ LAST.COMMAND 'RNFR) (TCPFTP.SERVER.RENAME.TO TCPFTPCON COMMAND.RDTBL PATH RENAME.FROM.FILE)) (T (TCPFTP.SERVER.RESPONSE 503 "I need a RNFR command immediately preceding a RNTO command." CONTROL.OUTPUT.STREAM)))) (REIN (DISCARDLINE CONTROL.INPUT.STREAM) (TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTPCON) (TCPFTP.SERVER.RESPONSE 220 "Go ahead" CONTROL.OUTPUT.STREAM)) (QUIT (DISCARDLINE CONTROL.INPUT.STREAM) (TCPFTP.SERVER.WAIT.FOR.IDLE TCPFTPCON) (TCPFTP.SERVER.RESPONSE 221 "It's been real" CONTROL.OUTPUT.STREAM) (RETURN)) (NOOP (TCPFTP.SERVER.RESPONSE 200 "I'm still here" CONTROL.OUTPUT.STREAM)) (NIL (* Error reading from control stream) (ERROR!)) (PROGN (DISCARDLINE CONTROL.INPUT.STREAM) (TCPFTP.SERVER.RESPONSE 502 (CONCAT "Unrecognized command " COMMAND) CONTROL.OUTPUT.STREAM))) (SETQ LAST.COMMAND COMMAND]) (TCPFTP.SERVER.CONNECTED.INFO [LAMBDA (PROCESS BUTTON) (* ejs%: "21-Mar-86 17:07") [PROMPTPRINT "TCPFTP server connected to " (IPHOSTNAME (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of (fetch (TCPSTREAM TCB) of CONTROL.INPUT.STREAM ] (COND ((EQ BUTTON 'MIDDLE) (COND ((AND (BOUNDP 'TCPFTPCON) (fetch (TCPFTPCON BUSY?) of TCPFTPCON)) (printout PROMPTWINDOW T " Server is busy; last command was " (OR (AND (BOUNDP 'COMMAND) COMMAND) "???"))) ((AND (BOUNDP COMMAND) COMMAND) (printout PROMPTWINDOW T " Last command was " COMMAND]) (TCPFTP.SERVER.DELETE [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH) (* ejs%: " 7-Apr-86 11:42") (* * This function parses USER commands) (LET* ((FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T T)) TRUENAME) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (COND [PACKED.FILENAME (COND ([SETQ TRUENAME (CAR (NLSETQ (DELFILE PACKED.FILENAME] (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Deleted " (COND (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY TRUENAME) 'TOPS-20)) (T TRUENAME))) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't delete file " TRUENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON] (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.DIRECTORY [LAMBDA (TCPFTPCON RDTBL USERPORT DEFAULT.PATH COMMAND) (* ; "Edited 30-Aug-90 17:47 by gadener") (* * This function parses USER commands) (LET* [(PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (FILES (CAR (NLSETQ (DIRECTORY (TCPFTP.SERVER.MERGE.PATHNAMES PATH DEFAULT.PATH T] (COND (FTPDEBUGFLG (printout FTPDEBUGLOG PATH T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for directory of " PATH " [" (LENGTH FILES) " file name(s)]") (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT))) (COND (DATASTREAM (for FILE in FILES do (PRIN1 [COND (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY FILE) 'TOPS-20)) (T (TCPFTP.SERVER.RETURN.FILE FILE DEFAULT.PATH 'INFO] DATASTREAM) (TERPRI DATASTREAM) finally (  TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTPCON)) (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON ]) (TCPFTP.SERVER.EXIT [LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM) (* ejs%: "20-Mar-86 19:52") (CLOSEF? CONTROL.OUTPUT.STREAM) (CLOSEF? CONTROL.INPUT.STREAM]) (TCPFTP.SERVER.IDLE.INFO [LAMBDA (PROCESS BUTTON) (* ejs%: "21-Mar-86 16:58") (PROMPTPRINT "Idle TCPFTP server"]) (TCPFTP.SERVER.LIST [LAMBDA (TCPFTPCON RDTBL USERPORT DEFAULT.PATH COMMAND) (* ; "Edited 13-Sep-90 14:41 by gadener") (* * This function parses USER commands) (LET* ((PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) [FILES (CAR (NLSETQ (DIRECTORY (TCPFTP.SERVER.MERGE.PATHNAMES PATH DEFAULT.PATH T] (NFILES (LENGTH FILES))) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG PATH T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for directory " DEFAULT.PATH " [" NFILES " file name(s)]") (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT))) (COND (DATASTREAM (for FILE in FILES do (PRIN1 (COND (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY FILE) 'TOPS-20)) (T (TCPFTP.SERVER.RETURN.FILE FILE DEFAULT.PATH COMMAND))) DATASTREAM) (TERPRI DATASTREAM) finally (  TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTPCON)) (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON ]) (TCPFTP.SERVER.MERGE.PATHNAMES [LAMBDA (NAME DEFAULT.PATH NODEVICE.IF.LOCAL NOVERSION.IF.LOCAL DIRFLG) (* ; "Edited 13-Sep-90 14:16 by gadener") (LET* ((NAMEFIELDS (UNPACKFILENAME.STRING NAME NIL DIRFLG)) (DEFAULTFIELDS (UNPACKFILENAME.STRING DEFAULT.PATH NIL DIRFLG)) [HOST (OR (LISTGET NAMEFIELDS 'HOST) (LISTGET DEFAULTFIELDS 'HOST] [HOSTSPECIFIED (NOT (NULL (LISTGET NAMEFIELDS 'HOST] DIRECTORY1) (PACKFILENAME.STRING 'HOST HOST 'DEVICE [COND ((AND NODEVICE.IF.LOCAL (EQ HOST 'DSK)) NIL) ((OR (LISTGET NAMEFIELDS 'DEVICE) (COND (HOSTSPECIFIED NIL) (T (LISTGET DEFAULTFIELDS 'DEVICE] 'DIRECTORY [COND ((LISTGET NAMEFIELDS 'DIRECTORY)) ([COND [(SETQ DIRECTORY1 (LISTGET NAMEFIELDS 'SUBDIRECTORY] ((SETQ DIRECTORY1 (LISTGET NAMEFIELDS 'RELATIVEDIRECTORY] (CL:CONCATENATE 'STRING (LISTGET DEFAULTFIELDS 'DIRECTORY) ">" DIRECTORY1)) (HOSTSPECIFIED NIL) (T (LISTGET DEFAULTFIELDS 'DIRECTORY] 'NAME (OR (LISTGET NAMEFIELDS 'NAME) (LISTGET DEFAULTFIELDS 'NAME)) 'EXTENSION (OR (LISTGET NAMEFIELDS 'EXTENSION) (LISTGET DEFAULTFIELDS 'EXTENSION)) 'VERSION (COND ((AND NOVERSION.IF.LOCAL (EQ HOST 'DSK)) NIL) (T (OR (LISTGET NAMEFIELDS 'VERSION) (LISTGET DEFAULTFIELDS 'VERSION]) (TCPFTP.SERVER.MODE [LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 15:38") (* * This function parses USER commands) (LET ((MODE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (RESPONSE.STRING) (ERRORFLG)) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG MODE T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SELECTQ MODE (S (SETQ RESPONSE.STRING "Now in stream mode")) (PROGN (SETQ RESPONSE.STRING (CONCAT "Unsupported mode - " MODE)) (SETQ ERRORFLG T))) (COND (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) NIL) (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.OPEN.DATA.CONNECTION [LAMBDA (TCPFTPCON USERPORT FORINPUT) (* ejs%: "11-Apr-86 16:09") (* * This function handles opening data connections and marking said tcp  connections as busy) (bind (TCB _ (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON))) DATASTREAM for RETRIES from 0 to TCPFTP.SERVER.RETRYCOUNT until (SETQ DATASTREAM (TCP.OPEN (COND (USERPORT (CAR USERPORT)) (T (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of TCB))) (COND (USERPORT (CDR USERPORT)) (T (fetch (TCP.CONTROL.BLOCK TCB.DST.PORT) of TCB))) (SUB1 (fetch (TCP.CONTROL.BLOCK TCB.SRC.PORT) of TCB)) 'ACTIVE (COND (FORINPUT 'INPUT) (T 'OUTPUT)) T)) finally (RETURN (COND (DATASTREAM (replace (TCPFTPCON DATASTREAM) of TCPFTPCON with DATASTREAM ) (replace (TCPFTPCON BUSY?) of TCPFTPCON with (CREATE.EVENT )) (* TELNET standard EOL convention on  DATASTREAMS) (SETFILEINFO DATASTREAM 'EOL 'CRLF) DATASTREAM) (T (TCPFTP.SERVER.RESPONSE 426 "Couldn't open data connection" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) NIL]) (TCPFTP.SERVER.PARSE.PORT [LAMBDA (PSTRING) (* ; "Edited 28-May-87 18:00 by jop") (* ;;; "Parse a port string, in the form 'h1,h2,h3,h4,p1,p2' , where the hx are bytes from an internet host address, and the px are bytes from a 16-bit TCP port number") (LET ((IPADDRESS (CREATECELL \FIXP)) (TCPPORT 0)) (bind (BYTECOUNTER _ 0) (ACCUMULATOR _ 0) ERRORFLG for CH instring PSTRING do (COND ((EQ CH (CHARCODE %,)) (COND ((IGREATERP BYTECOUNTER 3) (SETQ TCPPORT (IPLUS (ITIMES TCPPORT 256) ACCUMULATOR))) (T (\PUTBASEBYTE IPADDRESS BYTECOUNTER ACCUMULATOR))) (SETQ ACCUMULATOR 0) (add BYTECOUNTER 1)) [(AND (ILEQ CH (CHARCODE 9)) (IGEQ CH (CHARCODE 0))) (SETQ ACCUMULATOR (IPLUS (IDIFFERENCE CH (CHARCODE 0)) (ITIMES ACCUMULATOR 10))) (COND ((IGREATERP ACCUMULATOR 255) (SETQ ERRORFLG T) (GO $$OUT] (T (SETQ ERRORFLG T) (GO $$OUT))) finally (COND (ERRORFLG (RETURN NIL)) (T (COND ((NEQ BYTECOUNTER 5) (RETURN NIL)) (T (RETURN (CONS IPADDRESS (IPLUS (ITIMES TCPPORT 256) ACCUMULATOR]) (TCPFTP.SERVER.PASSWORD [LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 11:39") (* * This function parses USER commands) (LET ((PASS (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL))) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG PASS T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (TCPFTP.SERVER.RESPONSE 230 "OK, so you're logged in. Now what?" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.PATH [LAMBDA (TCPFTPCON COMMAND.RDTBL OLDPATH) (* ; "Edited 13-Sep-90 13:37 by gadener") (LET* ((PATH (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) COMMAND.RDTBL)) (TRUEPATH (TCPFTP.SERVER.MERGE.PATHNAMES PATH OLDPATH NIL T 'RETURN)) (* ;; "The last argument, RETURN, makes sure that even though a directory was specified as /a/b/c, we really meant /a/b/c") ) (IF TRUEPATH THEN (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Default pathname now " TRUEPATH) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) TRUEPATH else (TCPFTP.SERVER.RESPONSE 501 (CONCAT "Couldn't interpret " NEWPATH " as a pathname") (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) NIL]) (TCPFTP.SERVER.PORT [LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 11:41") (LET* ((PORTSTRING (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (PARSEDPORT (TCPFTP.SERVER.PARSE.PORT PORTSTRING))) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG PORTSTRING T))) (COND (PARSEDPORT (TCPFTP.SERVER.RESPONSE 200 (CONCAT "User port now " PORTSTRING) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) PARSEDPORT) (T (TCPFTP.SERVER.RESPONSE 501 (CONCAT "Couldn't parse port specification " PORTSTRING) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) NIL]) (TCPFTP.SERVER.PROCESS [LAMBDA (PORT DEFAULT.FILE.PATH) (* ; "Edited 24-Aug-87 17:55 by scp") (* * This is the TCP-based FTP server top-level) (PROCESSPROP (THIS.PROCESS) 'INFOHOOK (FUNCTION TCPFTP.SERVER.IDLE.INFO)) (LET* ((CONTROL.INPUT.STREAM (TCP.OPEN NIL NIL (OR PORT \TCP.FTP.PORT) 'PASSIVE 'INPUT)) (CONTROL.OUTPUT.STREAM (TCP.OTHER.STREAM CONTROL.INPUT.STREAM))) (* EOL convention -> TELNET Standard) (SETFILEINFO CONTROL.OUTPUT.STREAM 'EOL 'CRLF) (* Say hello quickly) (TCPFTP.SERVER.RESPONSE 220 TCPFTP.SERVER.HERALD.STRING CONTROL.OUTPUT.STREAM) (* Spawn a new server) (ADD.PROCESS (LIST (FUNCTION TCPFTP.SERVER) PORT (KWOTE DEFAULT.FILE.PATH)) 'RESTARTABLE 'HARDRESET) (* Now that we're "established,"  errors are fatal) (PROCESSPROP (THIS.PROCESS) 'RESTARTABLE 'NO) (PROCESSPROP (THIS.PROCESS) 'INFOHOOK (FUNCTION TCPFTP.SERVER.CONNECTED.INFO)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM) (COND (RESETSTATE (TCPFTP.SERVER.ABORTED CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM)) (T (TCPFTP.SERVER.EXIT CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM] CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM)) (TCPFTP.SERVER.COMMAND.LOOP CONTROL.INPUT.STREAM CONTROL.OUTPUT.STREAM DEFAULT.FILE.PATH]) (TCPFTP.SERVER.RENAME.FROM [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH) (* ejs%: "24-Mar-86 14:16") (* * This function parses RNFR commands) (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T)) (TRUENAME (CAR (NLSETQ (INFILEP PACKED.FILENAME] (COND (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (COND (TRUENAME (TCPFTP.SERVER.RESPONSE 350 (CONCAT "About to rename " (COND (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY TRUENAME) 'TOPS-20)) (T TRUENAME))) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) TRUENAME) (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) NIL]) (TCPFTP.SERVER.RENAME.TO [LAMBDA (TCPFTPCON RDTBL DEFAULT.PATH FROM.FILE) (* ejs%: "24-Mar-86 14:34") (* * This function parses RNTO commands) (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T)) (TRUENAME (CAR (NLSETQ (OUTFILEP PACKED.FILENAME] (COND (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (COND (TRUENAME (RENAMEFILE FROM.FILE TRUENAME) (TCPFTP.SERVER.RESPONSE 250 (CONCAT "Renamed " (COND (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING ( PACKFILENAME.STRING 'HOST NIL 'BODY FROM.FILE) 'TOPS-20)) (T FROM.FILE)) " to " (COND (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING ( PACKFILENAME.STRING 'HOST NIL 'BODY TRUENAME) 'TOPS-20)) (T TRUENAME))) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (T (TCPFTP.SERVER.RESPONSE 553 (CONCAT "Couldn't make an output file named " PACKED.FILENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.RESPONSE [LAMBDA (CODE STRING STREAM) (* edited%: "21-Mar-86 11:44") (RESETFORM (RADIX 10) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG "> " CODE " " STRING T))) (printout STREAM CODE " " STRING T)) (FORCEOUTPUT STREAM]) (TCPFTP.SERVER.RETRIEVE [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH) (* ; "Edited 13-Sep-90 14:59 by gadener") (* * This function parses USER commands) (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T)) (TRUENAME (CAR (NLSETQ (INFILEP PACKED.FILENAME] (COND (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (COND [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'INPUT 'OLD `((TYPE %, TYPE] (COND [FILESTREAM (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening " TYPE " data connection for " (COND (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (FULLNAME FILESTREAM) 'TOPS-20)) (T (FULLNAME FILESTREAM))) " (" [\IP.ADDRESS.TO.STRING (OR (CAR USERPORT) (fetch (TCP.CONTROL.BLOCK TCB.DST.HOST) of (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON] "," [OR (CDR USERPORT) (fetch (TCP.CONTROL.BLOCK TCB.DST.PORT) of (fetch (TCPSTREAM TCB) of (fetch (TCPFTPCON TCPIN) of TCPFTPCON] ") (" (OR (GETFILEINFO FILESTREAM 'LENGTH) 0) " bytes).") (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT))) (COND (DATASTREAM (LET [(RESULT (NLSETQ (COND ((EQ TYPE 'BINARY) (COPYBYTES FILESTREAM DATASTREAM)) (T (COPYCHARS FILESTREAM DATASTREAM] (CLOSEF? FILESTREAM) (TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTPCON) (COND (RESULT (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON))) (T (TCPFTP.SERVER.RESPONSE 426 "Couldn't complete retrieve operation" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON] (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON] (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "File not found - " PACKED.FILENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.RETURN.FILE [LAMBDA (FILE DEFAULT.PATH COMMAND) (* ; "Edited 31-Aug-90 17:57 by gadener") (* ;; "If COMMAND is LIST , it will return a verbose listing of the file and some of its properties. If the command is NLIST, it will just return the filename with extension and version. ") (* ;; "Note that since the D-mahines don't have a true directory structure, it will return the relative pathname to the file , in relation to DEFAULT.PATH.") (LET* [(DEFAULT.PATH.STRING.LENGTH (NCHARS DEFAULT.PATH)) (PATH (SUBSTRING FILE (PLUS 1 DEFAULT.PATH.STRING.LENGTH))) (TAB (CHARACTER (CHARCODE TAB] (COND ((EQUAL COMMAND 'LIST) (CONCAT (GETFILEINFO FILE 'TYPE) TAB (GETFILEINFO FILE 'LENGTH) TAB (GETFILEINFO FILE 'WRITEDATE) TAB (GETFILEINFO FILE 'AUTHOR) TAB PATH)) (T PATH]) (TCPFTP.SERVER.STORE [LAMBDA (TCPFTPCON RDTBL USERPORT TYPE DEFAULT.PATH) (* ejs%: "24-Mar-86 15:27") (* * This function parses USER commands) (LET* [(FILENAME (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (PACKED.FILENAME (TCPFTP.SERVER.MERGE.PATHNAMES FILENAME DEFAULT.PATH T)) (TRUENAME (CAR (NLSETQ (OUTFILEP PACKED.FILENAME] (COND (FTPDEBUGFLG (printout FTPDEBUGLOG FILENAME T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (COND [TRUENAME (LET [(FILESTREAM (CAR (NLSETQ (OPENSTREAM TRUENAME 'OUTPUT 'NEW `((TYPE %, TYPE] (COND [FILESTREAM (TCPFTP.SERVER.RESPONSE 150 (CONCAT "Opening data connection for store of " (FULLNAME FILESTREAM)) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (LET ((DATASTREAM (TCPFTP.SERVER.OPEN.DATA.CONNECTION TCPFTPCON USERPORT T ))) (COND (DATASTREAM [replace (STREAM ENDOFSTREAMOP) of DATASTREAM with (FUNCTION (LAMBDA (STREAM) (ERROR!] (RESETLST (RESETSAVE (COND ((EQ TYPE 'BINARY) (COPYBYTES DATASTREAM FILESTREAM)) (T (COPYCHARS DATASTREAM FILESTREAM ))) (LIST [FUNCTION (LAMBDA (FILESTREAM TCPFTPCON) (CLOSEF? FILESTREAM) (  TCPFTP.SERVER.CLOSE.DATA.CONNECTION TCPFTPCON) (TCPFTP.SERVER.RESPONSE 226 "Data transfer complete" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON] FILESTREAM TCPFTPCON] (T (TCPFTP.SERVER.RESPONSE 450 (CONCAT "Couldn't open file " TRUENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON] (T (TCPFTP.SERVER.RESPONSE 550 (CONCAT "Unable to create output filename - " PACKED.FILENAME) (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.STRUCTURE [LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 14:08") (* * This function parses USER commands) (LET ((STRUCTURE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (RESPONSE.STRING) (ERRORFLG)) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG STRUCTURE T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SELECTQ STRUCTURE (F (SETQ RESPONSE.STRING "Now in stream mode")) (PROGN (SETQ RESPONSE.STRING (CONCAT "Unsupported mode - " STRUCTURE)) (SETQ ERRORFLG T))) (COND (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) NIL) (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.TYPE [LAMBDA (TCPFTPCON RDTBL) (* ejs%: "24-Mar-86 15:26") (* * This function parses USER commands) (LET* ((MAJOR.TYPE (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) [MINOR.TYPE (LET [(TERM.CHAR (BIN (fetch (TCPFTPCON TCPIN) of TCPFTPCON] (COND ((EQ TERM.CHAR (CHARCODE SPACE)) (READ (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL)) (T (SELECTQ MAJOR.TYPE (A 'N) (L 8) NIL] (RESPONSE.STRING) (ERRORFLG)) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG MAJOR.TYPE " " MINOR.TYPE T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (SELECTQ MAJOR.TYPE (A (SELECTQ MINOR.TYPE (N (SETQ RESPONSE.STRING "Type is now standard ASCII")) (PROGN (SETQ RESPONSE.STRING (CONCAT "ASCII subtype " MINOR.TYPE " not recognized")) (SETQ ERRORFLG T)))) (E (SETQ RESPONSE.STRING "EBCDIC not supported") (SETQ ERRORFLG T)) (I (SETQ RESPONSE.STRING "Type is now 8-bit binary")) (L (COND ((NEQ MINOR.TYPE 8) (SETQ RESPONSE.STRING (CONCAT "Binary byte size " MINOR.TYPE " not supported")) (SETQ ERRORFLG T)) (T (SETQ RESPONSE.STRING "Type is now 8-bit binary")))) NIL) (COND (ERRORFLG (TCPFTP.SERVER.RESPONSE 504 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) NIL) (T (TCPFTP.SERVER.RESPONSE 200 RESPONSE.STRING (fetch (TCPFTPCON TCPOUT) of TCPFTPCON)) (SELECTQ MAJOR.TYPE (A 'TEXT) 'BINARY]) (TCPFTP.SERVER.USER [LAMBDA (TCPFTPCON RDTBL) (* edited%: "21-Mar-86 11:39") (* * This function parses USER commands) (LET ((USER (RSTRING (fetch (TCPFTPCON TCPIN) of TCPFTPCON) RDTBL))) (COND (FTPDEBUGFLG (printout FTPDEBUGLOG USER T))) (DISCARDLINE (fetch (TCPFTPCON TCPIN) of TCPFTPCON)) (TCPFTP.SERVER.RESPONSE 230 "Hi, there!" (fetch (TCPFTPCON TCPOUT) of TCPFTPCON]) (TCPFTP.SERVER.VERBOSE.LIST [LAMBDA (FILE STREAM) (* edited%: "26-Mar-86 11:32") (printout STREAM (COND (TCPFTP.SERVER.USE.TOPS20.SYNTAX (REPACKFILENAME.STRING (PACKFILENAME.STRING 'HOST NIL 'BODY (FULLNAME FILE)) 'TOPS-20)) (T (FULLNAME FILE))) ";P775252;AFORYOURSELF," (FOLDHI (OR (GETFILEINFO FILE 'SIZE) 0) 4) "," (GETFILEINFO FILE 'CREATIONDATE) "," (GETFILEINFO FILE 'WRITEDATE) T]) (TCPFTP.SERVER.WAIT.FOR.IDLE [LAMBDA (TCPFTPCON) (* ejs%: "20-Mar-86 16:39") (bind BUSY? while (SETQ BUSY? (fetch (TCPFTPCON BUSY?) of TCPFTPCON)) do (AWAIT.EVENT BUSY?]) (TCPFTP.UNIX.LS.DATE [LAMBDA (FILE) (* edited%: "21-Mar-86 13:38") (LET* [(CREATIONDATE (GETFILEINFO FILE 'CREATIONDATE)) (MONTHPOS (STRPOS "-" CREATIONDATE)) (YEARPOS (STRPOS "-" CREATIONDATE (ADD1 MONTHPOS))) (TIMEPOS (ADD1 (STRPOS " " CREATIONDATE] (CONCAT (SUBSTRING CREATIONDATE (ADD1 MONTHPOS) (SUB1 YEARPOS)) " " (SUBSTRING CREATIONDATE 1 (SUB1 MONTHPOS)) " " (SUBSTRING CREATIONDATE TIMEPOS -4]) ) (RPAQ? TCPFTP.SERVER.HERALD.STRING "Venue Medley FTP Service 1.0 at your service") (RPAQ? TCPFTP.SERVER.USE.TOPS20.SYNTAX NIL) (RPAQ? TCPFTP.SERVER.RETRYCOUNT 5) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TCPFTP.SERVER.HERALD.STRING TCPFTP.SERVER.USE.TOPS20.SYNTAX TCPFTP.SERVER.RETRYCOUNT) ) (FILESLOAD (SYSLOAD) TCPFTP) (PUTPROPS TCPFTPSRV COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1782 54890 (TCPFTP.SERVER 1792 . 2089) (TCPFTP.SERVER.ABORTED 2091 . 2263) ( TCPFTP.SERVER.ACCOUNT 2265 . 2817) (TCPFTP.SERVER.APPEND 2819 . 6531) ( TCPFTP.SERVER.CLOSE.DATA.CONNECTION 6533 . 7031) (TCPFTP.SERVER.COMMAND.LOOP 7033 . 13702) ( TCPFTP.SERVER.CONNECTED.INFO 13704 . 14690) (TCPFTP.SERVER.DELETE 14692 . 16577) ( TCPFTP.SERVER.DIRECTORY 16579 . 18921) (TCPFTP.SERVER.EXIT 18923 . 19115) (TCPFTP.SERVER.IDLE.INFO 19117 . 19282) (TCPFTP.SERVER.LIST 19284 . 21609) (TCPFTP.SERVER.MERGE.PATHNAMES 21611 . 23718) ( TCPFTP.SERVER.MODE 23720 . 24743) (TCPFTP.SERVER.OPEN.DATA.CONNECTION 24745 . 27732) ( TCPFTP.SERVER.PARSE.PORT 27734 . 30442) (TCPFTP.SERVER.PASSWORD 30444 . 31090) (TCPFTP.SERVER.PATH 31092 . 32075) (TCPFTP.SERVER.PORT 32077 . 32886) (TCPFTP.SERVER.PROCESS 32888 . 35079) ( TCPFTP.SERVER.RENAME.FROM 35081 . 36653) (TCPFTP.SERVER.RENAME.TO 36655 . 39136) ( TCPFTP.SERVER.RESPONSE 39138 . 39457) (TCPFTP.SERVER.RETRIEVE 39459 . 44526) ( TCPFTP.SERVER.RETURN.FILE 44528 . 45581) (TCPFTP.SERVER.STORE 45583 . 49232) (TCPFTP.SERVER.STRUCTURE 49234 . 50287) (TCPFTP.SERVER.TYPE 50289 . 52577) (TCPFTP.SERVER.USER 52579 . 53118) ( TCPFTP.SERVER.VERBOSE.LIST 53120 . 54036) (TCPFTP.SERVER.WAIT.FOR.IDLE 54038 . 54285) ( TCPFTP.UNIX.LS.DATE 54287 . 54888))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPHTE b/obsolete/tcp/TCPHTE deleted file mode 100644 index dda05d9a..00000000 --- a/obsolete/tcp/TCPHTE +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP") (FILECREATED "12-Jun-90 17:31:06" {DSK}local>lde>lispcore>library>TCPHTE.;3 5753 changes to%: (VARS TCPHTECOMS) previous date%: "11-Feb-89 11:06:54" {DSK}local>lde>lispcore>library>TCPHTE.;2) (* ; " Copyright (c) 1985, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPHTECOMS) (RPAQQ TCPHTECOMS ((PROP MAKEFILE-ENVIRONMENT TCPHTE) (RECORDS HOSTS.TXT.ENTRY) (FNS \HTE.PARSE.ENTRY \HTE.READ.FILE \HTE.READ; \HTE.READLINE) (INITVARS (HOSTS.TEXT.DIRECTORIES) (\HTE.RDTBL)) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \HTE.RDTBL \IP.HOSTNAMES) (RECORDS HTELINE)))) (PUTPROPS TCPHTE MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP")) (DECLARE%: EVAL@COMPILE (DATATYPE HOSTS.TXT.ENTRY (HTE.TYPE HTE.ADDRESSES HTE.NAMES HTE.MACHINE.TYPE HTE.OS.TYPE HTE.PROTOCOLS)) ) (/DECLAREDATATYPE 'HOSTS.TXT.ENTRY '(POINTER POINTER POINTER POINTER POINTER POINTER) '((HOSTS.TXT.ENTRY 0 POINTER) (HOSTS.TXT.ENTRY 2 POINTER) (HOSTS.TXT.ENTRY 4 POINTER) (HOSTS.TXT.ENTRY 6 POINTER) (HOSTS.TXT.ENTRY 8 POINTER) (HOSTS.TXT.ENTRY 10 POINTER)) '12) (DEFINEQ (\HTE.PARSE.ENTRY [LAMBDA (ENTRY) (* ; "Edited 11-Feb-89 11:04 by akw:") (DECLARE (GLOBALVARS NETWORKOSTYPES)) (LET* [[NAMES (for NAME in (fetch (HTELINE NAMES) of ENTRY) collect (MKATOM (U-CASE NAME] (OSTYPE (CAR (fetch (HTELINE OS.TYPE) of ENTRY)) (MKATOM (U-CASE))) (HTE.ENTRY (create HOSTS.TXT.ENTRY HTE.TYPE _ (CAR (fetch (HTELINE TYPE) of ENTRY)) HTE.ADDRESSES _ (for X in (fetch (HTELINE ADDRESSES) of ENTRY) collect (\IP.READ.STRING.ADDRESS X)) HTE.NAMES _ NAMES HTE.MACHINE.TYPE _ [MKATOM (U-CASE (CAR (fetch (HTELINE MACHINE.TYPE ) of ENTRY] HTE.OS.TYPE _ [AND OSTYPE (SETQ OSTYPE (MKATOM (U-CASE OSTYPE] HTE.PROTOCOLS _ (for PROTOENTRY in (fetch (HTELINE PROTOCOLS ) of ENTRY) bind SLASH when (SETQ SLASH (STRPOS '/ PROTOENTRY)) collect (CONS (SUBATOM PROTOENTRY 1 (SUB1 SLASH)) (SUBATOM PROTOENTRY (ADD1 SLASH] (for NAME in NAMES do (PUTHASH NAME HTE.ENTRY \IP.HOSTNAMES]) (\HTE.READ.FILE (LAMBDA (FILE WANTEDTYPES) (* ; "Edited 24-May-88 16:57 by bvm") (DECLARE (GLOBALVARS \IP.HOSTNAMES \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ)) (OR WANTEDTYPES (SETQ WANTEDTYPES (QUOTE (HOST)))) (CL:WITH-OPEN-FILE (STREAM FILE) (LET ((FILENAME (FULLNAME STREAM)) (DATE (GETFILEINFO STREAM (QUOTE ICREATIONDATE))) ENTRY) (PRINTOUT PROMPTWINDOW T "Reading " FILENAME " of " (GDATE DATE (DATEFORMAT NO.SECONDS))) (CLRHASH \IP.HOSTNAMES) (until (EOFP STREAM) when (AND (SETQ ENTRY (\HTE.READLINE STREAM WANTEDTYPES)) (FMEMB (CAR (fetch (HTELINE TYPE) of ENTRY)) WANTEDTYPES)) do (\HTE.PARSE.ENTRY ENTRY)) (SETQ \TCP.LAST.HOSTS.FILE.DATE DATE) (SETQ \TCP.LAST.HOSTS.FILE.READ FILENAME)))) ) (\HTE.READ; (LAMBDA (FL RDTBL) (* ; "Edited 24-May-88 14:45 by bvm") (until (SELCHARQ (READCCODE FL) ((CR LF EOL) T) NIL)) NIL) ) (\HTE.READLINE (LAMBDA (STREAM WANTEDTYPES) (* ; "Edited 24-May-88 16:57 by bvm") (while (EQ (PEEKCCODE STREAM T) (CHARCODE ";")) do (\HTE.READ; STREAM)) (AND (NOT (EOFP STREAM)) (for FIELD# from 1 bind FIELDCONTENTS DONE (RDTBL _ (COND (\HTE.RDTBL) (T (SETQ \HTE.RDTBL (COPYREADTABLE (QUOTE ORIG))) (SETSEPR (CHARCODE (SPACE TAB %,)) NIL \HTE.RDTBL) (SETBRK (CHARCODE (":" ";" CR LF)) NIL \HTE.RDTBL) (READTABLEPROP \HTE.RDTBL (QUOTE CASEINSENSITIVE) T) \HTE.RDTBL))) until DONE collect (SETQ FIELDCONTENTS (until (SELCHARQ (SKIPSEPRCODES STREAM RDTBL) (":" (* ; "End of field") (READCCODE STREAM) T) (";" (* ; "end of line") (\HTE.READ; STREAM) (SETQ DONE T)) ((CR LF) (* ; "end of line--consume the terminator") (READCCODE STREAM) (SETQ DONE T)) (NIL (* ; "Eof") (SETQ DONE T)) NIL) collect (* ; "Read up to the next field delimiter") (if (EQ FIELD# 1) then (* ; "Canonicalize the type field") (READ STREAM RDTBL) else (RSTRING STREAM RDTBL)))) (if (AND (EQ FIELD# 1) WANTEDTYPES (NOT (FMEMB (CAR FIELDCONTENTS) WANTEDTYPES))) then (* ; "Don't care about this line") (OR DONE (\HTE.READ; STREAM)) (RETURN NIL)) FIELDCONTENTS))) ) ) (RPAQ? HOSTS.TEXT.DIRECTORIES ) (RPAQ? \HTE.RDTBL ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \HTE.RDTBL \IP.HOSTNAMES) ) (DECLARE%: EVAL@COMPILE (RECORD HTELINE (TYPE ADDRESSES NAMES MACHINE.TYPE OS.TYPE PROTOCOLS)) ) ) (PUTPROPS TCPHTE COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1360 5370 (\HTE.PARSE.ENTRY 1370 . 3378) (\HTE.READ.FILE 3380 . 4095) (\HTE.READ; 4097 . 4230) (\HTE.READLINE 4232 . 5368))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPIP.TEDIT b/obsolete/tcp/TCPIP.TEDIT deleted file mode 100644 index 11c83753..00000000 Binary files a/obsolete/tcp/TCPIP.TEDIT and /dev/null differ diff --git a/obsolete/tcp/TCPLLAR b/obsolete/tcp/TCPLLAR deleted file mode 100644 index 12e028d3..00000000 --- a/obsolete/tcp/TCPLLAR +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Aug-90 12:32:20" {DSK}ETHERNET>TCP>NEW>TCPLLAR.;3 22788 changes to%: (FNS \AR.DAEMON \AR.ENTER.RESOLUTION \AR.NOTE.RESOLUTION \AR.UPDATE.RESOLUTION \PRINTAR SPUTASSOC \AR.TRANSLATE.TO.10MB \AR.REQUEST.IP.TO.10MB \AR.REQUEST.IP.TO.3MB \AR.RESOLVE \AR.TRANSLATE.TO.3MB \HANDLE.RAW.AR) previous date%: " 6-Jan-89 15:18:06" {DSK}ETHERNET>TCP>NEW>TCPLLAR.;2) (* " Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPLLARCOMS) (RPAQQ TCPLLARCOMS [(COMS (* ;;; "IP Ethernet address translation module") [DECLARE%: DONTCOPY (EXPORT (RECORDS AR ARETHER AREXPETHER ARENTRY) (CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET 1) (\AR.ETHERNET.ADDRESS.LENGTH 6) (\AR.IP.ADDRESS.LENGTH 4) (\AR.REQUEST 1) (\AR.RESPONSE 2) (\AR.ETHER.PACKET.LENGTH 28] (INITRECORDS ARENTRY) (INITVARS (\AR.IP.TO.10MB.ALIST (CONS)) (\AR.SEARCH.TIMEOUT.INTERVAL 300000) (\AR.VALID.TIMEOUT.INTERVAL 600000)) (GLOBALVARS \AR.IP.TO.10MB.ALIST \AR.SEARCH.TIMEOUT.INTERVAL \AR.VALID.TIMEOUT.INTERVAL) (FNS \AR.DAEMON \AR.ENTER.RESOLUTION \AR.NOTE.RESOLUTION \AR.UPDATE.RESOLUTION \PRINTAR SPUTASSOC \AR.TRANSLATE.TO.10MB \AR.REQUEST.IP.TO.10MB \AR.REQUEST.IP.TO.3MB \AR.RESOLVE \AR.TRANSLATE.TO.3MB \HANDLE.RAW.AR) (ADDVARS (\PACKET.PRINTERS (2054 . \PRINTAR]) (* ;;; "IP Ethernet address translation module") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (ACCESSFNS AR [(ARBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM] [BLOCKRECORD ARBASE ((ARHARDWARESPACE WORD) (ARPROTOCOLSPACE WORD) (ARHARDWARELEN BYTE) (ARPROTOCOLLEN BYTE) (AROPCODE WORD) (AR1STWORD WORD)) (ACCESSFNS AR1STWORD ((ARCONTENTS (LOCF DATUM]) (ACCESSFNS ARETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) [BLOCKRECORD ARETHERBASE ((ARLCLHDW0 WORD) (ARLCLHDW1 WORD) (ARLCLHDW2 WORD) (ARLCLPTCL FIXP) (ARFRNHDW0 WORD) (ARFRNHDW1 WORD) (ARFRNHDW2 WORD) (ARFRNPTCL FIXP)) [ACCESSFNS ARLCLHDW0 ((ARSENDERHDW (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE] (ACCESSFNS ARFRNHDW0 ((ARTARGETHDW (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE]) (ACCESSFNS AREXPETHER ((ARETHERBASE (fetch (AR ARCONTENTS) of DATUM))) (BLOCKRECORD ARETHERBASE ((ARLCLHDW WORD) (ARLCLPTCL FIXP) (ARFRNHDW WORD) (ARFRNPTCL FIXP)))) (DATATYPE ARENTRY ((RECENT FLAG) (SEARCHING FLAG) (IPADDRESS POINTER) (ETHERADDRESS POINTER) (TIMER POINTER)) TIMER _ (NCREATE 'FIXP)) ) (/DECLAREDATATYPE 'ARENTRY '(FLAG FLAG POINTER POINTER POINTER) '((ARENTRY 0 (FLAGBITS . 0)) (ARENTRY 0 (FLAGBITS . 16)) (ARENTRY 0 POINTER) (ARENTRY 2 POINTER) (ARENTRY 4 POINTER)) '6) (DECLARE%: EVAL@COMPILE (RPAQQ \AR.HARDWARE.SPACE.ETHERNET 1) (RPAQQ \AR.ETHERNET.ADDRESS.LENGTH 6) (RPAQQ \AR.IP.ADDRESS.LENGTH 4) (RPAQQ \AR.REQUEST 1) (RPAQQ \AR.RESPONSE 2) (RPAQQ \AR.ETHER.PACKET.LENGTH 28) (CONSTANTS (\AR.HARDWARE.SPACE.ETHERNET 1) (\AR.ETHERNET.ADDRESS.LENGTH 6) (\AR.IP.ADDRESS.LENGTH 4) (\AR.REQUEST 1) (\AR.RESPONSE 2) (\AR.ETHER.PACKET.LENGTH 28)) ) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'ARENTRY '(FLAG FLAG POINTER POINTER POINTER) '((ARENTRY 0 (FLAGBITS . 0)) (ARENTRY 0 (FLAGBITS . 16)) (ARENTRY 0 POINTER) (ARENTRY 2 POINTER) (ARENTRY 4 POINTER)) '6) (RPAQ? \AR.IP.TO.10MB.ALIST (CONS)) (RPAQ? \AR.SEARCH.TIMEOUT.INTERVAL 300000) (RPAQ? \AR.VALID.TIMEOUT.INTERVAL 600000) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \AR.IP.TO.10MB.ALIST \AR.SEARCH.TIMEOUT.INTERVAL \AR.VALID.TIMEOUT.INTERVAL) ) (DEFINEQ (\AR.DAEMON [LAMBDA NIL (* ejs%: "25-Jun-85 18:47") (for ARENTRY in \AR.IP.TO.10MB.ALIST do (\AR.UPDATE.RESOLUTION ARENTRY) (BLOCK]) (\AR.ENTER.RESOLUTION [LAMBDA (IPADDRESS ETHERADDRESS ONLY-IF-PRESENT-P) (* ; "Edited 21-Dec-88 20:10 by Briggs") (* * Enter a new resolution in the AR table, or update an existing resolution) (LET [(OLDENTRY (find ENTRY in \AR.IP.TO.10MB.ALIST suchthat (EQUAL IPADDRESS (fetch (ARENTRY IPADDRESS) of ENTRY] (COND (OLDENTRY (freplace (ARENTRY TIMER) of OLDENTRY with (SETUPTIMER \AR.VALID.TIMEOUT.INTERVAL (ffetch (ARENTRY TIMER) of OLDENTRY))) (freplace (ARENTRY ETHERADDRESS) of OLDENTRY with ETHERADDRESS) (freplace (ARENTRY RECENT) of OLDENTRY with T) (freplace (ARENTRY SEARCHING) of OLDENTRY with NIL) OLDENTRY) ((NOT ONLY-IF-PRESENT-P) (CAR (push \AR.IP.TO.10MB.ALIST (create ARENTRY IPADDRESS _ IPADDRESS ETHERADDRESS _ ETHERADDRESS TIMER _ (SETUPTIMER \AR.VALID.TIMEOUT.INTERVAL) RECENT _ T]) (\AR.NOTE.RESOLUTION [LAMBDA (AR) (* ; "Edited 21-Dec-88 20:11 by Briggs") (* ;;; "Use the information in the AR to update any existing entry in the cache, and if this was a response (presumably to our query) add the new information.") [COND ((NOT (AND (EQ (fetch (ARETHER ARLCLHDW0) of AR) 0) (EQ (fetch (ARETHER ARLCLHDW1) of AR) 0) (EQ (fetch (ARETHER ARLCLHDW2) of AR) 0))) (\AR.ENTER.RESOLUTION (fetch (ARETHER ARLCLPTCL) of AR) (fetch (ARETHER ARSENDERHDW) of AR) (NOT (MEMBER (fetch (ARETHER ARFRNPTCL) of AR) \IP.LOCAL.ADDRESSES] (COND ([AND (EQ (fetch (AR AROPCODE) of AR) \AR.RESPONSE) (NOT (AND (EQ (fetch (ARETHER ARFRNHDW0) of AR) 0) (EQ (fetch (ARETHER ARFRNHDW1) of AR) 0) (EQ (fetch (ARETHER ARFRNHDW2) of AR) 0] (\AR.ENTER.RESOLUTION (fetch (ARETHER ARFRNPTCL) of AR) (fetch (ARETHER ARTARGETHDW) of AR]) (\AR.UPDATE.RESOLUTION [LAMBDA (ARENTRY) (* ; "Edited 21-Dec-88 18:27 by Briggs") (* ;;; "Called when a resolution is no longer recent. Does ARP requests to update our cache. Eventually, the entry is marked invalid and is removed") (COND [(TIMEREXPIRED? (fetch (ARENTRY TIMER) of ARENTRY)) (COND ((ffetch (ARENTRY RECENT) of ARENTRY) (freplace (ARENTRY RECENT) of ARENTRY with NIL) (freplace (ARENTRY SEARCHING) of ARENTRY with T) (freplace (ARENTRY TIMER) of ARENTRY with (SETUPTIMER \AR.SEARCH.TIMEOUT.INTERVAL (ffetch (ARENTRY TIMER) of ARENTRY))) (* ;;  "ask the system in the table to respond to avoid clogging the net with broadcasts") (\AR.REQUEST.IP.TO.10MB (ffetch (ARENTRY IPADDRESS) of ARENTRY) (ffetch (ARENTRY ETHERADDRESS) of ARENTRY))) ((ffetch (ARENTRY SEARCHING) of ARENTRY) (SETQ \AR.IP.TO.10MB.ALIST (DREMOVE ARENTRY \AR.IP.TO.10MB.ALIST] ((ffetch (ARENTRY SEARCHING) of ARENTRY) (\AR.REQUEST.IP.TO.10MB (ffetch (ARENTRY IPADDRESS) of ARENTRY) (ffetch (ARENTRY ETHERADDRESS) of ARENTRY]) (\PRINTAR [LAMBDA (AR CALLER FILE) (* ejs%: " 2-Jun-85 13:58") (PROG NIL (SELECTC (fetch (ETHERPACKET EPTYPE) of AR) (\EPT.AR NIL) (3 (RETURN)) (RETURN)) (COND ((AND (EQ (fetch (AR ARHARDWARESPACE) of AR) \AR.HARDWARE.SPACE.ETHERNET) (EQ (fetch (AR ARHARDWARELEN) of AR) \AR.ETHERNET.ADDRESS.LENGTH) (EQ (fetch (AR ARPROTOCOLSPACE) of AR) \EPT.IP) (EQ (fetch (AR ARPROTOCOLLEN) of AR) \AR.IP.ADDRESS.LENGTH)) (printout FILE CALLER ": Address resolution " (SELECTC (fetch (AR AROPCODE) of AR) (\AR.REQUEST "request.") (\AR.RESPONSE "response.") "unknown opcode.") T "Sender's protocol address is " (\IP.ADDRESS.TO.STRING (fetch (ARETHER ARLCLPTCL) of AR)) "." T "Sender's hardware address is " (fetch (ARETHER ARSENDERHDW) of AR) "." T) (SELECTC (fetch (AR AROPCODE) of AR) (\AR.REQUEST (printout FILE "Sender desires hardware address for " (\IP.ADDRESS.TO.STRING (fetch (ARETHER ARFRNPTCL) of AR)) T)) (\AR.RESPONSE (printout FILE "Sender says hardware address for " (\IP.ADDRESS.TO.STRING (fetch (ARETHER ARFRNPTCL) of AR)) T " is " (fetch (ARETHER ARTARGETHDW) of AR) T)) NIL))) (TERPRI FILE]) (SPUTASSOC [LAMBDA (KEY VAL ALIST) (* ejs%: "27-Dec-84 17:52") (PROG (OLDENTRY) [COND ([SETQ OLDENTRY (for ENTRY in ALIST thereis (EQUAL KEY (CAR ENTRY] (RPLACD OLDENTRY VAL)) (T (NCONC1 ALIST (CONS KEY VAL] (RETURN VAL]) (\AR.TRANSLATE.TO.10MB [LAMBDA (IPADDRESS DONTPROBE) (* ; "Edited 21-Dec-88 20:11 by Briggs") (* ;;; "Translate an IPADDRESS to a 10MBHOSTNUMBER, or initiate request and fail for now") (COND ((\IP.BROADCAST.ADDRESS IPADDRESS) BROADCASTNSHOSTNUMBER) [(bind FOUNDIT find ENTRY in \AR.IP.TO.10MB.ALIST suchthat (AND (EQUAL IPADDRESS (fetch (ARENTRY IPADDRESS) of ENTRY)) (SETQ FOUNDIT T)) finally (COND (FOUNDIT (RETURN (ffetch (ARENTRY ETHERADDRESS ) of ENTRY] ((NOT DONTPROBE) (\AR.REQUEST.IP.TO.10MB IPADDRESS) NIL]) (\AR.REQUEST.IP.TO.10MB [LAMBDA (IPADDRESS PDH) (* ; "Edited 21-Dec-88 18:31 by Briggs") (* ;;; "Request an address translation, either from the specified host, or by broadcasting the request.") (PROG ((AR (\ALLOCATE.ETHERPACKET))) (replace (AR ARHARDWARESPACE) of AR with \AR.HARDWARE.SPACE.ETHERNET) (replace (AR ARPROTOCOLSPACE) of AR with \EPT.IP) (replace (AR ARHARDWARELEN) of AR with \AR.ETHERNET.ADDRESS.LENGTH) (replace (AR ARPROTOCOLLEN) of AR with \AR.IP.ADDRESS.LENGTH) (replace (AR AROPCODE) of AR with \AR.REQUEST) (replace (ARETHER ARSENDERHDW) of AR with \MY.NSHOSTNUMBER) (replace (ARETHER ARLCLPTCL) of AR with (ffetch (NDB NDBIPHOST#) of \10MBLOCALNDB)) (replace (ARETHER ARFRNPTCL) of AR with IPADDRESS) (replace (ETHERPACKET EPTYPE) of AR with \EPT.AR) (ENCAPSULATE.ETHERPACKET \10MBLOCALNDB AR (OR PDH BROADCASTNSHOSTNUMBER) \AR.ETHER.PACKET.LENGTH \EPT.AR) (COND ((EQ IPTRACEFLG T) (PRINTPACKET AR 'PUT IPTRACEFILE)) (IPTRACEFLG (PRIN1 (COND (PDH "!") (T "^")) IPTRACEFILE))) (TRANSMIT.ETHERPACKET \10MBLOCALNDB AR]) (\AR.REQUEST.IP.TO.3MB [LAMBDA (IPADDRESS) (* ejs%: " 2-Jan-85 17:12") (* * Broadcast a request for an address translation) (PROG ((AR (\ALLOCATE.ETHERPACKET))) (replace (AR ARHARDWARESPACE) of AR with \AR.HARDWARE.SPACE.ETHERNET) (replace (AR ARPROTOCOLSPACE) of AR with \EET.IP) (replace (AR ARHARDWARELEN) of AR with 2) (replace (AR ARPROTOCOLLEN) of AR with \AR.IP.ADDRESS.LENGTH) (replace (AR AROPCODE) of AR with \AR.REQUEST) (replace (AREXPETHER ARLCLHDW) of AR with (LOGAND \LOCALPUPNETHOST (MASK.1'S 0 8))) (replace (AREXPETHER ARLCLPTCL) of AR with (ffetch (NDB NDBIPHOST#) of \3MBLOCALNDB)) (replace (AREXPETHER ARFRNPTCL) of AR with IPADDRESS) (ENCAPSULATE.ETHERPACKET \3MBLOCALNDB AR 0 20 \EPT.AR) (COND (IPTRACEFLG (PRINTPACKET AR 'PUT IPTRACEFILE))) (TRANSMIT.ETHERPACKET \3MBLOCALNDB AR]) (\AR.RESOLVE [LAMBDA (AR) (* ; "Edited 6-Jan-89 14:50 by Briggs") (* ;;; "Try to respond to an address resolution request. Release the packet if we can't") (DECLARE (GLOBALVARS \10MBLOCALNDB \MY.NSHOSTNUMBER)) (LET* ((TargetProtocolAddress (fetch (ARETHER ARFRNPTCL) of AR)) (TargetHardwareAddress (COND ((MEMBER TargetProtocolAddress \IP.LOCAL.ADDRESSES) (\AR.ENTER.RESOLUTION TargetProtocolAddress \MY.NSHOSTNUMBER) \MY.NSHOSTNUMBER) ([AND \IP.GATEWAY.FLG (LET* ((SUBNETMASK (CDR (SASSOC (fetch NDBIPHOST# of \10MBLOCALNDB) \IP.SUBNET.MASKS))) (MASKEDTARGET (LOGAND TargetProtocolAddress SUBNETMASK))) (COND ([AND SUBNETMASK (NOT (EQP MASKEDTARGET (LOGAND (fetch NDBIPHOST# of \10MBLOCALNDB) SUBNETMASK] (for ADDRPAIR in \IP.ROUTING.TABLE when (LISTP ADDRPAIR) thereis (EQP MASKEDTARGET (CAR ADDRPAIR] \MY.NSHOSTNUMBER))) (SenderHardwareAddress (fetch (ARETHER ARSENDERHDW) of AR))) (COND (TargetHardwareAddress (swap (fetch (ARETHER ARLCLPTCL) of AR) (fetch (ARETHER ARFRNPTCL) of AR)) (replace (ARETHER ARTARGETHDW) of AR with (fetch (ARETHER ARSENDERHDW ) of AR)) (replace (ARETHER ARSENDERHDW) of AR with TargetHardwareAddress) (replace (ARETHER ARLCLPTCL) of AR with TargetProtocolAddress) (replace (AR AROPCODE) of AR with \AR.RESPONSE) (ENCAPSULATE.ETHERPACKET \10MBLOCALNDB AR SenderHardwareAddress \AR.ETHER.PACKET.LENGTH \EPT.AR) [COND (IPTRACEFLG (COND ((EQ IPTRACEFLG T) (PRINTPACKET AR 'PUT IPTRACEFILE)) (T (PRIN1 "!" IPTRACEFILE] (TRANSMIT.ETHERPACKET \10MBLOCALNDB AR)) (T (\RELEASE.ETHERPACKET AR]) (\AR.TRANSLATE.TO.3MB [LAMBDA (IPADDRESS) (* ejs%: "27-Jun-85 12:43") (COND ((\IP.BROADCAST.ADDRESS IPADDRESS) 0) (T (LDB (BYTE 8 0) IPADDRESS]) (\HANDLE.RAW.AR [LAMBDA (AR TYPE) (* ejs%: " 2-Jun-85 14:12") (PROG ((NDB (ffetch (ETHERPACKET EPNETWORK) of AR))) (SELECTQ (ffetch (NDB NETTYPE) of NDB) (10 (COND ((NEQ TYPE \EPT.AR) (RETURN)))) (3 (RETURN)) (ERROR "Unknown net type" (fetch (NDB NETTYPE) of NDB))) [COND ((AND (EQ (fetch (AR ARHARDWARESPACE) of AR) \AR.HARDWARE.SPACE.ETHERNET) (EQ (fetch (AR ARHARDWARELEN) of AR) \AR.ETHERNET.ADDRESS.LENGTH) (EQ (fetch (AR ARPROTOCOLSPACE) of AR) \EPT.IP) (EQ (fetch (AR ARPROTOCOLLEN) of AR) \AR.IP.ADDRESS.LENGTH)) [COND (IPTRACEFLG (COND ((EQ IPTRACEFLG T) (PRINTPACKET AR 'ARGET IPTRACEFILE)) (T (PRIN1 "*" IPTRACEFILE] (\AR.NOTE.RESOLUTION AR) (COND ((EQ (fetch (AR AROPCODE) of AR) \AR.REQUEST) (\AR.RESOLVE AR)) (T (\RELEASE.ETHERPACKET AR] (RETURN T]) ) (ADDTOVAR \PACKET.PRINTERS (2054 . \PRINTAR)) (PUTPROPS TCPLLAR COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5949 22633 (\AR.DAEMON 5959 . 6223) (\AR.ENTER.RESOLUTION 6225 . 7972) ( \AR.NOTE.RESOLUTION 7974 . 9329) (\AR.UPDATE.RESOLUTION 9331 . 10916) (\PRINTAR 10918 . 13356) ( SPUTASSOC 13358 . 13700) (\AR.TRANSLATE.TO.10MB 13702 . 14709) (\AR.REQUEST.IP.TO.10MB 14711 . 16270) (\AR.REQUEST.IP.TO.3MB 16272 . 17510) (\AR.RESOLVE 17512 . 20996) (\AR.TRANSLATE.TO.3MB 20998 . 21232) (\HANDLE.RAW.AR 21234 . 22631))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPLLICMP b/obsolete/tcp/TCPLLICMP deleted file mode 100644 index 62f1f4bb..00000000 --- a/obsolete/tcp/TCPLLICMP +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Aug-90 12:34:42" {DSK}ETHERNET>TCP>NEW>TCPLLICMP.;2 20237 changes to%: (FNS PRINTICMP \ICMP.HANDLE.REDIRECT \ICMP.INPUT) previous date%: " 6-Jan-89 16:38:06" {DSK}ETHERNET>TCP>NEW>TCPLLICMP.;1) (* " Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPLLICMPCOMS) (RPAQQ TCPLLICMPCOMS [(COMS (* * ICMP functions) (DECLARE%: DONTCOPY (EXPORT (RECORDS ICMPADMASK ICMP ICMPECHO ICMPDESTUN ICMPREDIRECT) (CONSTANTS * ICMPTYPES) (CONSTANTS * ICMPUNREACHABLES) (CONSTANTS * ICMPREDIRECTS) (CONSTANTS \ICMPOVLEN) (CONSTANTS \ICMP.PROTOCOL) (MACROS ICMPLENGTH))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS IP.FROM.ICMP)) (INITVARS * ICMPTIMEXS) (INITVARS (\ICMP.ECHO.REPLY.QUEUE (NCREATE 'SYSQUEUE)) (\ICMP.ECHO.REPLY.EVENT (CREATE.EVENT "ICMP Echo reply")) (\ICMP.ECHOING)) (GLOBALVARS \ICMP.ECHO.REPLY.QUEUE \ICMP.ECHO.REPLY.EVENT \ICMP.ECHOING) (FNS PRINTICMP \ICMP.DEST.UNREACHABLE \ICMP.REDIRECT \ICMP.ECHO.TEST \ICMP.HANDLE.ECHO.REPLY \ICMP.HANDLE.REDIRECT \ICMP.INPUT \ICMP.REPLY.TO.ECHO \ICMP.SETUPICMP \ICMP.TIME.EXCEEDED \ICMP.TRANSMIT) (FNS ICMP.HANDLE.ADDRESS.MASK \ICMP.INPUT \ICMP.REQUEST.ADDRESS.MASK) (ADDVARS (IPPRINTMACROS (1 . PRINTICMP]) (* * ICMP functions) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (ACCESSFNS ICMPADMASK ((ICMPADMASKBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPADMASKBASE ((ICMPADMASKID WORD) (ICMPADMASKSEQNO WORD) (ICMPADMASKADMASK FIXP)))) (ACCESSFNS ICMP ((ICMPBASE (\IPDATABASE DATUM))) (BLOCKRECORD ICMPBASE ((ICMPTYPE BYTE) (ICMPCODE BYTE) (ICMPCHECKSUM WORD) (ICMPDATASTART WORD))) [ACCESSFNS ICMP ((ICMPCONTENTS (LOCF (fetch (ICMP ICMPDATASTART) of DATUM]) (ACCESSFNS ICMPECHO ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE ((ICMPECHOID WORD) (ICMPECHOSEQNO WORD) (ICMPECHODATA BYTE)))) (ACCESSFNS ICMPDESTUN ((ICMPECHOBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPECHOBASE ((NIL FIXP) (ICMPIPSTART WORD))) [ACCESSFNS ICMPDESTUN ((ICMPIPHEADER (LOCF (fetch (ICMPDESTUN ICMPIPSTART) of DATUM]) (ACCESSFNS ICMPREDIRECT ((ICMPREDIRECTBASE (fetch (ICMP ICMPCONTENTS) of DATUM))) (BLOCKRECORD ICMPREDIRECTBASE ((ICMPGATEWAY FIXP) (ICMPIPSTART WORD))) [ACCESSFNS ICMPREDIRECT ((ICMPIPHEADER (LOCF (fetch (ICMPREDIRECT ICMPIPSTART) of DATUM]) ) (RPAQQ ICMPTYPES ((\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (\ICMP.REDIRECT 5) (\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (\ICMP.TIMESTAMP 13) (\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (\ICMP.ADDRESS.MASK.REQUEST 17) (\ICMP.ADDRESS.MASK.REPLY 18))) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.ECHO.REPLY 0) (RPAQQ \ICMP.DEST.UNREACHABLE 3) (RPAQQ \ICMP.SOURCE.QUENCH 4) (RPAQQ \ICMP.REDIRECT 5) (RPAQQ \ICMP.ECHO 8) (RPAQQ \ICMP.TIME.EXCEEDED 11) (RPAQQ \ICMP.PARAMETER.PROBLEM 12) (RPAQQ \ICMP.TIMESTAMP 13) (RPAQQ \ICMP.TIMESTAMP.REPLY 14) (RPAQQ \ICMP.INFO.REQUEST 15) (RPAQQ \ICMP.INFO.REPLY 16) (RPAQQ \ICMP.ADDRESS.MASK.REQUEST 17) (RPAQQ \ICMP.ADDRESS.MASK.REPLY 18) (CONSTANTS (\ICMP.ECHO.REPLY 0) (\ICMP.DEST.UNREACHABLE 3) (\ICMP.SOURCE.QUENCH 4) (\ICMP.REDIRECT 5) (\ICMP.ECHO 8) (\ICMP.TIME.EXCEEDED 11) (\ICMP.PARAMETER.PROBLEM 12) (\ICMP.TIMESTAMP 13) (\ICMP.TIMESTAMP.REPLY 14) (\ICMP.INFO.REQUEST 15) (\ICMP.INFO.REPLY 16) (\ICMP.ADDRESS.MASK.REQUEST 17) (\ICMP.ADDRESS.MASK.REPLY 18)) ) (RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5))) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.NET.UNREACHABLE 0) (RPAQQ \ICMP.HOST.UNREACHABLE 1) (RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2) (RPAQQ \ICMP.PORT.UNREACHABLE 3) (RPAQQ \ICMP.CANT.FRAGMENT 4) (RPAQQ \ICMP.SOURCE.ROUTE 5) (CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5)) ) (RPAQQ ICMPREDIRECTS ((\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) (\ICMP.REDIRECT.SVC.AND.HOST 3))) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.REDIRECT.NET 0) (RPAQQ \ICMP.REDIRECT.HOST 1) (RPAQQ \ICMP.REDIRECT.SVC.AND.NET 2) (RPAQQ \ICMP.REDIRECT.SVC.AND.HOST 3) (CONSTANTS (\ICMP.REDIRECT.NET 0) (\ICMP.REDIRECT.HOST 1) (\ICMP.REDIRECT.SVC.AND.NET 2) (\ICMP.REDIRECT.SVC.AND.HOST 3)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMPOVLEN 4) (CONSTANTS \ICMPOVLEN) ) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.PROTOCOL 1) (CONSTANTS \ICMP.PROTOCOL) ) (DECLARE%: EVAL@COMPILE [PUTPROPS ICMPLENGTH MACRO (LAMBDA (ICMP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of ICMP) (LLSH (fetch (IP IPHEADERLENGTH) of ICMP) 2] ) (* "END EXPORTED DEFINITIONS") ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE [PUTPROPS IP.FROM.ICMP MACRO (OPENLAMBDA (PKT) (* ;; "Returns a pointer to the 'Internet header + 64 bits' found in an ICMP packet, offset so that it looks like an IP record. I.e., add to the base the size of the IP header + ICMP header") (\ADDBASE PKT (+ (UNFOLD (fetch (IP IPHEADERLENGTH) of PKT) WORDSPERCELL) (CONSTANT (+ (FOLDHI \ICMPOVLEN BYTESPERWORD) 2] ) ) (RPAQQ ICMPTIMEXS ((\ICMP.TRANSIT.TIME.EXCEEDED 0) (\ICMP.FRAGMENT.TIME.EXCEEDED 1))) (RPAQ? \ICMP.TRANSIT.TIME.EXCEEDED 0) (RPAQ? \ICMP.FRAGMENT.TIME.EXCEEDED 1) (RPAQ? \ICMP.ECHO.REPLY.QUEUE (NCREATE 'SYSQUEUE)) (RPAQ? \ICMP.ECHO.REPLY.EVENT (CREATE.EVENT "ICMP Echo reply")) (RPAQ? \ICMP.ECHOING ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \ICMP.ECHO.REPLY.QUEUE \ICMP.ECHO.REPLY.EVENT \ICMP.ECHOING) ) (DEFINEQ (PRINTICMP [LAMBDA (ICMP FILE) (* ; "Edited 13-Sep-88 11:35 by bvm") (LET ((*PRINT-BASE* 10) (TYPE (fetch (ICMP ICMPTYPE) of ICMP)) (CODE (fetch (ICMP ICMPCODE) of ICMP))) (PRINTCONSTANT TYPE ICMPTYPES FILE "\ICMP.") (SPACES 1 FILE) (SELECTC TYPE (\ICMP.REDIRECT (PRINTCONSTANT CODE ICMPREDIRECTS FILE "\ICMP.REDIRECT.") (PRINTOUT FILE " " (\IP.ADDRESS.TO.STRING (fetch (ICMPREDIRECT ICMPGATEWAY) of ICMP)))) (\ICMP.DEST.UNREACHABLE (PRINTCONSTANT CODE ICMPUNREACHABLES FILE "\ICMP.")) (PRIN3 CODE FILE)) (TERPRI FILE]) (\ICMP.DEST.UNREACHABLE (LAMBDA (PACKET CODE) (* ejs%: " 2-Feb-86 11:35") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.DEST.UNREACHABLE CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL))) (\BLT (fetch (ICMPDESTUN ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP) (\RELEASE.ETHERPACKET PACKET))) ) (\ICMP.REDIRECT (LAMBDA (PACKET CODE) (* ejs%: " 2-Feb-86 12:13") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.REDIRECT CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL) WORDSPERCELL)) (replace (ICMPREDIRECT ICMPGATEWAY) of ICMP with (OR \IP.DEFAULT.GATEWAY 0)) (\BLT (fetch (ICMPREDIRECT ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP) (\RELEASE.ETHERPACKET PACKET))) ) (\ICMP.ECHO.TEST (LAMBDA (IPADDRESS ECHOSTREAM DATALENGTH) (* ejs%: "12-May-86 18:01") (* * An ICMP echo tester) (while (\QUEUEHEAD \ICMP.ECHO.REPLY.QUEUE) do (\RELEASE.ETHERPACKET (\DEQUEUE \ICMP.ECHO.REPLY.QUEUE))) (RESETVAR \ICMP.ECHOING T (PROG (ICMP (IPSOCKET (\IP.FIND.PROTOCOL \ICMP.PROTOCOL))) (for SEQUENCE from 0 do ((SETQ ICMP (\ALLOCATE.ETHERPACKET)) (\IP.SETUPIP ICMP (DODIP.HOSTP IPADDRESS) 0 IPSOCKET) (\ICMP.SETUPICMP ICMP \ICMP.ECHO 0) (replace (ICMPECHO ICMPECHOID) of ICMP with 0) (replace (ICMPECHO ICMPECHOSEQNO) of ICMP with SEQUENCE) (add (fetch (IP IPTOTALLENGTH) of ICMP) 4) (AND (NUMBERP DATALENGTH) (add (fetch (IP IPTOTALLENGTH) of ICMP) DATALENGTH)) (printout ECHOSTREAM "!") (\ICMP.TRANSMIT ICMP) (AWAIT.EVENT \ICMP.ECHO.REPLY.EVENT \ETHERTIMEOUT) (COND ((SETQ ICMP (\DEQUEUE \ICMP.ECHO.REPLY.QUEUE)) (COND ((IGREATERP (fetch (ICMPECHO ICMPECHOSEQNO) of ICMP) SEQUENCE) (printout T "ICMP echo out of sequence" T) (PRINTPACKET ICMP (QUOTE GET) ECHOSTREAM) (RETURN ICMP)) (T (printout ECHOSTREAM "+") (\RELEASE.ETHERPACKET ICMP)))) (T (printout ECHOSTREAM ".")))))))) ) (\ICMP.HANDLE.ECHO.REPLY (LAMBDA (ICMP) (* ejs%: "28-Dec-84 09:02") (COND (\ICMP.ECHOING (\ENQUEUE \ICMP.ECHO.REPLY.QUEUE ICMP) (NOTIFY.EVENT \ICMP.ECHO.REPLY.EVENT)) (T (\RELEASE.ETHERPACKET ICMP)))) ) (\ICMP.HANDLE.REDIRECT [LAMBDA (ICMP) (* ; "Edited 24-Aug-88 16:16 by bvm") (* ;;; "Called when a gateway tells us a better route to the destination. There is a code for type of redirect, but it's not obviously meaningful ") (LET* ((NDB (fetch EPNETWORK of ICMP)) (GATEWAY (fetch (ICMPREDIRECT ICMPGATEWAY) of ICMP)) (DESTADDRESS (fetch (IP IPDESTINATIONADDRESS) of (IP.FROM.ICMP ICMP))) (DESTNET (\IPNETADDRESS DESTADDRESS))) (* ;; "Store the new route in the routing table") (COND [(= DESTNET (fetch (NDB NDBIPNET#) of NDB)) (LET* ((SOURCEADDRESS (fetch (NDB NDBIPHOST#) of NDB)) (SUBNETMASK (CDR (SASSOC SOURCEADDRESS \IP.SUBNET.MASKS))) (DESTSUBNET (LOGAND DESTADDRESS SUBNETMASK))) (* ;; "The dest net is a local net. Either we fouled up in our routing, or the dest net is really a subnet") (COND ((NOT (= DESTSUBNET (LOGAND SOURCEADDRESS SUBNETMASK))) (* ;  "Yes, this is a redirect for a subnet, if such is possible") (SPUTASSOC DESTSUBNET GATEWAY \IP.ROUTING.TABLE] (T (* ; "Non-local net") (SPUTASSOC DESTNET GATEWAY \IP.ROUTING.TABLE))) (* ;; "If it's a 10MB network, see if we have the 10MB address of this gateway, and if not, request the address") (SELECTQ (fetch (NDB NETTYPE) of NDB) (10 (COND ((NOT (\AR.TRANSLATE.TO.10MB GATEWAY T)) (\AR.TRANSLATE.TO.10MB GATEWAY)))) NIL) (\RELEASE.ETHERPACKET ICMP]) (\ICMP.INPUT [LAMBDA (ICMP) (* ; "Edited 25-Aug-88 11:51 by bvm") (* ;;; "ICMP packet received") (COND ((\IP.CHECKSUM.OK (\IPCHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP) (\IPDATALENGTH ICMP))) (SELECTC (fetch (ICMP ICMPTYPE) of ICMP) (\ICMP.ECHO.REPLY (\ICMP.HANDLE.ECHO.REPLY ICMP)) (\ICMP.ECHO (\ICMP.REPLY.TO.ECHO ICMP)) (\ICMP.DEST.UNREACHABLE (* ; "Some packet couldn't reach its destination. Tell the protocol that sent the packet (found in the enclosed header)") [LET* [(SEGMENT (IP.FROM.ICMP ICMP)) (PROTOCOL (\IP.FIND.PROTOCOL (fetch (IP IPPROTOCOL) of SEGMENT] (COND (PROTOCOL (CL:FUNCALL (fetch (IPSOCKET IPSICMPFN) of PROTOCOL) ICMP SEGMENT PROTOCOL]) (\ICMP.REDIRECT (\ICMP.HANDLE.REDIRECT ICMP)) (\ICMP.ADDRESS.MASK.REPLY (ICMP.HANDLE.ADDRESS.MASK ICMP)) (\RELEASE.ETHERPACKET ICMP))) (T (AND IPTRACEFLG (PRINTPACKET ICMP 'ICMPGET IPTRACEFILE "[dropping packet--bad ICMP checksum]"]) (\ICMP.REPLY.TO.ECHO (LAMBDA (ICMP) (* ejs%: "12-May-86 17:34") (* * Reply to an echo request) (swap (fetch (IP IPSOURCEADDRESS) of ICMP) (fetch (IP IPDESTINATIONADDRESS) of ICMP)) (replace (ICMP ICMPTYPE) of ICMP with \ICMP.ECHO.REPLY) (replace EPREQUEUE of ICMP with (QUOTE FREE)) (\ICMP.TRANSMIT ICMP)) ) (\ICMP.SETUPICMP (LAMBDA (ICMP TYPE CODE) (* ejs%: "27-Dec-84 19:00") (replace (ICMP ICMPTYPE) of ICMP with TYPE) (replace (ICMP ICMPCODE) of ICMP with CODE) (add (fetch (IP IPTOTALLENGTH) of ICMP) \ICMPOVLEN)) ) (\ICMP.TIME.EXCEEDED (LAMBDA (PACKET CODE) (* ejs%: " 3-Feb-86 11:00") (* * Returns an ICMP unreachable packet of proper code to sender) (PROG ((ICMP (\ALLOCATE.ETHERPACKET)) NWORDS) (\IP.SETUPIP ICMP (fetch (IP IPSOURCEADDRESS) of PACKET) 0 (\IP.FIND.PROTOCOL \ICMP.PROTOCOL)) (\ICMP.SETUPICMP ICMP \ICMP.TIME.EXCEEDED CODE) (SETQ NWORDS (IPLUS (FOLDHI 64 BITSPERWORD) (UNFOLD (fetch (IP IPHEADERLENGTH) of PACKET) WORDSPERCELL))) (\BLT (fetch (ICMPDESTUN ICMPIPHEADER) of ICMP) (fetch (IP IPBASE) of PACKET) NWORDS) (add (fetch (IP IPTOTALLENGTH) of ICMP) (UNFOLD NWORDS BYTESPERWORD)) (\ICMP.TRANSMIT ICMP))) ) (\ICMP.TRANSMIT (LAMBDA (ICMP) (* ejs%: "31-Dec-84 14:27") (* * Checksum and transmit an ICMP packet) (\IP.SET.CHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP) (\IPDATALENGTH ICMP) (LOCF (fetch (ICMP ICMPCHECKSUM) of ICMP))) (\IP.TRANSMIT ICMP)) ) ) (DEFINEQ (ICMP.HANDLE.ADDRESS.MASK (LAMBDA (ICMP) (* ; "Edited 22-Mar-88 18:49 by eweaver") (* ;; "Called when an address-mask-reply icmp comes in.") (LET* ((FROM (fetch (IP IPSOURCEADDRESS) of ICMP)) (DESTADDR (fetch (IP IPDESTINATIONADDRESS) of ICMP)) (LOCALADDR (COND ((AND \3MBLOCALNDB (EQ (fetch NDBIPHOST# of \3MBLOCALNDB) DESTADDR)) DESTADDR) ((AND \10MBLOCALNDB (EQ (fetch NDBIPHOST# of \10MBLOCALNDB) DESTADDR)) DESTADDR))) (MASK (fetch (ICMPADMASK ICMPADMASKADMASK) of ICMP))) (* ;; (CL:FORMAT PROMPTWINDOW "ICMP AdMask from ~a mask ~a" (\IP.ADDRESS.TO.STRING FROM) (\IP.ADDRESS.TO.STRING MASK))) (COND ((NULL \IP.DEFAULT.GATEWAY) (SETQ \IP.DEFAULT.GATEWAY FROM))) (COND ((NULL (SASSOC DESTADDR \IP.SUBNET.MASKS)) (CL:PUSH (CONS DESTADDR MASK) \IP.SUBNET.MASKS))))) ) (\ICMP.INPUT [LAMBDA (ICMP) (* ; "Edited 25-Aug-88 11:51 by bvm") (* ;;; "ICMP packet received") (COND ((\IP.CHECKSUM.OK (\IPCHECKSUM ICMP (fetch (ICMP ICMPBASE) of ICMP) (\IPDATALENGTH ICMP))) (SELECTC (fetch (ICMP ICMPTYPE) of ICMP) (\ICMP.ECHO.REPLY (\ICMP.HANDLE.ECHO.REPLY ICMP)) (\ICMP.ECHO (\ICMP.REPLY.TO.ECHO ICMP)) (\ICMP.DEST.UNREACHABLE (* ; "Some packet couldn't reach its destination. Tell the protocol that sent the packet (found in the enclosed header)") [LET* [(SEGMENT (IP.FROM.ICMP ICMP)) (PROTOCOL (\IP.FIND.PROTOCOL (fetch (IP IPPROTOCOL) of SEGMENT] (COND (PROTOCOL (CL:FUNCALL (fetch (IPSOCKET IPSICMPFN) of PROTOCOL) ICMP SEGMENT PROTOCOL]) (\ICMP.REDIRECT (\ICMP.HANDLE.REDIRECT ICMP)) (\ICMP.ADDRESS.MASK.REPLY (ICMP.HANDLE.ADDRESS.MASK ICMP)) (\RELEASE.ETHERPACKET ICMP))) (T (AND IPTRACEFLG (PRINTPACKET ICMP 'ICMPGET IPTRACEFILE "[dropping packet--bad ICMP checksum]"]) (\ICMP.REQUEST.ADDRESS.MASK (LAMBDA NIL (* ; "Edited 8-Jan-88 15:15 by eweaver") (* ;; "Broadcast a request for the subnet mask. The reply is handled asynchronously by") (* ;; " \handle-icmp-address-mask.") (LET ((ICMP (\ALLOCATE.ETHERPACKET)) (IPSOCKET (\IP.FIND.PROTOCOL \ICMP.PROTOCOL))) (\IP.SETUPIP ICMP 0 0 IPSOCKET) (\ICMP.SETUPICMP ICMP \ICMP.ADDRESS.MASK.REQUEST 0) (replace (ICMPADMASK ICMPADMASKID) of ICMP with 0) (replace (ICMPADMASK ICMPADMASKSEQNO) of ICMP with 0) (add (fetch (IP IPTOTALLENGTH) of ICMP) 4) (\ICMP.TRANSMIT ICMP))) ) ) (ADDTOVAR IPPRINTMACROS (1 . PRINTICMP)) (PUTPROPS TCPLLICMP COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9098 17355 (PRINTICMP 9108 . 9918) (\ICMP.DEST.UNREACHABLE 9920 . 10573) ( \ICMP.REDIRECT 10575 . 11304) (\ICMP.ECHO.TEST 11306 . 12407) (\ICMP.HANDLE.ECHO.REPLY 12409 . 12615) (\ICMP.HANDLE.REDIRECT 12617 . 14564) (\ICMP.INPUT 14566 . 15953) (\ICMP.REPLY.TO.ECHO 15955 . 16266) (\ICMP.SETUPICMP 16268 . 16484) (\ICMP.TIME.EXCEEDED 16486 . 17103) (\ICMP.TRANSMIT 17105 . 17353)) ( 17356 20085 (ICMP.HANDLE.ADDRESS.MASK 17366 . 18138) (\ICMP.INPUT 18140 . 19527) ( \ICMP.REQUEST.ADDRESS.MASK 19529 . 20083))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPLLIP b/obsolete/tcp/TCPLLIP deleted file mode 100644 index b5ec716b..00000000 --- a/obsolete/tcp/TCPLLIP +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP") (FILECREATED "30-Aug-90 13:46:39" {DSK}TCP>TCPLLIP.;3 151757 changes to%: (VARS TCPLLIPCOMS) previous date%: "29-Aug-90 16:28:12" {DSK}TCP>TCPLLIP.;2) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPLLIPCOMS) (RPAQQ TCPLLIPCOMS ((PROP MAKEFILE-ENVIRONMENT TCPLLIP) (COMS (* ;; "IP definitions and addressing") (DECLARE%: DONTCOPY (EXPORT (RECORDS IP IPSOCKET IPADDRESS) (CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION \IP.MAX.EPKTS.ON.QUEUE \IP.DEFAULT.TIME.TO.LIVE \IP.WAKEUP.INTERVAL) (CONSTANTS * IPPACKETTYPES) (CONSTANTS * ICMPUNREACHABLES) (MACROS \IPDATABASE \IPDATALENGTH))) (ADDVARS (*IP-PROTOCOL-NAME-FROM-NUMBER* (17 . "UDP") (6 . "TCP") (1 . "ICMP"))) (GLOBALVARS *IP-PROTOCOL-NAME-FROM-NUMBER*) (* ;; "value in sysout is too small. This is 512-(indexf (fetch epencapsulation))-2. 489 is more correct, but let's leave a word of slop for off-by-ones") (VARS (\10MBPACKETLENGTH 488)) (* ;; "Make it easier to see queuelength without opening up q.") (FNS \SYSQUEUE.DEFPRINT \IPSOCKET.DEFPRINT) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'IPSOCKET '\IPSOCKET.DEFPRINT)) (P (DEFPRINT 'SYSQUEUE '\SYSQUEUE.DEFPRINT] (INITVARS (IPTRACETIME) (IPONLYTYPES) (IPIGNORETYPES) (IPPRINTMACROS) (IPTRACEFLG) (IPTRACEFILE) (\IP.INIT.FILE) (\IP.DEFAULT.CONFIGURATION) (\IP.HOSTNAMES (HASHARRAY 40 1.1)) (\IP.HOSTNUMBERS) (INTERNET.LOCAL.DOMAIN)) (INITRECORDS IP IPSOCKET IPADDRESS) (GLOBALVARS IPTRACEFILE IPTRACEFLG IPIGNORETYPES IPONLYTYPES IPPRINTMACROS \IP.HOSTNAMES \IP.INIT.FILE INTERNET.LOCAL.DOMAIN \IP.DEFAULT.CONFIGURATION \IP.HOSTNUMBERS) (FILES (SYSLOAD) TCPHTE TCPLLICMP TCPLLAR) (ADDVARS (\PACKET.PRINTERS (2048 . PRINTIP))) (FNS \CANONICALIZE.IP.HOSTNAME DODIP.HOSTP IPHOSTADDRESS IPHOSTNAME IPTRACE IPTRACEWINDOW.BUTTONFN PRINTIP PRINTIPDATA \IPADDRESSCLASS \IPEVENTFN \IPHOSTADDRESS \IPNETADDRESS \IP.ADDRESS.TO.STRING \IP.BROADCAST.ADDRESS \IP.LEGAL.ADDRESS \IP.MAKE.BROADCAST.ADDRESS \IP.PRINT.ADDRESS \IP.READ.STRING.ADDRESS \DOMAIN.NAME.QUALIFY.FULLY)) (COMS (* ;; "Startup and shutdown") (INITVARS (*IP-DEFAULT-HOSTS-FILE*) (TCP.ALWAYS.READ.HOSTS.FILE T) (\TCP.LAST.HOSTS.FILE.DATE) (\TCP.LAST.HOSTS.FILE.READ) (\IPFLG) (\IP.READY) (\IP.READY.EVENT (CREATE.EVENT "IP Ready")) (\IP.WAKEUP.TIMER) (IPTRACEFLG) (\IP.WAKEUP.EVENT (CREATE.EVENT "IP Wakeup"))) (GLOBALVARS \IPFLG \IP.READY \IP.READY.EVENT \IP.WAKEUP.TIMER \IP.WAKEUP.EVENT TCP.ALWAYS.READ.HOSTS.FILE \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ *IP-DEFAULT-HOSTS-FILE*) (FNS STOPIP \IPINIT \IPLISTENER \IP.REINITIALIZE.FROM.SCRATCH \IP.RESTART.FROM.CONFIGURATION \IP.MAYBE.READ.HOSTS.TXT \IP.READ.INIT.FILE \IP.PROMPT.FOR.FILE.NAME) (ADDVARS (RESTARTETHERFNS \IPEVENTFN))) (COMS (* ;; "Early IP reception functions") (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPADDRESSTYPES))) (INITVARS (\IP.LOCAL.ADDRESSES) (\IP.SUBNET.MASKS) (\IP.GATEWAY.FLG)) (VARS (\IP.ADDRESS.BOX (\CREATECELL \FIXP))) (GLOBALVARS \IP.LOCAL.ADDRESSES \IP.SUBNET.MASKS \IP.GATEWAY.FLG \IP.ADDRESS.BOX) (MACROS \IP.FIX.DEST.HOST \IP.FIX.DEST.NET \IP.FIX.SOURCE.HOST \IP.FIX.SOURCE.NET) (FNS \HANDLE.RAW.IP \FORWARD.IP \IP.LOCAL.DESTINATION \IPCHECKSUM \IP.CHECKSUM.OK \IP.SET.CHECKSUM)) (COMS (* ;; "Protocol Distribution") (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPPROTOCOLTYPES))) (INITVARS (\IP.PROTOCOLS)) (GLOBALVARS \IP.PROTOCOLS) (FNS \IP.HAND.TO.PROTOCOL \IP.DEFAULT.INPUTFN \IP.DEFAULT.NOSOCKETFN \IP.ADD.PROTOCOL \IP.DELETE.PROTOCOL \IP.FIND.PROTOCOL \IP.FIND.PROTOCOL.SOCKET \IP.FIND.SOCKET \IP.OPEN.SOCKET \IP.CLOSE.SOCKET)) (COMS (* ;; "Fragmentation Handling") (DECLARE%: DONTCOPY (EXPORT (RECORDS AssemblyRecord FragmentRecord FragmentID))) (INITVARS (\IP.FRAGMENT.LIST) (\IP.FRAGMENT.LOCK (CREATE.MONITORLOCK "IP Fragment Processing Lock"))) (GLOBALVARS \IP.FRAGMENT.LIST \IP.FRAGMENT.LOCK) (CONSTANTS (\IP.FRAGMENTATION.UNIT 8)) (FNS \HANDLE.RAW.IP.FRAGMENT \IP.NEW.FRAGMENT.LST \IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER \IP.ADD.FRAGMENT \IP.FIND.MATCHING.FRAGMENTS \IP.FRAGMENTED.PACKET \IP.CHECK.REASSEMBLY.TIMEOUTS \IP.DELETE.FRAGMENT \IP.PRINT.FRAGMENT)) (COMS (* ;; "Option Processing") [DECLARE%: DONTCOPY (EXPORT (CONSTANTS * IPOPTIONTYPES) (CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0] (FNS \IP.PROCESS.OPTIONS \IP.OPTION.RECORD.ROUTE \IP.OPTION.STRICT.SOURCE.ROUTE \IP.OPTION.TIMESTAMP)) (COMS (* ;; "Packet Transmission and routing") (INITVARS (\IP.ROUTING.TABLE (CONS)) (\IP.DEFAULT.GATEWAY) (\IP.LOCAL.NETWORKS) (\IP.GATEWAY.FORWARDING.FUNCTIONS)) (GLOBALVARS \IP.ROUTING.TABLE \IP.DEFAULT.GATEWAY \IP.LOCAL.NETWORKS \IP.GATEWAY.FORWARDING.FUNCTIONS) (FNS \IP.SETUPIP \IP.TRANSMIT \IP.ROUTE.PACKET) (FNS IP.GET IP.SEND IP.PACKET.WATCHER) (MACROS IP.SEND)) (COMS (* ;; "Client functions for building packets") (FNS \IP.APPEND.BYTE \IP.APPEND.CELL \IP.APPEND.STRING \IP.APPEND.WORD \IP.GET.BYTE \IP.GET.CELL \IP.GET.STRING \IP.GET.WORD \IP.PUT.BYTE \IP.PUT.CELL \IP.PUT.STRING \IP.PUT.WORD) (MACROS \IP.GET.BYTE \IP.GET.CELL \IP.GET.STRING \IP.GET.WORD \IP.PUT.BYTE \IP.PUT.CELL \IP.PUT.STRING \IP.PUT.WORD)) (P (MOVD? 'NILL 'IP.DEFAULT.CONFIGURATION)) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST)))) (PUTPROPS TCPLLIP MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP")) (* ;; "IP definitions and addressing") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (ACCESSFNS IP [(IPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM] [BLOCKRECORD IPBASE ((IPVERSION BITS 4) (* ; "Protocol version") (IPHEADERLENGTH BITS 4) (* ; "Head length, in cells") (IPSERVICE BYTE) (* ; "Service type") (IPTOTALLENGTH WORD) (* ; "Packet length, in bytes") (IPID WORD) (* ; "Packet id") (NIL BITS 1) (IPDONTFRAGMENT FLAG) (* ; "Don't fragment me") (IPMOREFRAGMENTS FLAG)(* ; "Last fragment") (IPFRAGMENTOFFSET BITS 13) (* ; "Fragment position") (IPTIMETOLIVE BYTE) (* ; "Hop limiter") (IPPROTOCOL BYTE) (* ; "Client protocol") (IPHEADERCHECKSUM WORD) (* ; "Header-only checksum") (IPSOURCEADDRESS FIXP) (IPDESTINATIONADDRESS FIXP) (IPOPTIONSSTART BYTE) (* ; "Options or data start here") ) [ACCESSFNS IPSERVICE ((IPSERVICEBASE (LOCF DATUM))) (BLOCKRECORD IPSERVICEBASE ((IPPRECEDENCE BITS 3) (IPDELAY FLAG) (IPTHROUGHPUT FLAG) (IPRELIABILITY FLAG) (NIL BITS 2] [ACCESSFNS IPDESTINATIONADDRESS ((IPDESTBASE (LOCF DATUM))) (ACCESSFNS IPDESTBASE ([IPDESTINATIONNET (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) ((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of DATUM)) (fetch (IPADDRESS CLASSCNET) of DATUM)) (T (ERROR "Illegal address class" DATUM))) (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (replace (IPADDRESS CLASSANET) of DATUM with NEWVALUE)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (replace (IPADDRESS CLASSBNET) of DATUM with NEWVALUE)) ((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of DATUM)) (replace (IPADDRESS CLASSCNET) of DATUM with NEWVALUE)) (T (ERROR "Illegal address class" DATUM] (IPDESTINATIONHOST (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSAHOST) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBHOST) of DATUM)) ((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of DATUM)) (fetch (IPADDRESS CLASSCHOST) of DATUM)) (T (ERROR "Illegal address class" DATUM))) (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (replace (IPADDRESS CLASSAHOST) of DATUM with NEWVALUE)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (replace (IPADDRESS CLASSBHOST) of DATUM with NEWVALUE)) ((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of DATUM)) (replace (IPADDRESS CLASSCHOST) of DATUM with NEWVALUE)) (T (ERROR "Illegal address class" DATUM] (ACCESSFNS IPSOURCEADDRESS ((IPSOURCEBASE (LOCF DATUM))) (ACCESSFNS IPSOURCEBASE ([IPSOURCENET (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSANET) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBNET) of DATUM)) ((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of DATUM)) (fetch (IPADDRESS CLASSCNET) of DATUM)) (T (ERROR "Illegal address class" DATUM))) (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (replace (IPADDRESS CLASSANET ) of DATUM with NEWVALUE )) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (replace (IPADDRESS CLASSBNET ) of DATUM with NEWVALUE )) ((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of DATUM)) (replace (IPADDRESS CLASSCNET ) of DATUM with NEWVALUE )) (T (ERROR "Illegal address class" DATUM] (IPSOURCEHOST (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (fetch (IPADDRESS CLASSAHOST) of DATUM)) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (fetch (IPADDRESS CLASSBHOST) of DATUM)) ((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of DATUM)) (fetch (IPADDRESS CLASSCHOST) of DATUM)) (T (ERROR "Illegal address class" DATUM))) (COND ((EQ \IP.CLASS.A (fetch (IPADDRESS CLASSA) of DATUM)) (replace (IPADDRESS CLASSAHOST) of DATUM with NEWVALUE )) ((EQ \IP.CLASS.B (fetch (IPADDRESS CLASSB) of DATUM)) (replace (IPADDRESS CLASSBHOST) of DATUM with NEWVALUE )) ((EQ \IP.CLASS.C (fetch (IPADDRESS CLASSC) of DATUM)) (replace (IPADDRESS CLASSCHOST) of DATUM with NEWVALUE )) (T (ERROR "Illegal address class" DATUM] (TYPE? (type? ETHERPACKET DATUM))) (DATATYPE IPSOCKET ((PROTOCOL BYTE) (IPSLINK POINTER) (* ;  "Other sockets of this protocol type") (NIL BYTE) (IPSQUEUE POINTER) (* ;  "Queue of packets for this protocol") (IPSQUEUELENGTH WORD) (* ; "Count of packets of input queue") (IPSQUEUEALLOC WORD) (* ; "Max count allowed") (IPSDESTSOCKETCOMPAREFN POINTER) (* ;  "Call this to compare dest protocol socket to this socket") (IPSOCKET POINTER) (* ; "This socket") (IPSINPUTFN POINTER) (* ; "Call to hand packet to protocol") (IPSEVENT POINTER) (* ; "Notify me when a packet arrives") (IPSNOSOCKETFN POINTER) (* ; "Call this when no socket found") (IPSICMPFN POINTER) (* ;  "Call this when an ICMP packet is received on this protocol") ) IPSQUEUE _ (create SYSQUEUE) IPSQUEUEALLOC _ \IP.MAX.EPKTS.ON.QUEUE IPSEVENT _ (CREATE.EVENT) IPSINPUTFN _ (FUNCTION \IP.DEFAULT.INPUTFN) IPSICMPFN _ (FUNCTION \RELEASE.ETHERPACKET)) (BLOCKRECORD IPADDRESS ((ADDRESS FIXP)) (* ;; "Class A nets: high bit is 0") (BLOCKRECORD IPADDRESS ((CLASSA BITS 1) (CLASSANET BITS 7) (CLASSAHOST BITS 24))) (* ;; "Class B nets: high 2 bits are 10") (BLOCKRECORD IPADDRESS ((CLASSB BITS 2))) (BLOCKRECORD IPADDRESS ((CLASSBNET BITS 16) (CLASSBHOST BITS 16))) (* ;; "Class C nets: high 3 bits are 110") (BLOCKRECORD IPADDRESS ((CLASSC BITS 3))) (BLOCKRECORD IPADDRESS ((CLASSCNETB1 BITS 8) (CLASSCNETB2 BITS 8) (CLASSCNETB3 BITS 8) (CLASSCHOST BITS 8))) (* ;  "I wish I could say just net bits 24, host bits 8, but BLOCKRECORD barfs") (BLOCKRECORD IPADDRESS ((CLASSCNETHI BITS 16))) [ACCESSFNS IPADDRESS ((CLASSCNET (\MAKENUMBER (FETCH CLASSCNETB1 OF DATUM) (LOGOR (LLSH (FETCH CLASSCNETB2 OF DATUM) 8) (FETCH CLASSCNETB3 OF DATUM))) (PROGN (REPLACE CLASSCNETHI OF DATUM WITH (LRSH NEWVALUE 8)) (REPLACE CLASSCNETB3 OF DATUM WITH (LOGAND NEWVALUE 255)) DATUM]) ) (/DECLAREDATATYPE 'IPSOCKET '(BYTE POINTER BYTE POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER) '((IPSOCKET 0 (BITS . 7)) (IPSOCKET 0 POINTER) (IPSOCKET 2 (BITS . 7)) (IPSOCKET 2 POINTER) (IPSOCKET 4 (BITS . 15)) (IPSOCKET 5 (BITS . 15)) (IPSOCKET 6 POINTER) (IPSOCKET 8 POINTER) (IPSOCKET 10 POINTER) (IPSOCKET 12 POINTER) (IPSOCKET 14 POINTER) (IPSOCKET 16 POINTER)) '18) (DECLARE%: EVAL@COMPILE (RPAQQ \IPOVLEN 20) (RPAQQ \MAX.IPDATALENGTH 556) (RPAQQ \IP.PROTOCOLVERSION 4) (RPAQQ \IP.MAX.EPKTS.ON.QUEUE 16) (RPAQQ \IP.DEFAULT.TIME.TO.LIVE 120) (RPAQQ \IP.WAKEUP.INTERVAL 15000) (CONSTANTS \IPOVLEN \MAX.IPDATALENGTH \IP.PROTOCOLVERSION \IP.MAX.EPKTS.ON.QUEUE \IP.DEFAULT.TIME.TO.LIVE \IP.WAKEUP.INTERVAL) ) (RPAQQ IPPACKETTYPES ((\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052))) (DECLARE%: EVAL@COMPILE (RPAQQ \EPT.IP 2048) (RPAQQ \EPT.AR 2054) (RPAQQ \EET.IP 513) (RPAQQ \EPT.CHAOS 2052) (CONSTANTS (\EPT.IP 2048) (\EPT.AR 2054) (\EET.IP 513) (\EPT.CHAOS 2052)) ) (RPAQQ ICMPUNREACHABLES ((\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5))) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.NET.UNREACHABLE 0) (RPAQQ \ICMP.HOST.UNREACHABLE 1) (RPAQQ \ICMP.PROTOCOL.UNREACHABLE 2) (RPAQQ \ICMP.PORT.UNREACHABLE 3) (RPAQQ \ICMP.CANT.FRAGMENT 4) (RPAQQ \ICMP.SOURCE.ROUTE 5) (CONSTANTS (\ICMP.NET.UNREACHABLE 0) (\ICMP.HOST.UNREACHABLE 1) (\ICMP.PROTOCOL.UNREACHABLE 2) (\ICMP.PORT.UNREACHABLE 3) (\ICMP.CANT.FRAGMENT 4) (\ICMP.SOURCE.ROUTE 5)) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \IPDATABASE MACRO (LAMBDA (IP) (* ejs%: "26-Dec-84 17:50") (* Returns the LOCF of the start of  the data in the packet) (\ADDBASE (fetch (IP IPBASE) of IP) (UNFOLD (fetch (IP IPHEADERLENGTH) of IP) 2] [PUTPROPS \IPDATALENGTH MACRO (LAMBDA (IP) (IDIFFERENCE (fetch (IP IPTOTALLENGTH) of IP) (LLSH (fetch (IP IPHEADERLENGTH) of IP) 2] ) (* "END EXPORTED DEFINITIONS") ) (ADDTOVAR *IP-PROTOCOL-NAME-FROM-NUMBER* (17 . "UDP") (6 . "TCP") (1 . "ICMP")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *IP-PROTOCOL-NAME-FROM-NUMBER*) ) (* ;; "value in sysout is too small. This is 512-(indexf (fetch epencapsulation))-2. 489 is more correct, but let's leave a word of slop for off-by-ones" ) (RPAQQ \10MBPACKETLENGTH 488) (* ;; "Make it easier to see queuelength without opening up q.") (DEFINEQ (\SYSQUEUE.DEFPRINT [LAMBDA (Q STREAM) (* ; "Edited 8-Sep-89 11:06 by bvm") (\DEFPRINT.BY.NAME Q STREAM (if (fetch (SYSQUEUE SYSQUEUEHEAD) of Q) then (\QUEUELENGTH Q) else "Empty") "SysQueue"]) (\IPSOCKET.DEFPRINT [LAMBDA (SOCKET STREAM) (* ; "Edited 25-Aug-88 17:51 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%"") (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (\OUTCHAR STREAM (CHARCODE <)) (LET ((TYPE (CDR (ASSOC (fetch (IPSOCKET PROTOCOL) of SOCKET) *IP-PROTOCOL-NAME-FROM-NUMBER*))) (NUM (fetch (IPSOCKET IPSOCKET) of SOCKET)) (*PRINT-BASE* 10)) (\SOUT (if TYPE then (MKSTRING TYPE) else "IP") STREAM) (\SOUT " Socket" STREAM) (if (if (FIXP NUM) elseif (NULL NUM) then (* ; "I assume this is the master") (SETQ NUM "Head")) then (\OUTCHAR STREAM (CHARCODE SPACE)) (PRIN3 NUM STREAM))) (\OUTCHAR STREAM (CHARCODE /)) (\PRINTADDR SOCKET STREAM) (\OUTCHAR STREAM (CHARCODE >)) T]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (DEFPRINT 'IPSOCKET '\IPSOCKET.DEFPRINT) (DEFPRINT 'SYSQUEUE '\SYSQUEUE.DEFPRINT) ) (RPAQ? IPTRACETIME ) (RPAQ? IPONLYTYPES ) (RPAQ? IPIGNORETYPES ) (RPAQ? IPPRINTMACROS ) (RPAQ? IPTRACEFLG ) (RPAQ? IPTRACEFILE ) (RPAQ? \IP.INIT.FILE ) (RPAQ? \IP.DEFAULT.CONFIGURATION ) (RPAQ? \IP.HOSTNAMES (HASHARRAY 40 1.1)) (RPAQ? \IP.HOSTNUMBERS ) (RPAQ? INTERNET.LOCAL.DOMAIN ) (/DECLAREDATATYPE 'IPSOCKET '(BYTE POINTER BYTE POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER) '((IPSOCKET 0 (BITS . 7)) (IPSOCKET 0 POINTER) (IPSOCKET 2 (BITS . 7)) (IPSOCKET 2 POINTER) (IPSOCKET 4 (BITS . 15)) (IPSOCKET 5 (BITS . 15)) (IPSOCKET 6 POINTER) (IPSOCKET 8 POINTER) (IPSOCKET 10 POINTER) (IPSOCKET 12 POINTER) (IPSOCKET 14 POINTER) (IPSOCKET 16 POINTER)) '18) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IPTRACEFILE IPTRACEFLG IPIGNORETYPES IPONLYTYPES IPPRINTMACROS \IP.HOSTNAMES \IP.INIT.FILE INTERNET.LOCAL.DOMAIN \IP.DEFAULT.CONFIGURATION \IP.HOSTNUMBERS) ) (FILESLOAD (SYSLOAD) TCPHTE TCPLLICMP TCPLLAR) (ADDTOVAR \PACKET.PRINTERS (2048 . PRINTIP)) (DEFINEQ (\CANONICALIZE.IP.HOSTNAME [LAMBDA (NAME) (* ; "Edited 12-Apr-88 17:18 by bvm") (AND \IP.READY (IPHOSTADDRESS NAME) NAME]) (DODIP.HOSTP [LAMBDA (NAME) (* ; "Edited 27-Feb-89 21:49 by welch") (COND ((NULL NAME) NIL) ((NUMBERP NAME)) (T (LET [(NAME (\DOMAIN.NAME.QUALIFY.FULLY (U-CASE NAME] (COND ((IPHOSTADDRESS NAME)) (T (if (CL:FBOUNDP 'DOMAIN.LOOKUP.ADDRESS) then (CAR (DOMAIN.LOOKUP.ADDRESS NAME]) (IPHOSTADDRESS [LAMBDA (NAME) (* ; "Edited 19-Jan-88 14:41 by FS") (LET (ENTRY) (* ;; "Hack to handle strings, by canonicalizing NAME") (SETQ NAME (MKATOM (U-CASE NAME))) (SETQ ENTRY (GETHASH NAME \IP.HOSTNAMES)) (COND (ENTRY (LET [(ADDRESS (CAR (fetch (HOSTS.TXT.ENTRY HTE.ADDRESSES) of ENTRY] [COND ((NOT (SASSOC ADDRESS \IP.HOSTNUMBERS)) (push \IP.HOSTNUMBERS (CONS ADDRESS NAME] ADDRESS)) ((\IP.READ.STRING.ADDRESS NAME]) (IPHOSTNAME [LAMBDA (IPADDRESS) (* ejs%: "22-Apr-85 13:54") (OR (CDR (SASSOC IPADDRESS \IP.HOSTNUMBERS)) (MKATOM (\IP.ADDRESS.TO.STRING IPADDRESS]) (IPTRACE [LAMBDA (FLG REGION) (* ; "Edited 13-Sep-88 14:53 by bvm") (MAKE-NETWORK-TRACE-WINDOW 'IPTRACEFLG 'IPTRACEFILE "IP traffic" REGION FLG]) (IPTRACEWINDOW.BUTTONFN [LAMBDA (WINDOW) (* ejs%: " 2-Jun-85 13:05") (COND ((MOUSESTATE (NOT UP)) (SETQ IPTRACEFLG (SELECTQ IPTRACEFLG (NIL T) (T 'PEEK) (PEEK NIL) NIL)) (printout WINDOW T "[Tracing " (SELECTQ IPTRACEFLG (T "on") (PEEK "peek") "off") "]" T]) (PRINTIP [LAMBDA (IP CALLER FILE PRE.NOTE DOFILTER) (* ; "Edited 28-Apr-88 14:05 by bvm") (PROG ((*STANDARD-OUTPUT* (GETSTREAM (OR FILE IPTRACEFILE) 'OUTPUT)) (PROTOCOL (fetch (IP IPPROTOCOL) of IP)) MACRO LENGTH) [COND (DOFILTER (COND ((COND (IPONLYTYPES (NOT (FMEMB PROTOCOL IPONLYTYPES))) (IPIGNORETYPES (FMEMB PROTOCOL IPIGNORETYPES))) (RETURN (PRIN1 (SELECTQ CALLER ((PUT RAWPUT) '!) ((GET RAWGET) '+) '?] (AND PRE.NOTE (printout NIL T PRE.NOTE)) (if CALLER then (* ; "Print GET or PUT") (FRESHLINE) (PRINTOUT NIL CALLER " ")) (printout NIL "From " (\IP.ADDRESS.TO.STRING (fetch (IP IPSOURCEADDRESS) of IP)) " to " (\IP.ADDRESS.TO.STRING (fetch (IP IPDESTINATIONADDRESS) of IP))) (if IPTRACETIME then (LET ((CSECS (\CENTICLOCK IP))) (PRINTOUT NIL " [" |.I4| (IQUOTIENT CSECS 100) "." |.I2..T| (IREMAINDER CSECS 100) "]"))) (TERPRI) [COND ((AND (SETQ MACRO (CDR (FASSOC PROTOCOL IPPRINTMACROS))) (NLISTP MACRO)) (* ;  "Macro is a function to which to dispatch for the printing.") (CL:FUNCALL MACRO IP *STANDARD-OUTPUT*) (RETURN (TERPRI] (printout NIL "Length = " |.P2| (SETQ LENGTH (fetch (IP IPTOTALLENGTH) of IP)) " bytes" " (header + " |.P2| (IDIFFERENCE LENGTH \IPOVLEN) ")" T "Protocol = ") (PRINTCONSTANT PROTOCOL IPPROTOCOLTYPES NIL) (TERPRI) [COND ((IGREATERP LENGTH \IPOVLEN) (* ; "MACRO tells how to print data.") (PRIN1 "Contents: ") (PRINTIPDATA IP (OR MACRO '(BYTES 12 |...|] (TERPRI) (RETURN IP]) (PRINTIPDATA [LAMBDA (IP MACRO OFFSET FILE) (* ejs%: "27-Dec-84 18:43") (* * Prints DATA part of IP starting at OFFSET  (Default zero) according to MACRO. MACRO contains elements describing what  format the data is in -  WORDS, BYTES, CHARS%: print as words, bytes  (numeric) or ascii characters -  %: subsequent commands apply starting at this byte offset -  ...%: print "..." and quit if you still have data at this point) (PROG ((DATA (\IPDATABASE IP)) (LENGTH (\IPDATALENGTH IP))) (PRINTPACKETDATA DATA OFFSET MACRO LENGTH FILE]) (\IPADDRESSCLASS [LAMBDA (IPADDRESS) (* ; "Edited 26-Oct-88 12:49 by bvm") (if (SMALLP IPADDRESS) then (* ; "bogus unless it's broadcastp") '\IP.CLASS.A elseif (EQ \IP.CLASS.C (SETQ IPADDRESS (fetch (IPADDRESS CLASSC) of IPADDRESS))) then '\IP.CLASS.C elseif (EQ \IP.CLASS.B (SETQ IPADDRESS (LRSH IPADDRESS 1))) then '\IP.CLASS.B elseif (EQ \IP.CLASS.A (LRSH IPADDRESS 1)) then '\IP.CLASS.A]) (\IPEVENTFN [LAMBDA (EVENT) (* ; "Edited 13-Sep-88 18:53 by Hiroshi Hayata") (* ;; "If maiko, do nothing. ") (* ;; "Call of \IPINIT with AFTERSYSOUT on maiko cause RAID.") (COND ((EQ \MACHINETYPE \MAIKO) NIL) (T (COND (\IPFLG (\IPINIT EVENT]) (\IPHOSTADDRESS [LAMBDA (IPADDRESS) (* ; "Edited 26-Oct-88 12:43 by bvm") (if (SMALLP IPADDRESS) then (* ; "can only be class a or bogus") (LOGAND IPADDRESS MAX.SMALLP) elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS) \IP.CLASS.A) then (fetch (IPADDRESS CLASSAHOST) of IPADDRESS) elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS) \IP.CLASS.B) then (fetch (IPADDRESS CLASSBHOST) of IPADDRESS) elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS) \IP.CLASS.C) then (fetch (IPADDRESS CLASSCHOST) of IPADDRESS]) (\IPNETADDRESS [LAMBDA (IPADDRESS) (* ; "Edited 26-Oct-88 12:45 by bvm") (if (SMALLP IPADDRESS) then (* ; "bogus unless it's broadcastp") (if (< IPADDRESS 0) then -1 else 0) elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS) \IP.CLASS.A) then (fetch (IPADDRESS CLASSANET) of IPADDRESS) elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS) \IP.CLASS.B) then (fetch (IPADDRESS CLASSBNET) of IPADDRESS) elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS) \IP.CLASS.C) then (fetch (IPADDRESS CLASSCNET) of IPADDRESS]) (\IP.ADDRESS.TO.STRING [LAMBDA (IPADDRESS) (* ejs%: "28-Dec-84 08:43") (RESETFORM (RADIX 10) (CONCAT (LDB (BYTE 8 24) IPADDRESS) "." (LDB (BYTE 8 16) IPADDRESS) "." (LDB (BYTE 8 8) IPADDRESS) "." (LDB (BYTE 8 0) IPADDRESS]) (\IP.BROADCAST.ADDRESS [LAMBDA (IPADDRESS) (* ; "Edited 26-Oct-88 14:59 by bvm") (* ;;  "0's in the host field are now considered broadcasts, so this code works with Berkeley Unix") (LET (HOST MASK) (if (SMALLP IPADDRESS) then (OR (EQ IPADDRESS 0) (EQ IPADDRESS -1)) elseif (EQ (fetch (IPADDRESS CLASSA) of IPADDRESS) \IP.CLASS.A) then [if (AND \IP.SUBNET.MASKS (ASSOC (fetch (IPADDRESS CLASSANET) of IPADDRESS) \IP.LOCAL.NETWORKS)) then (* ;  "If it's our subnet, check only the subnetted host part. The LOGOR patches bogus subnet masks") [SETQ HOST (LOGAND IPADDRESS (SETQ MASK (LOGXOR (LOGOR (CDAR \IP.SUBNET.MASKS ) -16777216) -1] (OR (EQ HOST 0) (EQL HOST MASK)) else (SETQ HOST (fetch (IPADDRESS CLASSAHOST) of IPADDRESS)) (OR (EQ HOST 0) (EQL HOST (MASK.1'S 0 24] elseif (EQ (fetch (IPADDRESS CLASSB) of IPADDRESS) \IP.CLASS.B) then [if (AND \IP.SUBNET.MASKS (ASSOC (fetch (IPADDRESS CLASSBNET) of IPADDRESS) \IP.LOCAL.NETWORKS)) then [SETQ HOST (LOGAND IPADDRESS (SETQ MASK (LOGXOR (LOGOR (CDAR \IP.SUBNET.MASKS ) -65536) -1] (OR (EQ HOST 0) (EQ HOST MASK)) else (SETQ HOST (fetch (IPADDRESS CLASSBHOST) of IPADDRESS)) (OR (EQ HOST 0) (EQ HOST (MASK.1'S 0 16] elseif (EQ (fetch (IPADDRESS CLASSC) of IPADDRESS) \IP.CLASS.C) then (SETQ HOST (fetch (IPADDRESS CLASSCHOST) of IPADDRESS)) (* ; "No subnetting here") (OR (EQ HOST 0) (EQ HOST (MASK.1'S 0 8))) elseif (EQ (fetch (IPADDRESS CLASSBNET) of IPADDRESS) MAX.SMALLP) then (* ;  "Sort of illegal, but recognize all ones as broadcast") (EQ (fetch (IPADDRESS CLASSBHOST) of IPADDRESS) MAX.SMALLP]) (\IP.LEGAL.ADDRESS [LAMBDA (ADDRESS) (* ejs%: "25-Mar-86 16:00") (AND (NOT (EQ ADDRESS 0)) (NOT (EQ ADDRESS -1)) (OR (EQ \IP.CLASS.C (SETQ ADDRESS (LRSH ADDRESS 29))) (EQ \IP.CLASS.B (SETQ ADDRESS (LRSH ADDRESS 1))) (EQ \IP.CLASS.A (LRSH ADDRESS 1]) (\IP.MAKE.BROADCAST.ADDRESS [LAMBDA (IPADDRESS) (* ejs%: " 3-Jun-85 01:02") (SELECTQ (\IPADDRESSCLASS IPADDRESS) (\IP.CLASS.A (LOGOR (MASK.1'S 0 24) IPADDRESS)) (\IP.CLASS.B (LOGOR (MASK.1'S 0 16) IPADDRESS)) (\IP.CLASS.C (LOGOR (MASK.1'S 0 8) IPADDRESS)) (SHOULDNT]) (\IP.PRINT.ADDRESS [LAMBDA (IPADDRESS FILE) (* ejs%: "28-Dec-84 08:42") (RESETFORM (RADIX 10) (PRIN1 (LDB (BYTE 8 24) IPADDRESS) FILE) (PRIN1 "." FILE) (PRIN1 (LDB (BYTE 8 16) IPADDRESS) FILE) (PRIN1 "." FILE) (PRIN1 (LDB (BYTE 8 8) IPADDRESS) FILE) (PRIN1 "." FILE) (PRIN1 (LDB (BYTE 8 0) IPADDRESS) FILE) IPADDRESS]) (\IP.READ.STRING.ADDRESS [LAMBDA (STRING.OR.ATOM) (* ; "Edited 21-Apr-88 14:41 by bvm") (for CHAR instring (MKSTRING STRING.OR.ATOM) bind (RESULT _ (NCREATE 'FIXP)) (INDEX _ 0) BYTE do (if (> INDEX 3) then (* ;  "Got 3 parts and there's still more to go, must be bad") (RETURN NIL) elseif (EQ CHAR (CHARCODE %.)) then (if BYTE then (\PUTBASEBYTE RESULT INDEX BYTE)) (SETQ BYTE NIL) (add INDEX 1) elseif (AND (SETQ CHAR (CL:DIGIT-CHAR-P (CL:INT-CHAR CHAR))) (< (SETQ BYTE (+ (if BYTE then (TIMES BYTE 10) else 0) CHAR)) 256)) then (* ;  "Accumulated decimal digit, and we haven't overflowed a byte yet") else (* ; "Malformed") (RETURN NIL)) finally (if BYTE then (\PUTBASEBYTE RESULT INDEX BYTE) (add INDEX 1)) (RETURN (AND (EQ INDEX 4) RESULT]) (\DOMAIN.NAME.QUALIFY.FULLY [LAMBDA (NAME) (* ; "Edited 29-Aug-90 16:27 by gadener") (* Make a fully qualified domain  name from a partial one) (if (OR (NULL INTERNET.LOCAL.DOMAIN) (STRPOS "." NAME)) then NAME else (MKATOM (CONCAT NAME "." INTERNET.LOCAL.DOMAIN]) ) (* ;; "Startup and shutdown") (RPAQ? *IP-DEFAULT-HOSTS-FILE* ) (RPAQ? TCP.ALWAYS.READ.HOSTS.FILE T) (RPAQ? \TCP.LAST.HOSTS.FILE.DATE ) (RPAQ? \TCP.LAST.HOSTS.FILE.READ ) (RPAQ? \IPFLG ) (RPAQ? \IP.READY ) (RPAQ? \IP.READY.EVENT (CREATE.EVENT "IP Ready")) (RPAQ? \IP.WAKEUP.TIMER ) (RPAQ? IPTRACEFLG ) (RPAQ? \IP.WAKEUP.EVENT (CREATE.EVENT "IP Wakeup")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IPFLG \IP.READY \IP.READY.EVENT \IP.WAKEUP.TIMER \IP.WAKEUP.EVENT TCP.ALWAYS.READ.HOSTS.FILE \TCP.LAST.HOSTS.FILE.DATE \TCP.LAST.HOSTS.FILE.READ *IP-DEFAULT-HOSTS-FILE*) ) (DEFINEQ (STOPIP [LAMBDA NIL (* ejs%: "28-Dec-84 08:10") (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.IP)) (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.AR)) (DEL.PROCESS '\IPLISTENER) (SETQ \IPFLG (SETQ \IP.READY NIL]) (\IPINIT [LAMBDA (EVENT) (* ; "Edited 18-Mar-88 17:22 by bvm") (* ;; "Initialize IP protocol. Called with EVENT NIL for explicit restart, RESTART from RESTART.ETHER, otherwise from usual around exit events via \ETHEREVENTFN and RESTARTETHERFNS after Pup and/an \icmp.echo.reply") (* ;; "or NS turned on.") (SELECTQ EVENT ((NIL RESTART AFTERSYSOUT AFTERMAKESYS AFTERLOGOUT AFTERSAVEVM) (if (AND (NULL \IPFLG) (NOT (NULL EVENT))) then (* ;  "Nothing to do. Only turn IP on for explicit call to \IPINIT") NIL elseif [OR (NULL EVENT) (NULL \IP.DEFAULT.CONFIGURATION) (NOT (EQUAL \MY.NSHOSTNUMBER (fetch (IPINIT LOCAL.NSHOSTNUMBER) of \IP.DEFAULT.CONFIGURATION] then (* ;  "Machine changed, or caller explicitly wants us to reread the init file") (SETQ \IP.DEFAULT.CONFIGURATION NIL) (SETQ \IP.LOCAL.ADDRESSES NIL) (SETQ \IP.LOCAL.NETWORKS NIL) (SETQ \IP.SUBNET.MASKS NIL) (DEL.PROCESS '\IPLISTENER) [SELECTQ EVENT ((NIL RESTART) (* ; "Can do it here--explicit manual restart. Otherwise spawn process, so that we can do arbitrary things like rely on other devices initialized later than ether") (\IP.REINITIALIZE.FROM.SCRATCH)) (ADD.PROCESS `(\IP.REINITIALIZE.FROM.SCRATCH ',EVENT] else (\IP.RESTART.FROM.CONFIGURATION EVENT))) NIL]) (\IPLISTENER [LAMBDA NIL (* ejs%: "25-Jun-85 18:52") (* * IP background process) (SETQ \IP.WAKEUP.TIMER (SETUPTIMER \IP.WAKEUP.INTERVAL)) (bind [\AR.WAKEUP.TIMER _ (SETUPTIMER (CONSTANT (ITIMES 4 \IP.WAKEUP.INTERVAL] while T do (AWAIT.EVENT \IP.WAKEUP.EVENT \IP.WAKEUP.INTERVAL) (\IP.CHECK.REASSEMBLY.TIMEOUTS) (COND ((TIMEREXPIRED? \AR.WAKEUP.TIMER) (\AR.DAEMON) (SETQ \AR.WAKEUP.TIMER (SETUPTIMER (CONSTANT (ITIMES 4 \IP.WAKEUP.INTERVAL)) \AR.WAKEUP.TIMER]) (\IP.REINITIALIZE.FROM.SCRATCH [LAMBDA (EVENT) (* ; "Edited 20-Jan-89 18:35 by bvm") (DECLARE (GLOBALVARS \IP.DEFAULT.CONFIGURATION \IP.LOCAL.ADDRESSES)) (* ;; "Called when we have never enabled IP, or the machine's address has changed.") (RESETBUFS (PROG (FILE ADDRESS.STRING HOSTS.FILE HOSTNAME ADDRESSES) (* ;;  "This is a kludge until we know more about IP routing and reverse address resolution (??)") [SETQ \IP.DEFAULT.CONFIGURATION (COND ((AND (SETQ FILE (INFILEP '{DSK}IP.INIT)) (\IP.READ.INIT.FILE FILE))) ((IP.DEFAULT.CONFIGURATION)) ((AND (SETQ FILE (\IP.PROMPT.FOR.FILE.NAME "Please enter the name of the IP initialization file for this host: " )) (\IP.READ.INIT.FILE FILE))) (T (* ;  "User declined to specify, or init file failed, so give up") (PRINTOUT T "IP not initialized" T) (RETURN NIL] (COND ((SETQ FILE (OR (fetch (IPINIT HTE.FILE) of \IP.DEFAULT.CONFIGURATION ) *IP-DEFAULT-HOSTS-FILE*)) (* ;;  "there is a hosts file in the configuration. Now see if we really want to read it.") (\IP.MAYBE.READ.HOSTS.TXT T FILE))) (COND ([AND (NOT (SETQ HOSTNAME (fetch (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION ))) (SETQ HOSTNAME (AND (EQ \PUP.READY T) (U-CASE (ETHERHOSTNAME] (replace (IPINIT HOSTNAME) of \IP.DEFAULT.CONFIGURATION with HOSTNAME))) [COND [(SETQ ADDRESSES (fetch (IPINIT LOCAL.ADDRESSES) of \IP.DEFAULT.CONFIGURATION )) (SETQ \IP.LOCAL.ADDRESSES (for ADDR in ADDRESSES collect (\IP.READ.STRING.ADDRESS ADDR] ((AND HOSTNAME (SETQ ADDRESSES (DODIP.HOSTP HOSTNAME))) (SETQ \IP.LOCAL.ADDRESSES (LIST ADDRESSES))) (T (until (SETQ ADDRESS.STRING (PROMPTFORWORD "Please enter this machine's IP host address (e.g. 39.9.0.9)" ))) (SETQ \IP.LOCAL.ADDRESSES (LIST (\IP.READ.STRING.ADDRESS ADDRESS.STRING))) (COND (HOSTNAME (* ;  "Associate name with local address(es)") (PUTHASH HOSTNAME [create HOSTS.TXT.ENTRY HTE.TYPE _ 'HOST HTE.ADDRESSES _ \IP.LOCAL.ADDRESSES HTE.NAMES _ (LIST HOSTNAME) HTE.MACHINE.TYPE _ (SELECTQ (MACHINETYPE) (DOVE 'XEROX-1185) (DANDELION 'XEROX-1108) (DOLPHIN 'XEROX-1100) (DORADO 'XEROX-1132) 'XEROX-11XX) HTE.OS.TYPE _ 'INTERLISP HTE.PROTOCOLS _ '((TCP) (IP] \IP.HOSTNAMES] (\IP.RESTART.FROM.CONFIGURATION EVENT T]) (\IP.RESTART.FROM.CONFIGURATION [LAMBDA (EVENT NEW.INIT) (* ; "Edited 26-Feb-89 21:28 by welch") (* ;; "Reinitialize IP after logout, etc, from the info in the default configuration. This is the only place that sets \IP.READY true.") (GLOBALVARS INTERNET.LOCAL.DOMAIN) (PROG ((GATE (fetch (IPINIT DEFAULT.GATEWAY) of \IP.DEFAULT.CONFIGURATION)) (NETS (fetch (IPINIT LOCAL.NETWORKS) of \IP.DEFAULT.CONFIGURATION)) PROC NDB) (SETQ \IP.DEFAULT.GATEWAY (AND GATE (\IP.READ.STRING.ADDRESS GATE))) (SETQ \IP.ROUTING.TABLE (CONS)) (SETQ \AR.IP.TO.10MB.ALIST NIL) (SETQ INTERNET.LOCAL.DOMAIN (fetch (IPINIT LOCAL.DOMAIN) of \IP.DEFAULT.CONFIGURATION )) [COND [(EQLENGTH NETS (LENGTH \IP.LOCAL.ADDRESSES)) (* ;;  "List tells net numbers of each directly connected net. Each element = (%"net.number%" . type).") (SETQ \IP.LOCAL.NETWORKS (bind NDB for NET.AND.TYPE in NETS as ADDRESS in \IP.LOCAL.ADDRESSES collect (LET* [(TYPE (CDR NET.AND.TYPE)) [NET (\IPNETADDRESS (\IP.READ.STRING.ADDRESS (CAR NET.AND.TYPE] (NDB (SELECTQ TYPE (3 \3MBLOCALNDB) (10 \10MBLOCALNDB) (SHOULDNT] (replace (NDB NDBIPNET#) of NDB with NET) (replace (NDB NDBIPHOST#) of NDB with ADDRESS) (CONS NET NDB] ((NULL \IP.LOCAL.ADDRESSES) (RETURN (CL:WARN "Error in IP init file. No local host address specified"))) ((AND (NULL (CDR \IP.LOCAL.ADDRESSES)) (NULL (fetch (NDB NDBNEXT) of \LOCALNDBS))) (* ;  "Only one address, so it goes with our one net") [SETQ \IP.LOCAL.NETWORKS (LIST (CONS (\IPNETADDRESS (CAR \IP.LOCAL.ADDRESSES)) (SETQ NDB (OR \10MBLOCALNDB \3MBLOCALNDB] (replace (NDB NDBIPNET#) of NDB with (CAAR \IP.LOCAL.NETWORKS)) (replace (NDB NDBIPHOST#) of NDB with (CAR \IP.LOCAL.ADDRESSES))) (T (RETURN (CL:WARN "Error in IP init file. Network list and local address list do not correlate." ] [SETQ \IP.SUBNET.MASKS (for LOCALADDR in \IP.LOCAL.ADDRESSES as MASK in (fetch (IPINIT SUBNETMASK) of \IP.DEFAULT.CONFIGURATION ) as NETADDRESS in NETS collect (CONS LOCALADDR (\IP.READ.STRING.ADDRESS (OR MASK (CAR NETADDRESS] (COND ((BOUNDP '\DOMAIN.NAMESERVERS) (\DOMAIN.INIT EVENT))) (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.IP)) (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.AR)) (SETQ \IPFLG T) (\IP.ADD.PROTOCOL \ICMP.PROTOCOL (FUNCTION TRUE) (FUNCTION NILL) (FUNCTION \ICMP.INPUT)) (COND ((SETQ PROC (FIND.PROCESS '\IPLISTENER)) (RESTART.PROCESS PROC)) (T (ADD.PROCESS '(\IPLISTENER) 'RESTARTABLE 'SYSTEM 'AFTEREXIT \IP.READY.EVENT))) (if (NOT NEW.INIT) then (* ; "Finally, check for new hosts.txt file, but we can do this in background. If NEW.INIT, the configuration code has already read it.") (ADD.PROCESS '(\IP.MAYBE.READ.HOSTS.TXT T) 'AFTEREXIT 'DELETE)) (SETQ \IP.READY T) (NOTIFY.EVENT \IP.READY.EVENT) (\ICMP.REQUEST.ADDRESS.MASK) (RETURN T]) (\IP.MAYBE.READ.HOSTS.TXT [LAMBDA (AFTEREXIT FILE) (* ; "Edited 20-Jan-89 11:56 by bvm") (* ;; "Read the hosts.txt file if it has changed") (if AFTEREXIT then (* ;  "Have to wait until all devices are happy") (until \PROC.READY do (AWAIT.EVENT \PROCESS.AFTEREXIT.EVENT 10000))) (LET (FULLNAME) (COND ((NULL FILE)) (TCP.ALWAYS.READ.HOSTS.FILE (* ;  "the user wants us to always read it fresh.") (\HTE.READ.FILE FILE)) ((NULL (SETQ FULLNAME (INFILEP FILE))) (CL:FORMAT PROMPTWINDOW "~%%Couldn't find hosts file ~A" FILE)) ([AND \TCP.LAST.HOSTS.FILE.DATE (STRING-EQUAL FULLNAME \TCP.LAST.HOSTS.FILE.READ) (EQUAL \TCP.LAST.HOSTS.FILE.DATE (GETFILEINFO FILE 'ICREATIONDATE] (* ;  "the file names and the file write dates are the same, don't re-read the hosts file.") NIL) (T (* ;  "Haven't read this particular file before, so snarf it") (\HTE.READ.FILE FILE]) (\IP.READ.INIT.FILE [LAMBDA (FILE) (* ; "Edited 18-Mar-88 18:34 by bvm") (CL:MULTIPLE-VALUE-BIND (CONFIGURATION CONDITION) [IGNORE-ERRORS (LET ((*UPPER-CASE-FILE-NAMES* NIL) (*READTABLE* (FIND-READTABLE "INTERLISP"))) (CL:WITH-OPEN-FILE (S FILE) (READ S] (if CONDITION then (PRINTOUT T "Failed to read init file because: " CONDITION) NIL else (LET ((HOST (fetch (IPINIT LOCAL.NSHOSTNUMBER) of CONFIGURATION))) (if (NULL HOST) then (* ;  "Old file that doesn't have its processor identification in it") (create IPINIT using CONFIGURATION LOCAL.NSHOSTNUMBER _ \MY.NSHOSTNUMBER) elseif (EQUAL HOST \MY.NSHOSTNUMBER) then (* ; "Good, init file for same host") CONFIGURATION else (PRINTOUT T FILE " gives configuration for host " ( \COERCE.TO.NSADDRESS HOST) " but this is machine " (\COERCE.TO.NSADDRESS \MY.NSHOSTNUMBER) T) NIL]) (\IP.PROMPT.FOR.FILE.NAME [LAMBDA (PROMPT DEFAULT) (* ; "Edited 18-Mar-88 18:14 by bvm") (* ;; "Prompts for a file name from user and returns its full name if it is infilep") (bind NAME do (if [NULL (SETQ NAME (PROG1 (PROMPTFORWORD PROMPT DEFAULT NIL NIL NIL NIL (CHARCODE (CR))) (TERPRI] then (RETURN NIL) elseif (SETQ NAME (INFILEP NAME)) then (RETURN NAME) else (PRINTOUT T "File not found" T]) ) (ADDTOVAR RESTARTETHERFNS \IPEVENTFN) (* ;; "Early IP reception functions") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ IPADDRESSTYPES ((\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24)) (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30)) (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) (\IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0)))) (DECLARE%: EVAL@COMPILE (RPAQQ \IP.CLASS.A 0) (RPAQ \IP.CLASS.A.BYTESPEC (BYTE 1 31)) (RPAQ \IP.CLASS.A.NET.BYTESPEC (BYTE 8 24)) (RPAQ \IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (RPAQQ \IP.CLASS.B 2) (RPAQ \IP.CLASS.B.BYTESPEC (BYTE 2 30)) (RPAQ \IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (RPAQ \IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (RPAQQ \IP.CLASS.C 6) (RPAQ \IP.CLASS.C.BYTESPEC (BYTE 3 29)) (RPAQ \IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (RPAQ \IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0)) (CONSTANTS (\IP.CLASS.A 0) (\IP.CLASS.A.BYTESPEC (BYTE 1 31)) (\IP.CLASS.A.NET.BYTESPEC (BYTE 8 24)) (\IP.CLASS.A.HOST.BYTESPEC (BYTE 24 0)) (\IP.CLASS.B 2) (\IP.CLASS.B.BYTESPEC (BYTE 2 30)) (\IP.CLASS.B.NET.BYTESPEC (BYTE 16 16)) (\IP.CLASS.B.HOST.BYTESPEC (BYTE 16 0)) (\IP.CLASS.C 6) (\IP.CLASS.C.BYTESPEC (BYTE 3 29)) (\IP.CLASS.C.NET.BYTESPEC (BYTE 24 8)) (\IP.CLASS.C.HOST.BYTESPEC (BYTE 8 0))) ) (* "END EXPORTED DEFINITIONS") ) (RPAQ? \IP.LOCAL.ADDRESSES ) (RPAQ? \IP.SUBNET.MASKS ) (RPAQ? \IP.GATEWAY.FLG ) (RPAQ \IP.ADDRESS.BOX (\CREATECELL \FIXP)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IP.LOCAL.ADDRESSES \IP.SUBNET.MASKS \IP.GATEWAY.FLG \IP.ADDRESS.BOX) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \IP.FIX.DEST.HOST MACRO (LAMBDA (IP NDB) (* ejs%: "26-Dec-84 15:07") (replace (IP IPDESTINATIONHOST) of IP with (ffetch (NDB NDBIPHOST#) of NDB] [PUTPROPS \IP.FIX.DEST.NET MACRO (LAMBDA (IP NDB) (* ejs%: "26-Dec-84 15:08") (* * Put the IP net# corresponding to the given NDB into the destination net  field of the dest address of the IP packet) (replace (IP IPDESTINATIONADDRESS) of IP with (LOGOR (fetch (IP IPDESTINATIONADDRESS) of IP) (LLSH (fetch (NDB NDBIPNET#) of NDB) (SELECTQ (\IPADDRESSCLASS (fetch (NDB NDBIPHOST#) of NDB)) (\IP.CLASS.A 24) (\IP.CLASS.B 16) (\IP.CLASS.C 8) (SHOULDNT] [PUTPROPS \IP.FIX.SOURCE.HOST MACRO (LAMBDA (IP NDB) (* ejs%: "26-Dec-84 15:07") (replace (IP IPSOURCEHOST) of IP with (ffetch (NDB NDBIPHOST#) of NDB] [PUTPROPS \IP.FIX.SOURCE.NET MACRO (LAMBDA (IP NDB) (* ejs%: "26-Dec-84 15:08") (* * Put the IP net# corresponding to the given NDB into the destination net  field of the dest address of the IP packet) (replace (IP IPSOURCENET) of IP with (ffetch (NDB NDBIPNET#) of NDB] ) (DEFINEQ (\HANDLE.RAW.IP [LAMBDA (IP TYPE) (* ejs%: " 3-Feb-86 11:01") (PROG ((NDB (ffetch (ETHERPACKET EPNETWORK) of IP))) (COND ((NOT (type? NDB NDB)) (ERROR "No NDB in ETHERPACKET!" IP))) (SELECTQ (ffetch (NDB NETTYPE) of NDB) (10 (COND ((NEQ TYPE \EPT.IP) (RETURN)))) (3 (COND ((NEQ TYPE \EET.IP) (RETURN)))) (ERROR "Unknown net type" (ffetch (NDB NETTYPE) of NDB))) [COND ((NOT \IP.READY) (\RELEASE.ETHERPACKET IP)) ([NOT (\IP.CHECKSUM.OK (\IPCHECKSUM IP (ffetch (IP IPBASE) of IP) (TIMES (ffetch (IP IPHEADERLENGTH) of IP) BYTESPERCELL] (AND IPTRACEFLG (PRINTPACKET IP 'GET IPTRACEFILE "[Packet dropped--bad IP header checksum]")) (\RELEASE.ETHERPACKET IP)) ((ZEROP (ffetch (IP IPTIMETOLIVE) of IP)) (\ICMP.TIME.EXCEEDED IP \ICMP.TRANSIT.TIME.EXCEEDED) (\RELEASE.ETHERPACKET IP)) ((\IP.PROCESS.OPTIONS IP) (COND ((NOT (\IP.LOCAL.DESTINATION IP)) (\FORWARD.IP IP)) [(\IP.FRAGMENTED.PACKET IP) (COND ((SETQ IP (\HANDLE.RAW.IP.FRAGMENT IP)) [COND (IPTRACEFLG (COND ((EQ IPTRACEFLG T) (PRINTIP IP 'GETFRAGMENT IPTRACEFILE NIL T)) (T (PRIN1 "+" IPTRACEFILE] (\IP.HAND.TO.PROTOCOL IP] (T [COND (IPTRACEFLG (COND ((EQ IPTRACEFLG T) (PRINTIP IP 'GET IPTRACEFILE NIL T)) (T (PRIN1 "+" IPTRACEFILE] (\IP.HAND.TO.PROTOCOL IP] (RETURN T]) (\FORWARD.IP [LAMBDA (IP) (* ejs%: "10-Feb-86 11:32") (DECLARE (GLOBALVARS \IP.GATEWAY.FLG \IP.GATEWAY.FORWARDING.FUNCTIONS)) (COND [\IP.GATEWAY.FLG (LET* ((DESTADDRESS (ffetch (IP IPDESTINATIONADDRESS) of IP)) (NETADDRESS (\IPNETADDRESS DESTADDRESS)) (NDB (fetch (ETHERPACKET EPNETWORK) of IP)) (SOURCEADDRESS (fetch NDBIPHOST# of NDB)) (SUBNETMASK (CDR (SASSOC SOURCEADDRESS \IP.SUBNET.MASKS))) SUBNETINUSE ROUTE FORWARDING.FUNCTION) [COND [(AND NDB SUBNETMASK (OR (EQP (LOGAND SOURCEADDRESS SUBNETMASK) (LOGAND DESTADDRESS SUBNETMASK)) (PROGN (SETQ SUBNETINUSE T) NIL] ((NULL NDB) (COND ((SETQ ROUTE (CDR (SASSOC NETADDRESS \IP.ROUTING.TABLE))) (SETQ NDB (CDR (SASSOC (\IPNETADDRESS ROUTE) \IP.LOCAL.NETWORKS] (COND [NDB (replace EPREQUEUE of IP with 'FREE) (add (ffetch (IP IPTIMETOLIVE) of IP) -1) [SETQ NETADDRESS (COND (SUBNETINUSE (LOGAND DESTADDRESS SUBNETMASK )) (T (BITCLEAR DESTADDRESS (\IPHOSTADDRESS DESTADDRESS] (COND ((SETQ FORWARDING.FUNCTION (CDR (SASSOC NETADDRESS \IP.GATEWAY.FORWARDING.FUNCTIONS ))) (APPLY* FORWARDING.FUNCTION IP NDB NETADDRESS ROUTE)) (T (\RELEASE.ETHERPACKET IP] (T (\ICMP.REDIRECT IP \ICMP.REDIRECT.NET] (T (\RELEASE.ETHERPACKET IP]) (\IP.LOCAL.DESTINATION [LAMBDA (IP) (* ejs%: "25-Mar-86 16:03") (* * Return T if IP packet is destined for us) (UNINTERRUPTABLY (\BLT \IP.ADDRESS.BOX (LOCF (fetch (IP IPDESTINATIONADDRESS) of IP)) WORDSPERCELL) [LET [(LOCALNETADDRESS (fetch NDBIPNET# of (fetch EPNETWORK of IP] (COND ((MEMBER \IP.ADDRESS.BOX \IP.LOCAL.ADDRESSES) T) ((AND (\IP.BROADCAST.ADDRESS \IP.ADDRESS.BOX) (EQP LOCALNETADDRESS (\IPNETADDRESS \IP.ADDRESS.BOX))) T) ((NOT (\IP.LEGAL.ADDRESS \IP.ADDRESS.BOX)) (* Bogus destination address) NIL) ((EQP 0 (\IPNETADDRESS \IP.ADDRESS.BOX)) (* Source doesn't know its network?) (SELECTQ (INTEGERLENGTH LOCALNETADDRESS) (8 (\PUTBASEBYTE \IP.ADDRESS.BOX 0 LOCALNETADDRESS)) (16 (\PUTBASE \IP.ADDRESS.BOX 0 LOCALNETADDRESS)) (24 [for I from 0 to 2 do (\PUTBASEBYTE \IP.ADDRESS.BOX I (LOGAND 255 (LRSH LOCALNETADDRESS (ITIMES 8 (IDIFFERENCE 2 I]) NIL) (COND ((\IP.BROADCAST.ADDRESS \IP.ADDRESS.BOX) T) ((MEMBER \IP.ADDRESS.BOX \IP.LOCAL.ADDRESSES) T])]) (\IPCHECKSUM [LAMBDA (ETHERPACKET CHECKSUMBASE NBYTES IGNOREDWORD) (* ejs%: "31-Dec-84 13:53") (* * Compute a general checksum for a packet starting at CHECKSUMBASE and  extending NBYTES. If NBYTES is odd, a 0 byte is padded on the end.  The IGNOREDWORD field is the LOCF of the field which will contain the checksum,  and is to be considered 0 for the calculation.) (PROG ((MAXINDEX (SUB1 (FOLDHI NBYTES BYTESPERWORD))) (CHECKSUM 0) (ODDFLG (ODDP NBYTES)) DIFF WORDCONTENTS) (AND IGNOREDWORD (\PUTBASE IGNOREDWORD 0 0)) [for WORD from 0 to MAXINDEX do (SETQ CHECKSUM (COND [(AND ODDFLG (EQ WORD MAXINDEX)) (COND ([ILEQ CHECKSUM (SETQ DIFF (IDIFFERENCE MAX.SMALL.INTEGER (SETQ WORDCONTENTS (LOGAND (\GETBASE CHECKSUMBASE WORD) (MASK.1'S 8 8] (IPLUS CHECKSUM WORDCONTENTS)) (T (IDIFFERENCE CHECKSUM DIFF] (T (COND ([ILEQ CHECKSUM (SETQ DIFF (IDIFFERENCE MAX.SMALL.INTEGER (SETQ WORDCONTENTS (\GETBASE CHECKSUMBASE WORD] (IPLUS CHECKSUM WORDCONTENTS)) (T (IDIFFERENCE CHECKSUM DIFF] (RETURN CHECKSUM]) (\IP.CHECKSUM.OK [LAMBDA (CHECKSUM) (* ejs%: "28-Dec-84 19:40") (OR (EQ CHECKSUM (MASK.1'S 0 16)) (EQ CHECKSUM 0]) (\IP.SET.CHECKSUM [LAMBDA (PACKET CHECKSUMBASE NBYTES CHECKSUMWORD) (* ejs%: " 4-Jun-85 22:47") (PROG ((CHECKSUM (\IPCHECKSUM PACKET CHECKSUMBASE NBYTES CHECKSUMWORD))) (\PUTBASE CHECKSUMWORD 0 (COND ((EQ CHECKSUM (MASK.1'S 0 16)) CHECKSUM) (T (LOGAND (LOGNOT CHECKSUM) (MASK.1'S 0 16]) ) (* ;; "Protocol Distribution") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ IPPROTOCOLTYPES ((\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17))) (DECLARE%: EVAL@COMPILE (RPAQQ \ICMP.PROTOCOL 1) (RPAQQ \TCP.PROTOCOL 6) (RPAQQ \UDP.PROTOCOL 17) (CONSTANTS (\ICMP.PROTOCOL 1) (\TCP.PROTOCOL 6) (\UDP.PROTOCOL 17)) ) (* "END EXPORTED DEFINITIONS") ) (RPAQ? \IP.PROTOCOLS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IP.PROTOCOLS) ) (DEFINEQ (\IP.HAND.TO.PROTOCOL [LAMBDA (IP) (* ejs%: "31-Mar-86 15:39") (PROG ((PROTOCOL (ffetch (IP IPPROTOCOL) of IP)) PROTOCOLCHAIN IPSOCKET) (COND ((NOT (SETQ PROTOCOLCHAIN (\IP.FIND.PROTOCOL PROTOCOL \IP.PROTOCOLS))) (OR (\IP.BROADCAST.ADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP)) (\ICMP.DEST.UNREACHABLE IP \ICMP.PROTOCOL.UNREACHABLE))) ((NOT (SETQ IPSOCKET (\IP.FIND.PROTOCOL.SOCKET IP PROTOCOLCHAIN))) (APPLY* (ffetch (IPSOCKET IPSNOSOCKETFN) of PROTOCOLCHAIN) IP)) (T (APPLY* (ffetch (IPSOCKET IPSINPUTFN) of (COND ((type? IPSOCKET IPSOCKET) IPSOCKET) (T PROTOCOLCHAIN))) IP IPSOCKET]) (\IP.DEFAULT.INPUTFN [LAMBDA (IP IPSOCKET) (* ejs%: " 3-Feb-85 19:19") (COND ((EQ (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) (fetch (IPSOCKET IPSQUEUEALLOC) of IPSOCKET)) (\RELEASE.ETHERPACKET IP)) (T (UNINTERRUPTABLY (\ENQUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET) IP) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) 1) (NOTIFY.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET)))]) (\IP.DEFAULT.NOSOCKETFN [LAMBDA (IP) (* ejs%: " 2-Feb-86 11:38") (COND ([OR (NEQ 0 (fetch (IP IPDESTINATIONHOST) of IP)) (NOT (\IP.BROADCAST.ADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP] (\ICMP.DEST.UNREACHABLE IP \ICMP.PORT.UNREACHABLE)) (T (\RELEASE.ETHERPACKET IP]) (\IP.ADD.PROTOCOL [LAMBDA (PROTOCOL SOCKETCOMPAREFN NOSOCKETFN INPUTFN ICMPFN) (* ; "Edited 25-Aug-88 12:10 by bvm") (* ;;; "Find an existing protocol, or create a new one, and return the socket chain head. If the protocol already exists, the remaining arguments redefine the current slots.") (LET* [(FOUND (find SOCKET in \IP.PROTOCOLS suchthat (EQ (fetch (IPSOCKET PROTOCOL) of SOCKET) PROTOCOL))) (SOCKET (OR FOUND (create IPSOCKET PROTOCOL _ PROTOCOL IPSQUEUE _ NIL IPSQUEUEALLOC _ 0 IPSEVENT _ NIL] (replace (IPSOCKET IPSDESTSOCKETCOMPAREFN) of SOCKET with SOCKETCOMPAREFN) (replace (IPSOCKET IPSINPUTFN) of SOCKET with (OR INPUTFN (FUNCTION \IP.DEFAULT.INPUTFN ))) (replace (IPSOCKET IPSNOSOCKETFN) of SOCKET with (OR NOSOCKETFN (FUNCTION \IP.DEFAULT.NOSOCKETFN))) (replace (IPSOCKET IPSICMPFN) of SOCKET with (OR ICMPFN (FUNCTION \RELEASE.ETHERPACKET)) ) (if (NOT FOUND) then (* ;  "Now that it's all filled in, add it to the protocol set") (push \IP.PROTOCOLS SOCKET)) SOCKET]) (\IP.DELETE.PROTOCOL [LAMBDA (PROTOCOL) (* ejs%: "10-Apr-85 16:24") (LET ((PROTOCOLCHAIN (\IP.FIND.PROTOCOL PROTOCOL))) (COND (PROTOCOLCHAIN (until (NULL (fetch (IPSOCKET IPSLINK) of PROTOCOLCHAIN)) do (\IP.CLOSE.SOCKET (fetch (IPSOCKET IPSOCKET) of (fetch (IPSOCKET IPSLINK) of PROTOCOLCHAIN)) PROTOCOL)) (SETQ \IP.PROTOCOLS (DREMOVE PROTOCOLCHAIN \IP.PROTOCOLS)) T]) (\IP.FIND.PROTOCOL [LAMBDA (PROTOCOL) (* ejs%: "27-Dec-84 11:18") (* * Find the protocol chain for this protocol#) (CAR (SOME \IP.PROTOCOLS (FUNCTION (LAMBDA (IPSOCKET) (EQ (ffetch (IPSOCKET PROTOCOL) of IPSOCKET) PROTOCOL]) (\IP.FIND.PROTOCOL.SOCKET [LAMBDA (IP PROTOCOLCHAIN) (* ; "Edited 26-Aug-88 12:44 by bvm") (* ;; "Find the socket specified by IP packet. PROTOCOLCHAIN is the head of the socket chain for this protocol; if NIL we look it up.") (LET ([SOCKET (OR PROTOCOLCHAIN (\IP.FIND.PROTOCOL (ffetch (IP IPPROTOCOL) of IP] RESULT) (* ;; "Note that we start the comparisons with the dummy head, even though we expect that to fail. This is so that a socketless protocol, such as ICMP can use this dummy head as the sole handler of the protocol.") (AND SOCKET (when (SETQ RESULT (CL:FUNCALL (ffetch (IPSOCKET IPSDESTSOCKETCOMPAREFN) of SOCKET) IP SOCKET)) do (RETURN (COND ((EQ RESULT T) SOCKET) (T (* ; "This is a little strange. Non-T comparison result will be passed as the second arg to the chain head's inputfn when a packet arrives here.") RESULT))) repeatwhile (SETQ SOCKET (ffetch (IPSOCKET IPSLINK ) of SOCKET]) (\IP.FIND.SOCKET [LAMBDA (SOCKET# SOCKETCHAIN) (* ejs%: "27-Dec-84 11:39") (* * Called to find the socket open on the socketchain, or NIL if no such open  socket. Socketchain comes from \IP.FIND.PROTOCOL) (while SOCKETCHAIN until (COND ((EQUAL SOCKET# (ffetch (IPSOCKET IPSOCKET) of SOCKETCHAIN )) SOCKETCHAIN) (T (SETQ SOCKETCHAIN (ffetch (IPSOCKET IPSLINK) of SOCKETCHAIN)) NIL)) finally (RETURN SOCKETCHAIN]) (\IP.OPEN.SOCKET [LAMBDA (PROTOCOL SOCKET NOERRORFLG DESTSOCKETCOMPAREFN NOSOCKETFN INPUTFN ICMPFN) (* ; "Edited 25-Aug-88 12:43 by bvm") (* ;;; "Open a new socket for a protocol. The last 4 fns default to those specified when the protocol was enabled.") (* ;; "Keeping NOSOCKETFN for back compatibility, but it doesn't really make any sense --bvm.") (LET ((MASTERSOC (\IP.FIND.PROTOCOL PROTOCOL)) OLDSOC NEWSOC) (COND [(NOT (type? IPSOCKET MASTERSOC)) (COND ((NOT NOERRORFLG) (ERROR "Attempt to open socket in unknown protocol" PROTOCOL SOCKET] [(if SOCKET then (SETQ OLDSOC (\IP.FIND.SOCKET SOCKET MASTERSOC)) else (* ;  "Pick a random socket that is smallp but not very small, so as to avoid well-known sockets") (SETQ SOCKET (LOGOR (LOGAND (DAYTIME) 65535) 32768)) (while (\IP.FIND.SOCKET SOCKET MASTERSOC) do (SETQ SOCKET (- SOCKET 1))) NIL) (COND (NOERRORFLG OLDSOC) (T (ERROR "Attempt to open an existing socket" OLDSOC] (T [SETQ NEWSOC (create IPSOCKET IPSLINK _ (ffetch (IPSOCKET IPSLINK) of MASTERSOC) IPSOCKET _ SOCKET PROTOCOL _ PROTOCOL IPSDESTSOCKETCOMPAREFN _ (OR DESTSOCKETCOMPAREFN (ffetch (IPSOCKET IPSDESTSOCKETCOMPAREFN ) of MASTERSOC )) IPSNOSOCKETFN _ (OR NOSOCKETFN (ffetch (IPSOCKET IPSNOSOCKETFN ) of MASTERSOC )) IPSINPUTFN _ (OR INPUTFN (ffetch (IPSOCKET IPSINPUTFN) of MASTERSOC)) IPSICMPFN _ (OR ICMPFN (ffetch (IPSOCKET IPSICMPFN) of MASTERSOC] (freplace (IPSOCKET IPSLINK) of MASTERSOC with NEWSOC) NEWSOC]) (\IP.CLOSE.SOCKET [LAMBDA (SOCKET PROTOCOL NOERRORFLG) (* ; "Edited 26-Aug-88 12:33 by bvm") (* ;;; "Close the given socket. Call this only after the higher level protocol has finished doing its closing operations.") (* ;; "For some silly reason, this fn was defined to take not an IPSOCKET object but rather the socket number, or whatever was in the socket slot. For backward compatibility, let's do both (sigh).") (LET ((PREV (\IP.FIND.PROTOCOL PROTOCOL)) NEXT) (COND [(AND PREV (while (SETQ NEXT (ffetch (IPSOCKET IPSLINK) of PREV)) do (if (OR (EQ SOCKET NEXT) (EQ SOCKET (ffetch (IPSOCKET IPSOCKET) of NEXT)) ) then (* ; "Found it, so splice it out") (freplace (IPSOCKET IPSLINK) of PREV with (ffetch (IPSOCKET IPSLINK) of NEXT)) (freplace (IPSOCKET IPSLINK) of NEXT with NIL) (RETURN T)) (SETQ PREV NEXT] ((NOT NOERRORFLG) (ERROR "Socket not found" SOCKET]) ) (* ;; "Fragmentation Handling") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (RECORD AssemblyRecord (Packet FirstHole Fragments Timeout) Packet _ (\ALLOCATE.ETHERPACKET) FirstHole _ 0) (RECORD FragmentRecord (Start Length LastFragment)) (RECORD FragmentID (AssemblyRecord SourceAddress ID Protocol . DestinationAddress)) ) (* "END EXPORTED DEFINITIONS") ) (RPAQ? \IP.FRAGMENT.LIST ) (RPAQ? \IP.FRAGMENT.LOCK (CREATE.MONITORLOCK "IP Fragment Processing Lock")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IP.FRAGMENT.LIST \IP.FRAGMENT.LOCK) ) (DECLARE%: EVAL@COMPILE (RPAQQ \IP.FRAGMENTATION.UNIT 8) (CONSTANTS (\IP.FRAGMENTATION.UNIT 8)) ) (DEFINEQ (\HANDLE.RAW.IP.FRAGMENT [LAMBDA (IP) (* ejs%: " 1-Feb-86 14:24") (* * Add the next fragment to a packet under assembly.  If this fragment completes a packet, return the completed packet to be  processed by higher-level protocol routines.) (WITH.MONITOR \IP.FRAGMENT.LOCK (LET ((AssemblyRecord (\IP.FIND.MATCHING.FRAGMENTS IP))) (COND (AssemblyRecord (\IP.ADD.FRAGMENT AssemblyRecord IP)) (T (\IP.NEW.FRAGMENT.LST IP) NIL))))]) (\IP.NEW.FRAGMENT.LST [LAMBDA (IP) (* ejs%: " 3-Feb-86 10:57") (* * Add a new fragment to the fragment list) (PROG ((Source (ffetch (IP IPSOURCEADDRESS) of IP)) (Dest (ffetch (IP IPDESTINATIONADDRESS) of IP)) (Protocol (ffetch (IP IPPROTOCOL) of IP)) (ID (ffetch (IP IPID) of IP)) NewFragmentID FragmentRecord AssemblyPacket AssemblyRecord) [SETQ NewFragmentID (create FragmentID SourceAddress _ Source ID _ ID Protocol _ Protocol DestinationAddress _ Dest AssemblyRecord _ (SETQ AssemblyRecord (create AssemblyRecord Timeout _ (SETUPTIMER (ITIMES 1000 (ffetch (IP IPTIMETOLIVE) of IP))) Fragments _ (LIST (SETQ FragmentRecord (create FragmentRecord Start _ (UNFOLD (ffetch (IP IPFRAGMENTOFFSET ) of IP) \IP.FRAGMENTATION.UNIT) Length _ (IDIFFERENCE (ffetch (IP IPTOTALLENGTH) of IP) (UNFOLD (ffetch (IP IPHEADERLENGTH ) of IP) BYTESPERCELL] (COND ((EQ IPTRACEFLG T) (\IP.PRINT.FRAGMENT NewFragmentID IP IPTRACEFILE))) (SETQ AssemblyPacket (fetch (AssemblyRecord Packet) of AssemblyRecord)) (\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER AssemblyPacket IP) (* * Copy the packet data to the packet) (\BLT (\ADDBASE (\IPDATABASE AssemblyPacket) (FOLDLO (fetch (FragmentRecord Start) of FragmentRecord) BYTESPERWORD)) (\IPDATABASE IP) (FOLDLO (fetch (FragmentRecord Length) of FragmentRecord) BYTESPERWORD)) (\RELEASE.ETHERPACKET IP) (push \IP.FRAGMENT.LIST NewFragmentID]) (\IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER [LAMBDA (Packet Fragment) (* ejs%: " 1-Feb-86 14:14") (* * Copy information from the header of the fragment packet into the header of  the reassembled packet) (\MOVEBYTES (fetch (IP IPBASE) of Fragment) 0 (fetch (IP IPBASE) of Packet) 0 (UNFOLD (fetch (IP IPHEADERLENGTH) of Fragment) BYTESPERCELL]) (\IP.ADD.FRAGMENT [LAMBDA (FragmentID NewIP) (* ejs%: " 1-Feb-86 18:41") (* * Called to add a fragment to a fragment list.  The fragment is added in order. If the fragment completes a fragmented IP  packet, a new packet is assembled and returned, else NIL is returned) (LET* ((AssemblyRecord (fetch (FragmentID AssemblyRecord) of FragmentID)) [NewFrag (create FragmentRecord Start _ (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of NewIP) \IP.FRAGMENTATION.UNIT) Length _ (IDIFFERENCE (ffetch (IP IPTOTALLENGTH) of NewIP) (UNFOLD (ffetch (IP IPHEADERLENGTH) of NewIP) BYTESPERCELL)) LastFragment _ (NOT (fetch (IP IPMOREFRAGMENTS) of NewIP] (Fragments (fetch (AssemblyRecord Fragments) of AssemblyRecord)) Status NextHole AssemblyPacket) (COND ((EQ IPTRACEFLG T) (\IP.PRINT.FRAGMENT FragmentID NewIP IPTRACEFILE))) (SETQ AssemblyPacket (fetch (AssemblyRecord Packet) of AssemblyRecord)) (replace (AssemblyRecord Timeout) of AssemblyRecord with (SETUPTIMER (ITIMES 1000 (ffetch (IP IPTIMETOLIVE) of NewIP)) (fetch (AssemblyRecord Timeout) of AssemblyRecord))) [SETQ Status (COND ((ILESSP (fetch (FragmentRecord Start) of NewFrag) (fetch (FragmentRecord Start) of (CAR Fragments))) (* Earlier than the earliest  existing fragment) (SETQ Fragments (push (fetch (AssemblyRecord Fragments) of AssemblyRecord ) NewFrag)) 'INSERTED.FRAGMENT) ((EQ (fetch (FragmentRecord Start) of NewFrag) (fetch (FragmentRecord Start) of (CAR Fragments))) (* Duplicate of earliest fragment) 'DUPLICATE) (T (* Have to search) (for OldFragTail on Fragments while (CDR OldFragTail) thereis (COND ((EQ (fetch (FragmentRecord Start) of NewFrag) (fetch (FragmentRecord Start) of (CADR OldFragTail ))) (* Duplicate) (SETQ Status 'DUPLICATE) T) ((ILESSP (fetch (FragmentRecord Start) of NewFrag) (fetch (FragmentRecord Start) of (CADR OldFragTail))) (* Found the hole to insert) T)) finally (COND (Status (* Duplicate) (RETURN Status)) ((CDR OldFragTail) (* Inserted in middle of list) (RPLACD OldFragTail (CONS NewFrag (CDR OldFragTail) )) (RETURN 'INSERTED.FRAGMENT)) (T (* Inserted at end of list) (NCONC1 OldFragTail NewFrag) (RETURN 'INSERTED.FRAGMENT] (PROG1 (SELECTQ Status (DUPLICATE NIL) (INSERTED.FRAGMENT (* Copy bytes into assembly) (\MOVEBYTES (\IPDATABASE NewIP) 0 (\IPDATABASE AssemblyPacket) (fetch (FragmentRecord Start) of NewFrag) (fetch (FragmentRecord Length) of NewFrag)) (add (ffetch (IP IPTOTALLENGTH) of AssemblyPacket) (fetch (FragmentRecord Length) of NewFrag)) (* Update Assembly record) [COND ((ILESSP (fetch (FragmentRecord Start) of NewFrag) (fetch (AssemblyRecord FirstHole) of AssemblyRecord)) (ERROR "Error in IP fragment reassembly!" NewFrag)) (T (COND ((EQ [bind End Status for FragTail on Fragments while (CDR FragTail) thereis [COND ((NEQ [SETQ End (IPLUS (fetch ( FragmentRecord Start) of (CAR FragTail)) (fetch ( FragmentRecord Length) of (CAR FragTail] (fetch (FragmentRecord Start) of (CADR FragTail))) (replace (AssemblyRecord FirstHole) of AssemblyRecord with End) (SETQ Status 'FOUND.HOLE] finally (RETURN (COND [(NULL Status) (COND ((fetch (FragmentRecord LastFragment) of (CAR FragTail)) (COND ((EQ IPTRACEFLG T) (printout IPTRACEFILE T "Complete IP Fragment received" T))) 'COMPLETE.PACKET) (T (replace (AssemblyRecord FirstHole) of AssemblyRecord with End) 'INCOMPLETE.BUT.NO.HOLES] (T Status] 'COMPLETE.PACKET) (\IP.DELETE.FRAGMENT FragmentID) AssemblyPacket]) NIL) (\RELEASE.ETHERPACKET NewIP]) (\IP.FIND.MATCHING.FRAGMENTS [LAMBDA (IP) (* ejs%: " 1-Feb-86 14:41") (* * Find the list of fragments matching this IP packet, or NIL if none exists) (DECLARE (GLOBALVARS \IP.FRAGMENT.LIST)) (LET* ((Source (ffetch (IP IPSOURCEADDRESS) of IP)) (Dest (ffetch (IP IPDESTINATIONADDRESS) of IP)) (Protocol (ffetch (IP IPPROTOCOL) of IP)) (ID (ffetch (IP IPID) of IP)) (FragmentEntry)) (for FragmentID in \IP.FRAGMENT.LIST thereis (AND (EQP (fetch (FragmentID SourceAddress ) of FragmentID) Source) (EQ (fetch (FragmentID ID) of FragmentID) ID) (EQ (fetch (FragmentID Protocol) of FragmentID) Protocol) (EQP (fetch (FragmentID DestinationAddress ) of FragmentID) Dest]) (\IP.FRAGMENTED.PACKET [LAMBDA (IP) (* ejs%: " 1-Feb-86 16:50") (* * Return T if IP packet is a fragment) (OR (ffetch (IP IPMOREFRAGMENTS) of IP) (NEQ 0 (ffetch (IP IPFRAGMENTOFFSET) of IP]) (\IP.CHECK.REASSEMBLY.TIMEOUTS [LAMBDA NIL (* ejs%: " 3-Feb-86 11:00") (* * Kill any fragments in the process of reassembly if their timeout has  expired. Report timeout via ICMP) (WITH.MONITOR \IP.FRAGMENT.LOCK (bind AssemblyRecord for Fragment in \IP.FRAGMENT.LIST when [TIMEREXPIRED? (fetch (AssemblyRecord Timeout) of (SETQ AssemblyRecord (fetch (FragmentID AssemblyRecord ) of Fragment] do (COND ((EQ IPTRACEFLG T) (printout IPTRACEFILE T "IP Fragment timeout expired" T))) (\ICMP.TIME.EXCEEDED (fetch (AssemblyRecord Packet) of AssemblyRecord) \ICMP.FRAGMENT.TIME.EXCEEDED) (\IP.DELETE.FRAGMENT Fragment T)))]) (\IP.DELETE.FRAGMENT [LAMBDA (FragmentID FreePacketToo) (* ejs%: " 3-Feb-86 10:59") (* * Delete FragmentID from the list of Fragment ID's) (PROG [(IP (fetch (AssemblyRecord Packet) of (fetch (FragmentID AssemblyRecord) of FragmentID] (SETQ \IP.FRAGMENT.LIST (DREMOVE FragmentID \IP.FRAGMENT.LIST)) (AND FreePacketToo (\RELEASE.ETHERPACKET IP]) (\IP.PRINT.FRAGMENT [LAMBDA (FragmentID IPFragment File) (* ejs%: " 2-Feb-86 10:39") (* * Print information about this fragement to File) (printout File T "Received IP Fragment:" T "Source " (\IP.ADDRESS.TO.STRING (fetch (FragmentID SourceAddress) of FragmentID)) " Dest " (\IP.ADDRESS.TO.STRING (fetch (FragmentID DestinationAddress) of FragmentID)) T "Protocol ") (PRINTCONSTANT (fetch (FragmentID Protocol) of FragmentID) IPPROTOCOLTYPES File) (printout File " ID " (fetch (FragmentID ID) of FragmentID) T "Covering [" (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of IPFragment) \IP.FRAGMENTATION.UNIT) ".." (IPLUS (UNFOLD (ffetch (IP IPFRAGMENTOFFSET) of IPFragment) \IP.FRAGMENTATION.UNIT) (IDIFFERENCE (ffetch (IP IPTOTALLENGTH) of IPFragment) (UNFOLD (ffetch (IP IPHEADERLENGTH) of IPFragment) BYTESPERCELL))) "]" T) (bind C for I from 0 to [SUB1 (IMIN 40 (IDIFFERENCE (ffetch (IP IPTOTALLENGTH ) of IPFragment) (UNFOLD (ffetch (IP IPHEADERLENGTH ) of IPFragment) BYTESPERCELL] do (SETQ C (\GETBASEBYTE (\IPDATABASE IPFragment) I)) (COND ((AND (IGEQ C (CHARCODE SPACE)) (ILEQ C 126)) (BOUT File C)) (T (printout File "[" C "]"]) ) (* ;; "Option Processing") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ IPOPTIONTYPES ((IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4) (IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9))) (DECLARE%: EVAL@COMPILE (RPAQQ IPOPT.END 0) (RPAQQ IPOPT.NOP 1) (RPAQQ IPOPT.SECURITY 2) (RPAQQ IPOPT.LSRR 3) (RPAQQ IPOPT.TIMESTAMP 4) (RPAQQ IPOPT.RECRT 7) (RPAQQ IPOPT.STREAMID 8) (RPAQQ IPOPT.SSSR 9) (CONSTANTS (IPOPT.END 0) (IPOPT.NOP 1) (IPOPT.SECURITY 2) (IPOPT.LSRR 3) (IPOPT.TIMESTAMP 4) (IPOPT.RECRT 7) (IPOPT.STREAMID 8) (IPOPT.SSSR 9)) ) (DECLARE%: EVAL@COMPILE (RPAQ IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0)) (CONSTANTS (IP.OPTION.NUMBER.BYTESPEC (BYTE 5 0))) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (\IP.PROCESS.OPTIONS [LAMBDA (IP) (* ; "Edited 20-Jan-89 12:24 by bvm") (* ;;; "Process option fields in IP header. Return T if OK, else handle internally needed actions like redirection or reporting of parameter problems") (bind (OPTIONSSTART _ (LOCF (ffetch (IP IPOPTIONSSTART) of IP))) (INDEX _ 0) (RESULT _ T) REROUTING OPTION until (OR (>= INDEX (- (UNFOLD (fetch (IP IPHEADERLENGTH) of IP) BYTESPERCELL) \IPOVLEN)) (EQ (SETQ OPTION (LDB (BYTE 5 0) (\GETBASEBYTE OPTIONSSTART INDEX))) IPOPT.END)) do (if (EQ OPTION IPOPT.NOP) then (* ;  "This is the only one-byte option we know of other than IPOPT.END") (add INDEX 1) else (SELECTC OPTION ((LIST IPOPT.LSRR IPOPT.SSSR) (COND (REROUTING (SETQ RESULT INDEX)) ((NEQ (SETQ RESULT (\IP.OPTION.STRICT.SOURCE.ROUTE IP INDEX) ) 'REROUTE) (SETQ REROUTING T)))) (IPOPT.RECRT (SETQ RESULT (\IP.OPTION.RECORD.ROUTE IP INDEX))) (IPOPT.TIMESTAMP (\IP.OPTION.TIMESTAMP IP INDEX)) (IPOPT.SECURITY) (IPOPT.STREAMID) (PROGN (* ;  "Unknown option code-- we can't continue, since it could be some unknown 1-byte option") (RETURN NIL))) (COND ((NUMBERP RESULT) (* ;;  "If the result is a number then there was a parameter problem. We could process them here.") (RETURN NIL))) (add INDEX (\GETBASEBYTE OPTIONSSTART (ADD1 INDEX))) (* ; "Increment by the length field") ) finally (RETURN RESULT]) (\IP.OPTION.RECORD.ROUTE [LAMBDA (IP INDEX) (* ; "Edited 2-Aug-88 14:57 by atm") (LET* [(OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP))) (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1))) (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2] (* ;; "From RFC 791: If the route data area is already full just forward. If there is room , but not enough for a full address to be inserted, signal an ICMP error. Otherwise insert the address into the datagram and update PTR.") (COND ((IGREATERP PTR LENGTH) NIL) ((ILESSP (IDIFFERENCE LENGTH PTR) 3) INDEX) (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR) (CAR \IP.LOCAL.ADDRESSES)) (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2) (LDB (BYTE 8 0) (IPLUS PTR 4))) T]) (\IP.OPTION.STRICT.SOURCE.ROUTE [LAMBDA (IP INDEX) (* ; "Edited 8-Aug-88 12:05 by atm") (LET* ((OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP))) (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1))) (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2))) (DESTINATIONADDRESSLOC (LOCF (ffetch (IP IPDESTINATIONADDRESS) of IP))) (DESTINATIONADDRESS (\GETBASEFIXP DESTINATIONADDRESSLOC 0))) (* ;; "From RFC 791: If the address in the destination field has been reached and PTR is not greater than LENGTH, the next address in the source route replaces the address in the destination address field, and the recorded route address replaces the source address just used, and PTR is increased by four.") (COND ((IGREATERP PTR LENGTH) NIL) ((ILESSP (IDIFFERENCE LENGTH PTR) 3) INDEX) (T (COND ((MEMBER DESTINATIONADDRESS \IP.LOCAL.ADDRESSES) (\PUTBASEFIXP OPTIONSSTART (IPLUS PTR INDEX 4) DESTINATIONADDRESS) (\PUTBASEFIXP DESTINATIONADDRESSLOC 0 (\GETBASEFIXP OPTIONSSTART (IPLUS PTR INDEX ))) (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2) (LDB (BYTE 8 0) (IPLUS PTR 4))) 'REROUTE) (T]) (\IP.OPTION.TIMESTAMP [LAMBDA (IP INDEX) (* ; "Edited 8-Aug-88 12:08 by atm") (LET* ((OPTIONSSTART (LOCF (ffetch (IP IPOPTIONSSTART) of IP))) (LENGTH (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 1))) (PTR (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 2))) (OFLW/FLG (\GETBASEBYTE OPTIONSSTART (IPLUS INDEX 3))) FLAG) (* ;; "From RFC 791: If the timestamp area is already full then increment the overflow flag and forward the datagram without inserting the timestamp. If there is room but not enough for a full timestamp to be inserted then signal an ICMP error. Otherwise insert the timestamp or the timestamp and the internet address depending on the flag; 0 indicates timestamp only, 1 indicates timestamp and address, 3 indicates that the address is prespecified.") (COND ((IGREATERP PTR LENGTH) (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 3) (IPLUS OFLW/FLG (LSH 1 4))) T) (T (SELECTQ (LOGAND 15 OFLW/FLG) (0 (COND ((ILESSP (IDIFFERENCE LENGTH PTR) 3) INDEX) (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR) (\CLOCK0 (\CREATECELL \FIXP))) (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2) (LDB (BYTE 8 0) (IPLUS PTR 4))) T))) (1 (COND ((IGREATERP 8 (IDIFFERENCE LENGTH (SUB1 PTR))) INDEX) (T (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR) (CAR \IP.LOCAL.ADDRESSES)) (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR 4) (\CLOCK0 (\CREATECELL \FIXP))) (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2) (LDB (BYTE 8 0) (IPLUS PTR 8))) T))) (3 [COND ((IGREATERP 8 (IDIFFERENCE LENGTH (SUB1 PTR))) INDEX) (T (COND ((MEMBER (\GETBASEFIXP OPTIONSSTART (IPLUS INDEX PTR)) \IP.LOCAL.ADDRESSES) (\PUTBASEFIXP OPTIONSSTART (IPLUS INDEX PTR 4) (\CLOCK0 (\CREATECELL \FIXP))) (\PUTBASEBYTE OPTIONSSTART (IPLUS INDEX 2) (LDB (BYTE 8 0) (IPLUS PTR 8))) T) (T NIL]) INDEX]) ) (* ;; "Packet Transmission and routing") (RPAQ? \IP.ROUTING.TABLE (CONS)) (RPAQ? \IP.DEFAULT.GATEWAY ) (RPAQ? \IP.LOCAL.NETWORKS ) (RPAQ? \IP.GATEWAY.FORWARDING.FUNCTIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IP.ROUTING.TABLE \IP.DEFAULT.GATEWAY \IP.LOCAL.NETWORKS \IP.GATEWAY.FORWARDING.FUNCTIONS ) ) (DEFINEQ (\IP.SETUPIP [LAMBDA (IP DESTHOST ID SOCKET REQUEUE) (* ejs%: "31-Mar-86 15:01") (* * Initialize IP header of packet.) (OR IP (SETQ IP (\ALLOCATE.ETHERPACKET))) (replace (IP IPVERSION) of IP with \IP.PROTOCOLVERSION) (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI \IPOVLEN BYTESPERCELL)) (freplace (IP IPTOTALLENGTH) of IP with \IPOVLEN) [freplace (IP IPID) of IP with (OR (SMALLP ID) (LOGAND (DAYTIME) (MASK.1'S 0 16] (freplace (IP IPMOREFRAGMENTS) of IP with NIL) (freplace (IP IPFRAGMENTOFFSET) of IP with 0) (freplace (IP IPTIMETOLIVE) of IP with \IP.DEFAULT.TIME.TO.LIVE) (freplace (IP IPPROTOCOL) of IP with (fetch (IPSOCKET PROTOCOL) of SOCKET)) (freplace (IP IPSOURCEADDRESS) of IP with (CAR \IP.LOCAL.ADDRESSES)) (freplace (IP IPDESTINATIONADDRESS) of IP with DESTHOST) (freplace EPREQUEUE of IP with REQUEUE) IP]) (\IP.TRANSMIT [LAMBDA (IP ROUTINGREADONLY) (* ejs%: "27-Jan-86 15:59") (* * Sends an IP packet, after first computing the IP header checksum) (PROG (NDB) (SETQ IP (\DTEST IP 'ETHERPACKET)) (until \IP.READY do (AWAIT.EVENT \IP.READY.EVENT)) (\RCLK (LOCF (ffetch EPTIMESTAMP of IP))) (replace EPTYPE of IP with \EPT.IP) (RETURN (COND ((ffetch EPTRANSMITTING of IP) (AND IPTRACEFLG (printout IPTRACEFILE "[Put fails--packet already being transmitted]")) 'AlreadyQueued) ((NOT (SETQ NDB (\IP.ROUTE.PACKET IP ROUTINGREADONLY))) (AND IPTRACEFLG (PRINTPACKET IP 'PUT IPTRACEFILE "[Put fails--no routing]")) (\REQUEUE.ETHERPACKET IP) 'NoRouting) (T (\IP.SET.CHECKSUM IP (ffetch (IP IPBASE) of IP) (LLSH (ffetch (IP IPHEADERLENGTH) of IP) 2) (LOCF (ffetch (IP IPHEADERCHECKSUM) of IP))) [COND (IPTRACEFLG (COND ((EQ IPTRACEFLG T) (PRINTPACKET IP 'PUT IPTRACEFILE)) (T (PRIN1 "!" IPTRACEFILE] (TRANSMIT.ETHERPACKET NDB IP) NIL]) (\IP.ROUTE.PACKET [LAMBDA (IP READONLY) (* ; "Edited 19-Jan-89 18:00 by bvm") (* ;; "Encapsulates XIP, choosing the right network and immediate destination host. Returns an NDB for the transmission. Unless READONLY is true, defaults source and destination nets if needed") (DECLARE (GLOBALVARS \10MBLOCALNDB \3MBLOCALNDB \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY)) (PROG ((DESTADDRESS (fetch (IP IPDESTINATIONADDRESS) of IP)) DESTNET SUBNETMASK SOURCEHOSTADDRESS SUBNETINUSE PDH ROUTE NDB EPTYPE BROADCASTP) (SETQ DESTNET (\IPNETADDRESS DESTADDRESS)) (* ;; "Try to resolve a destination network of 0.0 If we have two attached networks, fail.") [COND ((AND (EQ 0 DESTADDRESS) \10MBLOCALNDB \3MBLOCALNDB) (RETURN)) ((EQ 0 DESTADDRESS) '[SETQ DESTADDRESS (\IP.MAKE.BROADCAST.ADDRESS (fetch NDBIPHOST# of (OR \10MBLOCALNDB \3MBLOCALNDB] (SETQ DESTADDRESS -1) (SETQ BROADCASTP T) '(SETQ DESTNET (\IPNETADDRESS DESTADDRESS)) (SETQ DESTNET (CAAR \IP.LOCAL.NETWORKS] (* ;; "First see if the destination network is one of our local networks") [COND [(AND (SETQ NDB (CDR (SASSOC DESTNET \IP.LOCAL.NETWORKS))) (SETQ SUBNETMASK (CDR (SASSOC (SETQ SOURCEHOSTADDRESS (fetch (NDB NDBIPHOST#) of NDB)) \IP.SUBNET.MASKS))) (OR (AND (\IP.BROADCAST.ADDRESS DESTADDRESS) (SETQ BROADCASTP T)) (EQP (LOGAND SOURCEHOSTADDRESS SUBNETMASK) (LOGAND DESTADDRESS SUBNETMASK)) (PROGN (SETQ SUBNETINUSE T) NIL))) (* ;; "A local net. Try to find the Ethernet address of the host") (COND [(SETQ PDH (SELECTQ (fetch (NDB NETTYPE) of NDB) (10 (SETQ EPTYPE \EPT.IP) (COND (BROADCASTP BROADCASTNSHOSTNUMBER) (T (\AR.TRANSLATE.TO.10MB DESTADDRESS)))) (3 (SETQ EPTYPE \EET.IP) (\AR.TRANSLATE.TO.3MB DESTADDRESS)) (SHOULDNT] (T (* ; "Nope") (RETURN] (T (* ;; "The host is not on a local net. See if we have a route to that host, or use the default route if necessary") (COND [(SETQ ROUTE (OR [COND (SUBNETINUSE (CDR (SASSOC (LOGAND DESTADDRESS SUBNETMASK) \IP.ROUTING.TABLE))) (T (CDR (SASSOC DESTNET \IP.ROUTING.TABLE] \IP.DEFAULT.GATEWAY)) (* ;; "We've got the IP address of the gateway") (COND [(SETQ NDB (CDR (SASSOC (\IPNETADDRESS ROUTE) \IP.LOCAL.NETWORKS))) (* ;; "We know what network it's on") (COND [(SETQ PDH (SELECTQ (fetch (NDB NETTYPE) of NDB) (10 (SETQ EPTYPE \EPT.IP) (\AR.TRANSLATE.TO.10MB ROUTE)) (3 (SETQ EPTYPE \EET.IP) (\AR.TRANSLATE.TO.3MB ROUTE)) (SHOULDNT] (T (RETURN] (T (ERROR "IP routing table contains non-local gateway address for network" DESTNET] (T (RETURN] (freplace EPNETWORK of IP with NDB) (ENCAPSULATE.ETHERPACKET NDB IP PDH (ffetch (IP IPTOTALLENGTH) of IP) EPTYPE) (replace EPTYPE of IP with EPTYPE) [COND ((NOT READONLY) (COND ((EQ 0 (fetch (IP IPDESTINATIONADDRESS) of IP)) (freplace (IP IPDESTINATIONADDRESS) of IP with DESTADDRESS))) (freplace (IP IPSOURCEADDRESS) of IP with (fetch NDBIPHOST# of NDB] (RETURN NDB]) ) (DEFINEQ (IP.GET [LAMBDA (IPSOCKET WAIT) (* ejs%: "31-Mar-86 14:30") (* * Returns the next IP packet on the queue, or NIL if none exist and WAIT is  NIL. If WAIT is T, this function waits forever.  If WAIT is an integer, it is interpreted as the number of milliseconds to wait  before returning NIL or a packet which arrives during that time.  This function therefore is like GETXIP and GETPUP) (PROG ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) IP TIMER) LP (UNINTERRUPTABLY (COND ((SETQ IP (\DEQUEUE QUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1)))) [COND ((NULL IP) (COND (WAIT (COND ((EQ WAIT T)) [TIMER (COND ((TIMEREXPIRED? TIMER) (RETURN] (T (OR (FIXP WAIT) (LISPERROR "NON-NUMERIC ARG" WAIT)) (SETQ TIMER (SETUPTIMER WAIT)) T)) (AWAIT.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET) TIMER T) (GO LP)) (T (BLOCK] (RETURN IP]) (IP.SEND [LAMBDA (IP) (* ejs%: "31-Mar-86 15:07") (\IP.TRANSMIT IP]) (IP.PACKET.WATCHER [LAMBDA (IPSOCKET PACKET.FUNCTION) (* ejs%: "31-Mar-86 15:50") (* * Infinite loop which waits for packet on IPSOCKET, and calls  PACKET.FUNCTION whenever one arrives) (COND ((NOT (type? IPSOCKET IPSOCKET)) (ERROR "ARG NOT IPSOCKET" IPSOCKET)) ((NOT (FNTYP PACKET.FUNCTION)) (ERROR "UNDEFINED FUNCTION" PACKET.FUNCTION)) (T (while T do (APPLY* PACKET.FUNCTION (IP.GET IPSOCKET T) IPSOCKET]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS IP.SEND MACRO (LAMBDA (IP) (* ejs%: "31-Mar-86 15:07") (\IP.TRANSMIT IP] ) (* ;; "Client functions for building packets") (DEFINEQ (\IP.APPEND.BYTE [LAMBDA (IP BYTE INHEADER) (* ejs%: "28-Dec-84 08:23") (* * Append a byte to an IP packet. If INHEADER is not NIL, we adjust the  header length field as well.) (PROG (NEWLENGTH) (\PUTBASEBYTE (fetch (IP IPBASE) of IP) (fetch (IP IPTOTALLENGTH) of IP) BYTE) (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP) 1)) [COND (INHEADER (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI NEWLENGTH 4] (RETURN NEWLENGTH]) (\IP.APPEND.CELL [LAMBDA (IP CELL INHEADER) (* ejs%: "28-Dec-84 08:33") (* * Append a cell to an IP packet. If INHEADER is not NIL, we adjust the  header length field as well.) (PROG (NEWLENGTH (OFFSET (fetch (IP IPTOTALLENGTH) of IP))) [COND ((EVENP OFFSET) (\PUTBASEFIXP (fetch (IP IPBASE) of IP) (FOLDLO OFFSET 2) CELL)) (T (\PUTBASEBYTE (fetch (IP IPBASE) of IP) OFFSET (LDB (BYTE 8 24) CELL)) (\PUTBASEBYTE (fetch (IP IPBASE) of IP) (\ADDBASE OFFSET 1) (LDB (BYTE 8 16) CELL)) (\PUTBASEBYTE (fetch (IP IPBASE) of IP) (\ADDBASE OFFSET 2) (LDB (BYTE 8 8) CELL)) (\PUTBASEBYTE (fetch (IP IPBASE) of IP) (\ADDBASE OFFSET 3) (LDB (BYTE 8 0) CELL] (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP) 4)) (COND (INHEADER (add (ffetch (IP IPHEADERLENGTH) of IP) 1))) (RETURN NEWLENGTH]) (\IP.APPEND.STRING [LAMBDA (IP STRING) (* ejs%: " 9-Feb-85 19:44") (PROG ((LENGTH (fetch (STRINGP LENGTH) of STRING))) (\MOVEBYTES (fetch (STRINGP BASE) of STRING) (fetch (STRINGP OFFST) of STRING) (fetch (IP IPBASE) of IP) (fetch (IP IPTOTALLENGTH) of IP) LENGTH) (RETURN (add (ffetch (IP IPTOTALLENGTH) of IP) LENGTH]) (\IP.APPEND.WORD [LAMBDA (IP WORD INHEADER) (* ejs%: "28-Dec-84 08:28") (* * Append a word to an IP packet. If INHEADER is not NIL, we adjust the  header length field as well.) (PROG (NEWLENGTH (OFFSET (fetch (IP IPTOTALLENGTH) of IP))) [COND ((EVENP OFFSET) (\PUTBASE (fetch (IP IPBASE) of IP) (FOLDLO OFFSET 2) WORD)) (T (\PUTBASEBYTE (fetch (IP IPBASE) of IP) OFFSET (LDB (BYTE 8 8) WORD)) (\PUTBASEBYTE (fetch (IP IPBASE) of IP) (\ADDBASE OFFSET 1) (LDB (BYTE 8 0) WORD] (SETQ NEWLENGTH (add (ffetch (IP IPTOTALLENGTH) of IP) 2)) [COND (INHEADER (freplace (IP IPHEADERLENGTH) of IP with (FOLDHI NEWLENGTH 4] (RETURN NEWLENGTH]) (\IP.GET.BYTE [LAMBDA (IP BYTE INHEADER) (* ejs%: "30-Mar-86 14:49") (* * Retrieve a byte from an IP packet.  If INHEADER is T, BYTE is an offset from the start of the packet, else it's an  offset from the start of the IP data section) (\GETBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE]) (\IP.GET.CELL [LAMBDA (IP CELL INHEADER) (* ejs%: "30-Mar-86 15:07") (* * Retrieve a cell from an IP packet.  If INHEADER is not NIL, the cell is written to the header portion of the IP  packet, else it's written to the data portion.  CELL is the offset, in 16-bit units) (\GETBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL]) (\IP.GET.STRING [LAMBDA (IP BYTEOFFSET NCHARS INHEADER) (* ejs%: "30-Mar-86 15:13") (* * Retrieve a string from an IP packet.  If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else  it's an offset from the start of the IP data section) (\GETBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET NCHARS]) (\IP.GET.WORD [LAMBDA (IP WORD INHEADER) (* ejs%: "30-Mar-86 14:51") (* * Retrieve a word from an IP packet.  If INHEADER is T, WORD is an offset from the start of the packet, else it's an  offset from the start of the IP data section) (\GETBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD]) (\IP.PUT.BYTE [LAMBDA (IP BYTE VALUE INHEADER) (* ejs%: "30-Mar-86 14:52") (* * Store a byte in an IP packet. If INHEADER is T, BYTE is an offset from the  start of the packet, else it's an offset from the start of the IP data section) (\PUTBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE VALUE]) (\IP.PUT.CELL [LAMBDA (IP CELL VALUE INHEADER) (* ejs%: "30-Mar-86 15:06") (* * Store a cell in an IP packet. If INHEADER is not NIL, the cell is written  to the header portion of the IP packet, else it's written to the data portion.  CELL is the offset, in 16-bit units) (\PUTBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL VALUE]) (\IP.PUT.STRING [LAMBDA (IP BYTEOFFSET STRING INHEADER) (* ejs%: "30-Mar-86 15:13") (* * Store a string ib an IP packet. If INHEADER is T, BYTEOFFSET is an offset  from the start of the packet, else it's an offset from the start of the IP data  section) (\PUTBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET STRING]) (\IP.PUT.WORD [LAMBDA (IP WORD VALUE INHEADER) (* ejs%: "30-Mar-86 14:50") (* * Store a word in an IP packet. If INHEADER is T, WORD is an offset from the  start of the packet, else it's an offset from the start of the IP data section) (\PUTBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD VALUE]) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \IP.GET.BYTE DMACRO (LAMBDA (IP BYTE INHEADER) (* ejs%: "30-Mar-86 14:49") (* * Retrieve a byte from an IP packet.  If INHEADER is T, BYTE is an offset from the start of the packet, else it's an  offset from the start of the IP data section) (\GETBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE] [PUTPROPS \IP.GET.CELL DMACRO (LAMBDA (IP CELL INHEADER) (* ejs%: "30-Mar-86 15:07") (* * Retrieve a cell from an IP packet.  If INHEADER is not NIL, the cell is written to the header portion of the IP  packet, else it's written to the data portion.  CELL is the offset, in 16-bit units) (\GETBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL] [PUTPROPS \IP.GET.STRING DMACRO (LAMBDA (IP BYTEOFFSET NCHARS INHEADER) (* ejs%: "30-Mar-86 15:13") (* * Retrieve a string from an IP packet.  If INHEADER is T, BYTEOFFSET is an offset from the start of the packet, else  it's an offset from the start of the IP data section) (\GETBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET NCHARS] [PUTPROPS \IP.GET.WORD DMACRO (LAMBDA (IP WORD INHEADER) (* ejs%: "30-Mar-86 14:51") (* * Retrieve a word from an IP packet.  If INHEADER is T, WORD is an offset from the start of the packet, else it's an  offset from the start of the IP data section) (\GETBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD] [PUTPROPS \IP.PUT.BYTE DMACRO (LAMBDA (IP BYTE VALUE INHEADER) (* ejs%: "30-Mar-86 14:52") (* * Store a byte in an IP packet. If INHEADER is T, BYTE is an offset from the  start of the packet, else it's an offset from the start of the IP data section) (\PUTBASEBYTE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTE VALUE] [PUTPROPS \IP.PUT.CELL DMACRO (LAMBDA (IP CELL VALUE INHEADER) (* ejs%: "30-Mar-86 15:06") (* * Store a cell in an IP packet. If INHEADER is not NIL, the cell is written  to the header portion of the IP packet, else it's written to the data portion.  CELL is the offset, in 16-bit units) (\PUTBASEFIXP (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) CELL VALUE] [PUTPROPS \IP.PUT.STRING DMACRO (LAMBDA (IP BYTEOFFSET STRING INHEADER) (* ejs%: "30-Mar-86 15:13") (* * Store a string ib an IP packet. If INHEADER is T, BYTEOFFSET is an offset  from the start of the packet, else it's an offset from the start of the IP data  section) (\PUTBASESTRING (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) BYTEOFFSET STRING] [PUTPROPS \IP.PUT.WORD DMACRO (LAMBDA (IP WORD VALUE INHEADER) (* ejs%: "30-Mar-86 14:50") (* * Store a word in an IP packet. If INHEADER is T, WORD is an offset from the  start of the packet, else it's an offset from the start of the IP data section) (\PUTBASE (COND (INHEADER (fetch (IP IPBASE) of IP)) (T (\IPDATABASE IP))) WORD VALUE] ) (MOVD? 'NILL 'IP.DEFAULT.CONFIGURATION) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IP.LOCAL.NETWORKS \IP.DEFAULT.GATEWAY \IP.INIT.FILE \IP.SUBNET.MASKS \PROCESS.AFTEREXIT.EVENT \PROC.READY \AR.IP.TO.10MB.ALIST) ) ) (PUTPROPS TCPLLIP COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (33488 35161 (\SYSQUEUE.DEFPRINT 33498 . 33847) (\IPSOCKET.DEFPRINT 33849 . 35159)) ( 36483 52693 (\CANONICALIZE.IP.HOSTNAME 36493 . 36686) (DODIP.HOSTP 36688 . 37144) (IPHOSTADDRESS 37146 . 37814) (IPHOSTNAME 37816 . 38028) (IPTRACE 38030 . 38227) (IPTRACEWINDOW.BUTTONFN 38229 . 38826) ( PRINTIP 38828 . 41424) (PRINTIPDATA 41426 . 42106) (\IPADDRESSCLASS 42108 . 42705) (\IPEVENTFN 42707 . 43055) (\IPHOSTADDRESS 43057 . 43873) (\IPNETADDRESS 43875 . 44739) (\IP.ADDRESS.TO.STRING 44741 . 45229) (\IP.BROADCAST.ADDRESS 45231 . 48921) (\IP.LEGAL.ADDRESS 48923 . 49271) ( \IP.MAKE.BROADCAST.ADDRESS 49273 . 49713) (\IP.PRINT.ADDRESS 49715 . 50333) (\IP.READ.STRING.ADDRESS 50335 . 52200) (\DOMAIN.NAME.QUALIFY.FULLY 52202 . 52691)) (53342 70901 (STOPIP 53352 . 53628) ( \IPINIT 53630 . 55639) (\IPLISTENER 55641 . 56413) (\IP.REINITIALIZE.FROM.SCRATCH 56415 . 61690) ( \IP.RESTART.FROM.CONFIGURATION 61692 . 66877) (\IP.MAYBE.READ.HOSTS.TXT 66879 . 68355) ( \IP.READ.INIT.FILE 68357 . 70174) (\IP.PROMPT.FOR.FILE.NAME 70176 . 70899)) (75225 84872 ( \HANDLE.RAW.IP 75235 . 77533) (\FORWARD.IP 77535 . 80265) (\IP.LOCAL.DESTINATION 80267 . 82052) ( \IPCHECKSUM 82054 . 84204) (\IP.CHECKSUM.OK 84206 . 84382) (\IP.SET.CHECKSUM 84384 . 84870)) (85442 97726 (\IP.HAND.TO.PROTOCOL 85452 . 86504) (\IP.DEFAULT.INPUTFN 86506 . 87105) (\IP.DEFAULT.NOSOCKETFN 87107 . 87491) (\IP.ADD.PROTOCOL 87493 . 89620) (\IP.DELETE.PROTOCOL 89622 . 90351) ( \IP.FIND.PROTOCOL 90353 . 90740) (\IP.FIND.PROTOCOL.SOCKET 90742 . 92342) (\IP.FIND.SOCKET 92344 . 93234) (\IP.OPEN.SOCKET 93236 . 96216) (\IP.CLOSE.SOCKET 96218 . 97724)) (98507 118821 ( \HANDLE.RAW.IP.FRAGMENT 98517 . 99124) (\IP.NEW.FRAGMENT.LST 99126 . 102391) ( \IP.COPY.FRAGMENT.HEADER.TO.PACKET.HEADER 102393 . 102894) (\IP.ADD.FRAGMENT 102896 . 111986) ( \IP.FIND.MATCHING.FRAGMENTS 111988 . 114409) (\IP.FRAGMENTED.PACKET 114411 . 114700) ( \IP.CHECK.REASSEMBLY.TIMEOUTS 114702 . 116007) (\IP.DELETE.FRAGMENT 116009 . 116501) ( \IP.PRINT.FRAGMENT 116503 . 118819)) (119865 128230 (\IP.PROCESS.OPTIONS 119875 . 122592) ( \IP.OPTION.RECORD.ROUTE 122594 . 123607) (\IP.OPTION.STRICT.SOURCE.ROUTE 123609 . 125209) ( \IP.OPTION.TIMESTAMP 125211 . 128228)) (128581 136430 (\IP.SETUPIP 128591 . 129761) (\IP.TRANSMIT 129763 . 131402) (\IP.ROUTE.PACKET 131404 . 136428)) (136431 138607 (IP.GET 136441 . 137907) (IP.SEND 137909 . 138041) (IP.PACKET.WATCHER 138043 . 138605)) (138832 146433 (\IP.APPEND.BYTE 138842 . 139504) (\IP.APPEND.CELL 139506 . 140978) (\IP.APPEND.STRING 140980 . 141518) (\IP.APPEND.WORD 141520 . 142611) (\IP.GET.BYTE 142613 . 143077) (\IP.GET.CELL 143079 . 143589) (\IP.GET.STRING 143591 . 144084) (\IP.GET.WORD 144086 . 144538) (\IP.PUT.BYTE 144540 . 144994) (\IP.PUT.CELL 144996 . 145496) ( \IP.PUT.STRING 145498 . 145987) (\IP.PUT.WORD 145989 . 146431))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPNAMES b/obsolete/tcp/TCPNAMES deleted file mode 100644 index 13c7aa25..00000000 --- a/obsolete/tcp/TCPNAMES +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10) (FILECREATED " 8-Oct-90 17:23:42" |{LISPDEV:LAIR:OHIO-STATE}TCPNAMES.;2| 70558 changes to%: (VARS TCPNAMESCOMS) (FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D REPACKFILENAME.STRING.MSDOS REPACKFILENAME.STRING.TI REPACKFILENAME.STRING.VMS REPACKFILENAME.STRING.3600 REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.UNIX \REPACKFILENAME.NEW.TRANSLATION \REPACKFILENAME.NEW.TRANSLATIONS) previous date%: "12-Sep-90 17:37:35" {DSK}gadener>medley>work>tcp>tcpnames.;2) (* ; " Copyright (c) 1985, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPNAMESCOMS) (RPAQQ TCPNAMESCOMS [(PROP MAKEFILE-ENVIRONMENT TCPNAMES) (PROP FILETYPE TCPNAMES) (FNS REPACKFILENAME.STRING REPACKFILENAME.STRING.D REPACKFILENAME.STRING.MSDOS REPACKFILENAME.STRING.TI REPACKFILENAME.STRING.VMS REPACKFILENAME.STRING.3600 REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.UNIX \REPACKFILENAME.NEW.TRANSLATION \REPACKFILENAME.NEW.TRANSLATIONS) (INITVARS (\REPACKFILENAME.OSTYPE.TABLE (HASHARRAY 30 1.1))) (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE) (P (\REPACKFILENAME.NEW.TRANSLATIONS (INTERLISP IFS) REPACKFILENAME.STRING.D (TOPS-20 TOPS20) REPACKFILENAME.STRING.TOPS20 (SYMBOLICS-3600 LISPM GENERA) REPACKFILENAME.STRING.3600 VMS REPACKFILENAME.STRING.VMS UNIX REPACKFILENAME.STRING.UNIX MS-DOS REPACKFILENAME.STRING.MSDOS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA \REPACKFILENAME.NEW.TRANSLATIONS) (NLAML) (LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.3600 REPACKFILENAME.STRING.VMS REPACKFILENAME.STRING.TI REPACKFILENAME.STRING.MSDOS REPACKFILENAME.STRING.D]) (PUTPROPS TCPNAMES MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10)) (PUTPROPS TCPNAMES FILETYPE :BCOMPL) (DEFINEQ (REPACKFILENAME.STRING [LAMBDA (NAME FOROSTYPE) (* ; "Edited 29-Sep-90 11:47 by welch") (DECLARE (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE)) (LET ((REPACKFUNCTION (GETHASH FOROSTYPE \REPACKFILENAME.OSTYPE.TABLE))) (COND ((NULL REPACKFUNCTION) NAME) (T (APPLY REPACKFUNCTION (UNPACKFILENAME.STRING NAME]) (REPACKFILENAME.STRING.D [LAMBDA N (* ; "Edited 8-Oct-90 16:23 by welch") (* * Convert file names to native format) (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.D) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY DIR NAME EXTENSION VERSION PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error  checking of fields) (REPACKFILENAME.STRING.D VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen  as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) (HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP)))) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (RELATIVEDIRECTORY (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP)))) ((DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) [AND DEVICE (NEQ DEVICE BLIP) (SELCHARQ (NTHCHARCODE DEVICE -1) (%: (LIST DEVICE)) (LIST DEVICE '%:] (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE \) (CHARCODE /] (RPLCHARCODE DIRECTORY C (CHARCODE >] (LIST "<" DIRECTORY ">")) (LIST "<" DIRECTORY ">")) (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP) (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY)) [for C from 1 to (NCHARS SUBDIRECTORY) do (COND ([FMEMB (NTHCHARCODE SUBDIRECTORY C) (CONSTANT (CHARCODE >) (LIST (CHARCODE \) (CHARCODE /] (RPLCHARCODE SUBDIRECTORY C (CHARCODE >] (LIST "<" SUBDIRECTORY ">")) (LIST "<" SUBDIRECTORY ">")) (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP) (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY)) [for C from 1 to (NCHARS RELATIVEDIRECTORY) do (COND ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C) (CONSTANT (CHARCODE >) (LIST (CHARCODE \) (CHARCODE /] (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE >] (LIST "<" RELATIVEDIRECTORY ">")) (LIST "<" RELATIVEDIRECTORY ">")) (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) (COND ((FIXP VERSION) (LIST '; VERSION)) (T (SELCHARQ (CHCON1 VERSION) (; (LIST VERSION)) ((%. !) (LIST '; (SUBSTRING VERSION 2 -1))) (LIST '; VERSION]) (REPACKFILENAME.STRING.MSDOS [LAMBDA N (* ; "Edited 8-Oct-90 16:48 by welch") (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.MSDOS) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR RELATIVEDIRECTORY SUBDIRECTORY VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION VERSION)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error  checking of fields) (REPACKFILENAME.STRING.MSDOS VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen  as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) (HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP)))) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (RELATIVEDIRECTORY (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP)))) ((DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) (AND DEVICE (NEQ DEVICE BLIP) (LIST ":" DEVICE)) (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE >) (CHARCODE %.) (CHARCODE /] (RPLCHARCODE DIRECTORY C (CHARCODE \] (LIST "\" DIRECTORY "\")) (LIST "\" DIRECTORY "\")) (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP) (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY)) [for C from 1 to (NCHARS SUBDIRECTORY) do (COND ([FMEMB (NTHCHARCODE SUBDIRECTORY C) (CONSTANT (LIST (CHARCODE >) (CHARCODE %.) (CHARCODE /] (RPLCHARCODE SUBDIRECTORY C (CHARCODE \] (LIST "\" SUBDIRECTORY "\")) (LIST "\" SUBDIRECTORY "\")) (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP) (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY)) [for C from 1 to (NCHARS RELATIVEDIRECTORY) do (COND ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C) (CONSTANT (LIST (CHARCODE >) (CHARCODE %.) (CHARCODE /] (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE \] (LIST "\" RELATIVEDIRECTORY "\")) (LIST "\" RELATIVEDIRECTORY "\")) (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((OR (AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) (OR (NULL EXTENSION) (EQ EXTENSION BLIP) (STREQUAL EXTENSION ""))) BLIP) (T '%.)) (OR EXTENSION BLIP]) (REPACKFILENAME.STRING.TI [LAMBDA N (* ; "Edited 8-Oct-90 16:59 by welch") (* * Can you believe this???) (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.TI) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error  checking of fields) (REPACKFILENAME.STRING.TI VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen  as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) (HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP)))) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (RELATIVEDIRECTORY (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP)))) ((DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST HOST ":")) (AND DEVICE (NEQ DEVICE BLIP) (SELCHARQ (NTHCHARCODE DEVICE -1) (%: (LIST DEVICE)) (LIST DEVICE |':|))) (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE >) (CHARCODE /) (CHARCODE \] (RPLCHARCODE DIRECTORY C (CHARCODE %.] (LIST DIRECTORY ";"))) (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP) (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY)) [for C from 1 to (NCHARS SUBDIRECTORY) do (COND ([FMEMB (NTHCHARCODE SUBDIRECTORY C) (CONSTANT (LIST (CHARCODE >) (CHARCODE /) (CHARCODE \] (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.] (LIST SUBDIRECTORY ";"))) (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP) (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY)) [for C from 1 to (NCHARS RELATIVEDIRECTORY) do (COND ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C) (CONSTANT (LIST (CHARCODE >) (CHARCODE /) (CHARCODE \] (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE %.] (LIST RELATIVEDIRECTORY ";"))) (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) (COND ((FIXP VERSION) (LIST '%# VERSION)) (T (SELCHARQ (CHCON1 VERSION) (%# (LIST VERSION)) ((%. ! ;) (LIST '%# (SUBSTRING VERSION 2 -1))) (L (LIST '%# 'OLDEST)) ((H 0) (LIST '%# '>)) (LIST '%# VERSION]) (REPACKFILENAME.STRING.VMS [LAMBDA N (* ; "Edited 8-Oct-90 16:52 by welch") (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.VMS) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error  checking of fields) (REPACKFILENAME.STRING.VMS VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen  as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) (HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP)))) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (RELATIVEDIRECTORY (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP)))) ((DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) [AND DEVICE (NEQ DEVICE BLIP) (SELCHARQ (NTHCHARCODE DEVICE -1) (%: (LIST DEVICE)) (LIST DEVICE '%:] (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE >] (RPLCHARCODE DIRECTORY C (CHARCODE %.] (LIST "[" DIRECTORY "]"))) (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP) (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY)) [for C from 1 to (NCHARS SUBDIRECTORY) do (COND ([FMEMB (NTHCHARCODE SUBDIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE >] (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.] (LIST "[" SUBDIRECTORY "]"))) (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP) (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY)) [for C from 1 to (NCHARS RELATIVEDIRECTORY) do (COND ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE >] (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE %.] (LIST "[" RELATIVEDIRECTORY "]"))) (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) (COND ((FIXP VERSION) (LIST '; VERSION)) (T (SELCHARQ (CHCON1 VERSION) (; (LIST VERSION)) ((%. !) (LIST '; (SUBSTRING VERSION 2 -1))) (LIST '; VERSION]) (REPACKFILENAME.STRING.3600 [LAMBDA N (* ; "Edited 8-Oct-90 16:46 by welch") (* * Can you believe this???) (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.3600) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION PACKLIST VAR VAL TEMP RELATIVEDIRECTORY SUBDIRECTORY) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION SUBDIRECTORY RELATIVEDIRECTORY)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error  checking of fields) (REPACKFILENAME.STRING.3600 VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen  as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) (HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP)))) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (RELATIVEDIRECTORY (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP)))) ((DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST HOST ":")) [AND DEVICE (NEQ DEVICE BLIP) (SELCHARQ (NTHCHARCODE DEVICE -1) (%: (LIST DEVICE)) (LIST DEVICE '%:] (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE %.) (CHARCODE /) (CHARCODE \] (RPLCHARCODE DIRECTORY C (CHARCODE >] (LIST ">" DIRECTORY ">"))) (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP) (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY)) [for C from 1 to (NCHARS SUBDIRECTORY) do (COND ([FMEMB (NTHCHARCODE SUBDIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE %.) (CHARCODE /) (CHARCODE \] (RPLCHARCODE SUBDIRECTORY C (CHARCODE >] (LIST ">" SUBDIRECTORY ">"))) (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP) (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY)) [for C from 1 to (NCHARS RELATIVEDIRECTORY) do (COND ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE %.) (CHARCODE /) (CHARCODE \] (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE >] (LIST ">" RELATIVEDIRECTORY ">"))) (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) (COND ((FIXP VERSION) (LIST '%. VERSION)) (T (SELCHARQ (CHCON1 VERSION) (; (LIST VERSION)) ((%. !) (LIST '%. (SUBSTRING VERSION 2 -1))) (L (LIST '%. 'OLDEST)) ((H 0) (LIST '%. 'NEWEST)) (LIST '%. VERSION]) (REPACKFILENAME.STRING.TOPS20 [LAMBDA N (* ; "Edited 8-Oct-90 16:42 by welch") (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.TOPS20) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY RELATIVEDIRECTORY SUBDIRECTORY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error  checking of fields) (REPACKFILENAME.STRING.TOPS20 VAL)) (T VAL))) [FUNCTION (LAMBDA (X) (* NIL => not yet seen, BLIP => seen  as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) (HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP)))) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (RELATIVEDIRECTORY (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" (CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP)))) ((DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (SELECTQ TEMPORARY ((T S ;S) (* hack for Interlisp-D!) (OR HOST DEVICE (PROGN (SETQ HOST 'CORE) (SETQ TEMPORARY)))) NIL) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) [AND DEVICE (NEQ DEVICE BLIP) (SELCHARQ (NTHCHARCODE DEVICE -1) (%: (LIST DEVICE)) (LIST DEVICE '%:] (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ([FMEMB (NTHCHARCODE DIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE >] (RPLCHARCODE DIRECTORY C (CHARCODE %.] (LIST "<" DIRECTORY ">"))) (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP) (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY)) [for C from 1 to (NCHARS SUBDIRECTORY) do (COND ([FMEMB (NTHCHARCODE SUBDIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE >] (RPLCHARCODE SUBDIRECTORY C (CHARCODE %.] (LIST "<" SUBDIRECTORY ">"))) (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP) (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY)) [for C from 1 to (NCHARS RELATIVEDIRECTORY) do (COND ([FMEMB (NTHCHARCODE RELATIVEDIRECTORY C) (CONSTANT (LIST (CHARCODE /) (CHARCODE >] (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE %.] (LIST "<" RELATIVEDIRECTORY ">"))) (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) (COND ((FIXP VERSION) (LIST '%. VERSION)) (T (SELCHARQ (CHCON1 VERSION) (; (LIST VERSION)) ((%. !) (LIST '%. (SUBSTRING VERSION 2 -1))) (L (LIST '%. -2)) (H (LIST '%. 0)) (LIST '%. VERSION] (AND TEMPORARY (NEQ TEMPORARY BLIP) (LIST '; (SELECTQ TEMPORARY ((S ;S) 'S) T]) (REPACKFILENAME.STRING.UNIX [LAMBDA N (* ; "Edited 8-Oct-90 16:48 by welch") (if (AND (EQ N 1) (LISTP (ARG N 1))) then (* spread argument list) (APPLY (FUNCTION REPACKFILENAME.STRING.UNIX) (ARG N 1)) else (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY DIR NAME EXTENSION VERSION PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY NAME RELATIVEDIRECTORY SUBDIRECTORY EXTENSION VERSION)) LP (COND ((NOT (IGREATERP I N)) (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((NOT (IGREATERP (SETQ I (ADD1 I)) N)) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (ERRORX (LIST 27 VAL))) (* fields must be atom) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (* PACKFILENAME.STRING for error  checking of fields) (REPACKFILENAME.STRING.UNIX VAL)) (T VAL))) [FUNCTION (LAMBDA (X)(* NIL => not yet seen, BLIP => seen  as NIL.) (OR (EVALV (CAR X)) (SET (CAR X) (OR (CADR X) BLIP] (FUNCTION CDDR))) (HOST (OR HOST (SETQ HOST (if VAL then (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL) else BLIP)))) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (if VAL then (CONCAT ( CL:STRING-LEFT-TRIM "<" ( CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (RELATIVEDIRECTORY (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (if VAL then (CONCAT (CL:STRING-LEFT-TRIM "<" ( CL:DIRECTORY-NAMESTRING *DEFAULT-PATHNAME-DEFAULTS* )) VAL) else BLIP)))) (DIRECTORY (OR DIRECTORY (SETQ DIRECTORY (OR VAL BLIP)))) ((DEVICE HOST NAME EXTENSION VERSION) (OR (EVALV VAR) (SET VAR (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (RETURN (CONCATLIST (NCONC (AND HOST (NEQ HOST BLIP) (LIST "{" HOST "}")) (AND DEVICE (NEQ DEVICE BLIP) (LIST "/" DEVICE)) (AND DIRECTORY (NEQ DIRECTORY BLIP) (PROGN (SETQ DIRECTORY (CONCAT DIRECTORY)) [for C from 1 to (NCHARS DIRECTORY) do (COND ((EQ (NTHCHARCODE DIRECTORY C) (CONSTANT (CHARCODE >))) (RPLCHARCODE DIRECTORY C (CHARCODE /] (LIST "/" DIRECTORY "/")) (LIST "/" DIRECTORY "/")) (AND SUBDIRECTORY (NEQ SUBDIRECTORY BLIP) (PROGN (SETQ SUBDIRECTORY (CONCAT SUBDIRECTORY)) [for C from 1 to (NCHARS SUBDIRECTORY) do (COND ((EQ (NTHCHARCODE SUBDIRECTORY C) (CONSTANT (CHARCODE >))) (RPLCHARCODE SUBDIRECTORY C (CHARCODE /] (LIST "/" SUBDIRECTORY "/")) (LIST "/" SUBDIRECTORY "/")) (AND RELATIVEDIRECTORY (NEQ RELATIVEDIRECTORY BLIP) (PROGN (SETQ RELATIVEDIRECTORY (CONCAT RELATIVEDIRECTORY)) [for C from 1 to (NCHARS RELATIVEDIRECTORY ) do (COND ((EQ (NTHCHARCODE RELATIVEDIRECTORY C) (CONSTANT (CHARCODE >))) (RPLCHARCODE RELATIVEDIRECTORY C (CHARCODE /] (LIST "/" RELATIVEDIRECTORY "/")) (LIST "/" RELATIVEDIRECTORY "/")) (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((OR (AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) (OR (NULL EXTENSION) (EQ EXTENSION BLIP) (STREQUAL EXTENSION ""))) BLIP) (T '%.)) (OR EXTENSION BLIP]) (\REPACKFILENAME.NEW.TRANSLATION [LAMBDA (OSTYPE FUNCTION) (DECLARE (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE)) (* ejs%: "27-Apr-85 13:36") (PUTHASH OSTYPE FUNCTION \REPACKFILENAME.OSTYPE.TABLE]) (\REPACKFILENAME.NEW.TRANSLATIONS [NLAMBDA NAMES (* ejs%: "27-Apr-85 13:36") (* * Supply a property-list format argument of ostypes and translating  functions to be added to ostype table) (for TAIL on NAMES by (CDDR TAIL) do (for OSTYPE inside (CAR TAIL) do (\REPACKFILENAME.NEW.TRANSLATION OSTYPE (CADR TAIL]) ) (RPAQ? \REPACKFILENAME.OSTYPE.TABLE (HASHARRAY 30 1.1)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \REPACKFILENAME.OSTYPE.TABLE) ) (\REPACKFILENAME.NEW.TRANSLATIONS (INTERLISP IFS) REPACKFILENAME.STRING.D (TOPS-20 TOPS20) REPACKFILENAME.STRING.TOPS20 (SYMBOLICS-3600 LISPM GENERA) REPACKFILENAME.STRING.3600 VMS REPACKFILENAME.STRING.VMS UNIX REPACKFILENAME.STRING.UNIX MS-DOS REPACKFILENAME.STRING.MSDOS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA \REPACKFILENAME.NEW.TRANSLATIONS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA REPACKFILENAME.STRING.UNIX REPACKFILENAME.STRING.TOPS20 REPACKFILENAME.STRING.3600 REPACKFILENAME.STRING.VMS REPACKFILENAME.STRING.TI REPACKFILENAME.STRING.MSDOS REPACKFILENAME.STRING.D) ) (PUTPROPS TCPNAMES COPYRIGHT ("Xerox Corporation" 1985 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2757 69593 (REPACKFILENAME.STRING 2767 . 3171) (REPACKFILENAME.STRING.D 3173 . 12368) ( REPACKFILENAME.STRING.MSDOS 12370 . 21255) (REPACKFILENAME.STRING.TI 21257 . 30611) ( REPACKFILENAME.STRING.VMS 30613 . 39537) (REPACKFILENAME.STRING.3600 39539 . 49180) ( REPACKFILENAME.STRING.TOPS20 49182 . 58763) (REPACKFILENAME.STRING.UNIX 58765 . 68684) ( \REPACKFILENAME.NEW.TRANSLATION 68686 . 68967) (\REPACKFILENAME.NEW.TRANSLATIONS 68969 . 69591))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPOPS b/obsolete/tcp/TCPOPS deleted file mode 100644 index 5e47a466..00000000 --- a/obsolete/tcp/TCPOPS +++ /dev/null @@ -1,212 +0,0 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") -(FILECREATED "22-May-90 10:55:20" |{DSK}/home/neptune/jds/TCPOPS.;17| 14660 - - |changes| |to:| (FNS TCP-ACCEPT TCP-LISTEN UDP-RECV) - - |previous| |date:| " 3-May-90 11:40:39" |{DSK}/home/neptune/jds/TCPOPS.;16|) - - -; Copyright (c) 1989, 1990 by Savoir, Inc.. All rights reserved. - -(PRETTYCOMPRINT TCPOPSCOMS) - -(RPAQQ TCPOPSCOMS ((FILES CHARDEVICE) (ADDVARS (\\INITSUBRS (TCP 144))) (COMS (* |;;| "TCP Streams") (FNS \\TCP-DEV-INIT \\TCP-OPENFILE \\TCP-FORCEOUTPUT \\TCP-GETNEXTBUFFER \\TCP-EOFP \\TCP-CLOSEFILE \\TCP-EVENTFN \\TCP.BUFFERED.BOUTS) (P (\\TCP-DEV-INIT))) (COMS (* |;;| "User-level TCP operations") (FNS TCP OPENTCPSTREAM TCP-ACCEPT TCP-LISTEN TCP-CLOSE) (FNS UDP-LISTEN UDP-SEND UDP-RECV) (FNS GETHOSTFROMNAME GETHOSTFROMADDR GETHOSTFROMSOCKET GETHOSTNAME)) (DECLARE\: EVAL@LOAD DONTCOPY (COMS (* |;;| "Debugging functions &c") (VARS (BUFFER (\\ALLOCBLOCK 100))) (FNS TCPRECV TCPSEND SEEBUFFER FOON))))) - -(FILESLOAD CHARDEVICE) - -(ADDTOVAR \\INITSUBRS (TCP 144)) - - - -(* |;;| "TCP Streams") - -(DEFINEQ - -(\\TCP-DEV-INIT -(LAMBDA NIL (* \; "Edited 20-Feb-90 12:51 by jds") (* |;;| "Initialization for buffered Unix-character-oriented device (e.g. for TCP streams on SUN)") (SETQ \\TCP-FDEV (|create| FDEV DEVICENAME _ "TCP" FDBINABLE _ T FDBOUTABLE _ T BUFFERED _ T BIN _ (FUNCTION \\BUFFERED.BIN) BOUT _ (FUNCTION \\BUFFCHAR-OTHER-BOUT) OPENFILE _ (FUNCTION \\BUFFCHAR-DEV-OPENFILE) EVENTFN _ (FUNCTION \\CHAR-DEV-EVENTFN) REOPENFILE _ (FUNCTION \\BUFFCHAR-DEV-OPENFILE) CLOSEFILE _ (FUNCTION \\TCP-CLOSEFILE) FORCEOUTPUT _ (FUNCTION \\TCP-FORCEOUTPUT) EOFP _ (FUNCTION \\TCP-EOFP) BLOCKIN _ (FUNCTION \\BUFFERED.BINS) BLOCKOUT _ (FUNCTION \\TCP.BUFFERED.BOUTS) READP _ (FUNCTION \\GENERIC.READP) PEEKBIN _ (FUNCTION \\BUFFERED.PEEKBIN) GETNEXTBUFFER _ (FUNCTION \\TCP-GETNEXTBUFFER))) (\\DEFINEDEVICE (QUOTE TCP) \\TCP-FDEV)) -) - -(\\TCP-OPENFILE -(LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) (* \; "Edited 7-Mar-90 10:11 by jds") (LET ((UNIX-NAME (SUBSTRING NAME (ADD1 (STRPOS "}" NAME)))) (ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (SELECTQ ACCESS (INPUT (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (SETQ ACCESS-VALUE 0)) (OUTPUT (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (REPLACE F2 OF STREAM WITH (SETQ OTHER-STREAM (|create| STREAM BINABLE _ NIL BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC))) (SETQ ACCESS-VALUE 1)) (BOTH (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (REPLACE F2 OF STREAM WITH (SETQ OTHER-STREAM (|create| STREAM BINABLE _ NIL BOUTABLE _ NIL DEVICE _ FDEV FULLFILENAME _ NAME STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC))) (SETQ ACCESS-VALUE 2)) (APPEND (\\ILLEGAL.ARG ACCESS)) (\\ILLEGAL.ARG ACCESS)) (COND ((SETQ IODESCRIPTOR (SUBRCALL CHAR-OPENFILE UNIX-NAME ACCESS-VALUE ERRNO)) (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| IODESCRIPTOR) (COND (OTHER-STREAM (|replace| (STREAM F1) |of| OTHER-STREAM |with| IODESCRIPTOR)))) (T (\\CHAR-ERROR ERRNO NAME))) STREAM)) -) - -(\\TCP-FORCEOUTPUT - (LAMBDA (STREAM WAIT) (* \; "Edited 15-Dec-89 16:09 by jds") - -(* |;;;| "Generic buffer refiller for Buffered character streams (e.g. TCP streams on Sun, or the Lisp side of a shell CHAT, eventually)") - - (PROG (ERRCODE (OTHER-STREAM (|fetch| F2 |of| STREAM)) - (ERRNO (\\CREATECELL \\FIXP)) - BUFFER) - (COND - ((NULL (|fetch| CPPTR |of| OTHER-STREAM)) - - (* |;;| "No buffer allocated yet; create one.") - - (REPLACE CPPTR OF OTHER-STREAM WITH (NCREATE 'VMEMPAGEP)) - (REPLACE CBUFSIZE OF OTHER-STREAM WITH 512) - (REPLACE CBUFMAXSIZE OF OTHER-STREAM WITH 512) - (REPLACE COFFSET OF OTHER-STREAM WITH 0) - T) - ((ZEROP (|fetch| COFFSET |of| OTHER-STREAM)) - T) - ((SETQ ERRCODE (\\CHAR-BOUTS OTHER-STREAM (|fetch| CPPTR |of| OTHER-STREAM) - 0 - (|fetch| COFFSET |of| OTHER-STREAM) - NIL)) - - (* |;;| "WRITE HAPPENED.") - - (|replace| CBUFSIZE |of| OTHER-STREAM |with| 512) - (|replace| CBUFMAXSIZE |of| OTHER-STREAM |with| 512) - (|replace| COFFSET |of| OTHER-STREAM |with| 0) - T))))) - -(\\TCP-GETNEXTBUFFER -(LAMBDA (STREAM WHATFOR NOERRORFLG EOF-TEST) (* \; "Edited 20-Feb-90 12:43 by jds") (* |;;;| "Generic buffer refiller for Buffered character streams (e.g. TCP streams on Sun, or the Lisp side of a shell CHAT, eventually).") (PROG (ERRCODE (ERRNO (\\CREATECELL \\FIXP)) BUFFER) READ-LOOP (RETURN (SELECTQ WHATFOR (READ (* |;;| "READING; GET A FRESH BUFFER FULL OF UN-READ CHARACTERS.") (SETQ BUFFER (OR (FETCH (STREAM CPPTR) OF STREAM) (NCREATE (QUOTE VMEMPAGEP)))) (|replace| CPPTR |of| STREAM |with| BUFFER) (COND ((ZEROP (SETQ ERRCODE (TCP 6 (|fetch| (STREAM F1) |of| STREAM) BUFFER 512))) (AND (NULL NOERRORFLG) (\\EOF.ACTION STREAM)) NIL) ((EQ ERRCODE T) (AND EOF-TEST (RETURN T)) (BLOCK) (GO READ-LOOP)) (ERRCODE (* |;;| "Read succeeded, and ERRCODE has # of chars read.") (|replace| CPPTR |of| STREAM |with| BUFFER) (|replace| COFFSET |of| STREAM |with| 0) (|replace| CBUFSIZE |of| STREAM |with| ERRCODE) (|replace| CBUFMAXSIZE |of| STREAM |with| ERRCODE) T) ((NULL NOERRORFLG) (\\CHAR-ERROR ERRNO STREAM)))) (WRITE (COND ((NULL (FETCH CPPTR OF STREAM)) (* |;;| "No buffer allocated yet; create one.") (REPLACE CPPTR OF STREAM WITH (NCREATE (QUOTE VMEMPAGEP))) (REPLACE CBUFSIZE OF STREAM WITH 512) (REPLACE CBUFMAXSIZE OF STREAM WITH 512) (REPLACE COFFSET OF STREAM WITH 0) T) ((ZEROP (FETCH COFFSET OF STREAM)) T) ((SETQ ERRCODE (\\CHAR-BOUTS STREAM (FETCH CPPTR OF STREAM) 0 (FETCH COFFSET OF STREAM) NOERRORFLG)) (* |;;| "WRITE HAPPENED.") (REPLACE CBUFSIZE OF STREAM WITH 512) (REPLACE CBUFMAXSIZE OF STREAM WITH 512) (REPLACE COFFSET OF STREAM WITH 0) T))) (SHOULDNT))))) -) - -(\\TCP-EOFP -(LAMBDA (STREAM) (* \; "Edited 20-Feb-90 12:42 by jds") (* |;;| "T if there will be no more data on the stream") (AND (OR (NOT (|fetch| (STREAM CPPTR) |of| STREAM)) (IEQP (FETCH (STREAM COFFSET) OF STREAM) (FETCH (STREAM CBUFSIZE) OF STREAM))) (NOT (\\TCP-GETNEXTBUFFER STREAM (QUOTE READ) T T)))) -) - -(\\TCP-CLOSEFILE - (LAMBDA (STREAM) (* \; "Edited 18-Dec-89 11:17 by jds") - - (* |;;| "Close a TCP connection or listening-socket cleanly.") - - (TCP 3 (|fetch| (STREAM F1) |of| STREAM)) - STREAM)) - -(\\TCP-EVENTFN - (LAMBDA (FDEV EVENT) (* \; "Edited 30-Jan-90 13:56 by jds") - (SELECTQ EVENT - ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS BEFORESAVEVM) - (* |;;| - "Clean up existing connections, and remember any LISTENS in progress") - - ) - ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) - - (* |;;| -"Try to reopen streams that had been open, and re-establish any LISTENs in progress when we exited.") - - ) - NIL))) - -(\\TCP.BUFFERED.BOUTS -(LAMBDA (STREAM SBASE OFFSET NBYTES) (\\BUFFERED.BOUTS (FETCH F2 OF STREAM) SBASE OFFSET NBYTES))) -) - -(\\TCP-DEV-INIT) - - - -(* |;;| "User-level TCP operations") - -(DEFINEQ - -(TCP -(LAMBDA (A B C D E F G H I J K L M) (* \; "Edited 4-Apr-90 17:29 by jds") (* |;;| "Generic TCP-operation hider function. Hides the fact of TCP ops being SUBRCALLs.") (* |;;| "Returns whatever result the TCP operation returns.") (SUBRCALL TCP A B C D E F G H I J K L M)) -) - -(OPENTCPSTREAM -(LAMBDA (HOST PORT) (* \; "Edited 3-May-90 11:38 by jds") (LET ((ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (|replace| (STREAM ACCESS) |of| STREAM |with| (QUOTE BOTH)) (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (|replace| F2 |of| STREAM |with| (SETQ OTHER-STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ NIL USERVISIBLE _ NIL EOLCONVENTION _ LF.EOLC))) (COND ((SETQ IODESCRIPTOR (TCP 4 HOST PORT)) (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| IODESCRIPTOR) (|replace| (STREAM F1) |of| OTHER-STREAM |with| IODESCRIPTOR)) (T (\\CHAR-ERROR ERRNO HOST))) STREAM)) -) - -(TCP-ACCEPT -(LAMBDA (WAITING-SOCKET) (* \; "Edited 22-May-90 10:18 by jhb") (LET ((ERRNO (CREATECELL \\FIXP)) IODESCRIPTOR ACCESS-VALUE STREAM OTHER-STREAM SOCKET) (|while| (OR (NOT SOCKET) (< SOCKET 0)) |do| (BLOCK) (SETQ SOCKET (TCP 8 WAITING-SOCKET))) (PRINTOUT *TRACE-OUTPUT* "SOCKET ACCEPTED " SOCKET T) (SETQ STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ (GETHOSTFROMSOCKET SOCKET) USERCLOSEABLE _ T USERVISIBLE _ T EOLCONVENTION _ LF.EOLC)) (|replace| (STREAM ACCESS) |of| STREAM |with| (QUOTE BOTH)) (|replace| (STREAM STRMBINFN) |of| STREAM |with| (FUNCTION \\BUFFERED.BIN)) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\BUFFCHAR-OTHER-BOUT)) (|replace| F2 |of| STREAM |with| (SETQ OTHER-STREAM (|create| STREAM BINABLE _ T BOUTABLE _ T DEVICE _ \\TCP-FDEV FULLFILENAME _ HOST STRMBOUTFN _ (FUNCTION \\BUFFERED.BOUT) USERCLOSEABLE _ NIL USERVISIBLE _ NIL EOLCONVENTION _ LF.EOLC))) (COND (SOCKET (* |;;| "Open happened, so put things together.") (|replace| (STREAM F1) |of| STREAM |with| SOCKET) (|replace| (STREAM F1) |of| OTHER-STREAM |with| SOCKET)) (T (\\CHAR-ERROR ERRNO HOST))) STREAM)) -) - -(TCP-LISTEN -(LAMBDA (SOCKET-NUMBER ACCEPT-FUNCTION ACCEPT-DATA) (* \; "Edited 22-May-90 10:54 by jhb") (LET ((SOCKET (TCP 7 SOCKET-NUMBER))) (SETQ \\MAIKO.IO-INTERRUPT-VECTOR (CONS (LIST (LLSH 1 SOCKET) ACCEPT-FUNCTION SOCKET ACCEPT-DATA) \\MAIKO.IO-INTERRUPT-VECTOR)) SOCKET)) -) - -(TCP-CLOSE -(LAMBDA (DESCRIPTOR-NUMBER) (* \; "Edited 4-Apr-90 14:51 by jds") (LET ((ACCEPTOR (ASSOC (LLSH 1 DESCRIPTOR-NUMBER) \\MAIKO.IO-INTERRUPT-VECTOR))) (TCP 3 DESCRIPTOR-NUMBER) (* \; "Close the TCP connection") (DREMOVE ACCEPTOR \\MAIKO.IO-INTERRUPT-VECTOR) (* \; "REmove any acceptor.") DESCRIPTOR-NUMBER)) -) -) -(DEFINEQ - -(UDP-LISTEN -(LAMBDA (SOCKET-NUMBER ACCEPT-FUNCTION ACCEPT-INFO) (* \; "Edited 4-Apr-90 15:49 by jds") (* |;;| "Listen on a particular UDP socket for incoming packet traffic. Also has the effect of opening the socket for outgoing traffic.") (LET ((SOCKET (TCP 128 SOCKET-NUMBER))) (SETQ \\MAIKO.IO-INTERRUPT-VECTOR (CONS (LIST (LLSH 1 SOCKET) ACCEPT-FUNCTION SOCKET ACCEPT-INFO) \\MAIKO.IO-INTERRUPT-VECTOR)) SOCKET)) -) - -(UDP-SEND -(LAMBDA (SOCKET BUFFER LEN ADDR PORT) (TCP 130 SOCKET ADDR PORT BUFFER LEN))) - -(UDP-RECV -(LAMBDA (SOCKET) (* \; "Edited 3-May-90 11:40 by jds") (* |;;| "Xall recvfrom() to get an incoming packet on a UDP socket.") (* |;;| "Returns 4 results:") (* |;;| " The 1500-byte buffer containing the packet") (* |;;| " The length of the incoming packet") (* |;;| " The address of the guy who sent it") (* |;;| " The port to answer him on (or where he sent it from)") (LET ((BUFFER (NCREATE (QUOTE VMEMPAGEP))) LEN (ADDR (\\CREATECELL \\FIXP)) (PORT (\\CREATECELL \\FIXP))) (SETQ LEN (TCP 131 SOCKET BUFFER 512 ADDR PORT)) (CL:VALUES BUFFER LEN ADDR PORT))) -) -) -(DEFINEQ - -(GETHOSTFROMNAME - (LAMBDA (NAME) (* \; "Edited 1-Feb-90 11:26 by jds") - - (* |;;| - "Given a host name, return the IP address for that host. If the host isn't found, return NIL.") - - (TCP 0 NAME))) - -(GETHOSTFROMADDR -(LAMBDA (ADDR) (* \; "Edited 6-Apr-90 20:23 by jds") (* |;;| "Given a host's IP address, return the string name of the host, or NIL if it can't be found.") (LET* ((BUF (\\ALLOCBLOCK 100 NIL)) (LEN (TCP 66 ADDR BUF))) (COND ((ZEROP LEN) NIL) (T (\\GETBASESTRING BUF 0 LEN))))) -) - -(GETHOSTFROMSOCKET - (LAMBDA (SOCKET) (* \; "Edited 1-Feb-90 11:30 by jds") - - (* |;;| "Given the socket FD of a TCP connection, return the NAME of the remote host, or NIL if it can't be found.") - - (LET* ((BUF (\\ALLOCBLOCK 100 NIL)) - (LEN (TCP 65 SOCKET BUF))) - (COND - ((ZEROP LEN) - NIL) - (T (CONCATLIST (FOR I FROM 0 TO (SUB1 LEN) COLLECT (\\GETBASEBYTE BUF I) - ))))))) - -(GETHOSTNAME -(LAMBDA NIL (* \; "Edited 6-Apr-90 20:25 by jds") (* |;;| "Given a host's IP address, return the string name of the host, or NIL if it can't be found.") (LET* ((BUF (\\ALLOCBLOCK 100 NIL)) (LEN (TCP 67 BUF))) (COND ((ZEROP LEN) NIL) (T (\\GETBASESTRING BUF 0 LEN))))) -) -) -(DECLARE\: EVAL@LOAD DONTCOPY - - - -(* |;;| "Debugging functions &c") - - -(RPAQ BUFFER (\\ALLOCBLOCK 100)) -(DEFINEQ - -(TCPRECV - (LAMBDA (PORT) - (LET ((LEN (TCP 6 PORT BUFFER 100))) - (|for| I |from| 0 |to| (SUB1 LEN) |do| (PRIN1 (CHARACTER (\\GETBASEBYTE - BUFFER I)))) - (TERPRI)))) - -(TCPSEND - (LAMBDA (PORT BASE LEN) (* \; "Edited 15-Dec-89 15:13 by jds") - (TCP 5 PORT BASE OFFSET LEN))) - -(SEEBUFFER -(LAMBDA (BUF) (|for| I |from| 0 |to| 11 |do| (PRIN1 (CHARACTER (\\GETBASEBYTE BUF I)))))) - -(FOON -(LAMBDA (INFO) (* \; "Edited 4-Apr-90 17:35 by jds") (LET ((RES (CL:MULTIPLE-VALUE-LIST (UDP-RECV (CADDR INFO))))) (AND (CADR RES) (SETQ RESULT RES)))) -) -) -) -(PUTPROPS TCPOPS COPYRIGHT ("Savoir, Inc." 1989 1990)) -(DECLARE\: DONTCOPY - (FILEMAP (NIL (1081 8055 (\\TCP-DEV-INIT 1091 . 1918) (\\TCP-OPENFILE 1920 . 3557) (\\TCP-FORCEOUTPUT -3559 . 5060) (\\TCP-GETNEXTBUFFER 5062 . 6672) (\\TCP-EOFP 6674 . 6989) (\\TCP-CLOSEFILE 6991 . 7259) -(\\TCP-EVENTFN 7261 . 7927) (\\TCP.BUFFERED.BOUTS 7929 . 8053)) (8119 11214 (TCP 8129 . 8411) ( -OPENTCPSTREAM 8413 . 9441) (TCP-ACCEPT 9443 . 10604) (TCP-LISTEN 10606 . 10889) (TCP-CLOSE 10891 . -11212)) (11215 12328 (UDP-LISTEN 11225 . 11649) (UDP-SEND 11651 . 11742) (UDP-RECV 11744 . 12326)) ( -12329 13743 (GETHOSTFROMNAME 12339 . 12608) (GETHOSTFROMADDR 12610 . 12909) (GETHOSTFROMSOCKET 12911 - . 13452) (GETHOSTNAME 13454 . 13741)) (13851 14580 (TCPRECV 13861 . 14149) (TCPSEND 14151 . 14306) ( -SEEBUFFER 14308 . 14412) (FOON 14414 . 14578))))) -STOP diff --git a/obsolete/tcp/TCPTFTP b/obsolete/tcp/TCPTFTP deleted file mode 100644 index 9f1b3327..00000000 --- a/obsolete/tcp/TCPTFTP +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 17:44:14" {DSK}local>lde>lispcore>library>TCPTFTP.;2 53424 changes to%: (VARS TCPTFTPCOMS) previous date%: " 1-Jul-87 10:52:03" {DSK}local>lde>lispcore>library>TCPTFTP.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPTFTPCOMS) (RPAQQ TCPTFTPCOMS ((COMS (* ;; "Trivial File Transfer Protocol") (INITVARS (\TFTP.DEVICE) (TFTP.MAXRETRIES 20)) (GLOBALVARS \TFTP.DEVICE TFTP.MAXRETRIES) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS TFTPCON TFTP TFTPSTREAM) (CONSTANTS (\TFTPOVLEN 4) (\TFTP.SOCKET 69)) (CONSTANTS * TFTPOPCODES))) (INITVARS (TFTP.MAXRETRIES 20)) (FNS \TFTP.ACKNOWLEDGE \TFTP.CLOSEFILE \TFTP.EOFP \TFTP.ERROR \TFTP.GETNEXTBUFFER \TFTP.INIT \TFTP.INPUT.BUFFER \TFTP.OPENFILE \TFTP.READP \TFTP.SEND.ERROR \TFTP.SETUP) (FILES (SYSLOAD) TCPUDP)) (COMS (* ;; "TFTP Server functions") (INITVARS (\TFTP.SERVER.CONNECTIONS)) (GLOBALVARS \TFTP.SERVER.CONNECTIONS) (FNS TFTP.SERVER.PROCESS \TFTP.GET.FILE \TFTP.SEND.FILE)) (COMS (* ;; "User functions") (FNS TFTP.SERVER TFTP.GET TFTP.PUT)) (COMS (* ;; "Tracing functions") (FNS PRINTTFTP \TFTP.PRINT.ACK \TFTP.PRINT.DATA \TFTP.PRINT.ERROR \TFTP.PRINT.REQUEST)) (P (\TFTP.INIT)))) (* ;; "Trivial File Transfer Protocol") (RPAQ? \TFTP.DEVICE ) (RPAQ? TFTP.MAXRETRIES 20) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TFTP.DEVICE TFTP.MAXRETRIES) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (RECORD TFTPCON (UDPSOCKET DESTSOCKET STREAM HOST)) (ACCESSFNS TFTP ((TFTPBASE (fetch (UDP UDPCONTENTS) of DATUM))) (BLOCKRECORD TFTPBASE ((OPCODE WORD) (BLOCK# WORD))) [ACCESSFNS TFTP ((TFTPCONTENTS (\ADDBASE (fetch (UDP UDPCONTENTS) of DATUM) (FOLDHI \TFTPOVLEN BYTESPERWORD] (BLOCKRECORD TFTPBASE ((NIL WORD) (ERRORCODE WORD)))) (ACCESSFNS TFTPSTREAM ((TFTPCON (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) (LASTPACKETIN (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TFTPOVLEN 4) (RPAQQ \TFTP.SOCKET 69) (CONSTANTS (\TFTPOVLEN 4) (\TFTP.SOCKET 69)) ) (RPAQQ TFTPOPCODES ((\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5))) (DECLARE%: EVAL@COMPILE (RPAQQ \TFTP.RRQ 1) (RPAQQ \TFTP.WRQ 2) (RPAQQ \TFTP.DATA 3) (RPAQQ \TFTP.ACK 4) (RPAQQ \TFTP.ERROR 5) (CONSTANTS (\TFTP.RRQ 1) (\TFTP.WRQ 2) (\TFTP.DATA 3) (\TFTP.ACK 4) (\TFTP.ERROR 5)) ) (* "END EXPORTED DEFINITIONS") ) (RPAQ? TFTP.MAXRETRIES 20) (DEFINEQ (\TFTP.ACKNOWLEDGE [LAMBDA (STREAM ACK#) (* MPL " 2-Jun-85 17:07") (LET ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM)) (ACK (\ALLOCATE.ETHERPACKET))) (\TFTP.SETUP ACK TFTPCON \TFTP.ACK 'FREE) (UDP.APPEND.WORD ACK ACK#) (UDP.SEND (fetch (TFTPCON UDPSOCKET) of TFTPCON) ACK) (BLOCK) (COND ((AND (EQ (fetch (STREAM ACCESS) of STREAM) 'INPUT) (fetch (TFTPSTREAM LASTPACKETIN) of STREAM)) (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON]) (\TFTP.CLOSEFILE [LAMBDA (STREAM) (* ejs%: " 9-Feb-85 23:47") (LET ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM))) (SELECTQ (fetch (STREAM ACCESS) of STREAM) (OUTPUT [COND ((AND (fetch (STREAM CBUFPTR) of STREAM) (NOT (fetch (TFTPSTREAM LASTPACKETIN) of STREAM))) (\TFTP.GETNEXTBUFFER STREAM 'WRITE]) NIL) (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON) T) (replace (STREAM ACCESS) of STREAM with NIL) STREAM]) (\TFTP.EOFP [LAMBDA (STREAM) (* ejs%: " 9-Feb-85 21:23") (OR (NULL (fetch (STREAM CBUFPTR) of STREAM)) (AND (fetch (TFTPSTREAM LASTPACKETIN) of STREAM) (EQ (fetch (STREAM COFFSET) of STREAM) (fetch (STREAM CBUFSIZE) of STREAM]) (\TFTP.ERROR [LAMBDA (TFTP TFTPCON) (* ejs%: " 9-Feb-85 19:04") (* * Called upon receipt of error packet in TFTP stream) (LET [(ERRORSTRING (ALLOCSTRING (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP) (CONSTANT (IPLUS \UDPOVLEN (ADD1 \TFTPOVLEN] (\MOVEBYTES (fetch (TFTP TFTPCONTENTS) of TFTP) 0 (fetch (STRINGP BASE) of ERRORSTRING) (fetch (STRINGP OFFST) of ERRORSTRING) (fetch (STRINGP LENGTH) of ERRORSTRING)) (ERROR (CONCAT "TFTP error message: " ERRORSTRING " for code") (fetch (TFTP ERRORCODE) of TFTP]) (\TFTP.GETNEXTBUFFER [LAMBDA (STREAM WHATFOR NOERRORFLG) (* MPL " 2-Jun-85 19:48") (DECLARE (GLOBALVARS TFTP.MAXRETRIES)) (LET* ((TFTPCON (fetch (TFTPSTREAM TFTPCON) of STREAM)) (IPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)) (RETRYCOUNT 0) (BUFFER (fetch (STREAM CBUFPTR) of STREAM)) UDP) (SELECTQ WHATFOR (READ [COND [(fetch (TFTPSTREAM LASTPACKETIN) of STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (\RELEASE.ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM)) (replace (STREAM CBUFPTR) of STREAM with NIL) (COND (NOERRORFLG NIL) (T (\EOF.ACTION STREAM] (T (PROG [(NEXT# (COND (BUFFER (ADD1 (fetch (TFTP BLOCK#) of BUFFER))) (T 1] LP [for I from 1 to TFTP.MAXRETRIES until UDP do (SETQ UDP (UDP.GET IPSOCKET \ETHERTIMEOUT)) (COND ((NOT UDP) (\TFTP.ACKNOWLEDGE STREAM (SUB1 NEXT#] (COND [UDP (COND [(EQ (fetch (TFTP OPCODE) of UDP) \TFTP.DATA) (COND ((IEQP (fetch (TFTP BLOCK#) of UDP) NEXT#) (\TFTP.INPUT.BUFFER STREAM UDP) (\TFTP.ACKNOWLEDGE STREAM NEXT#) (RETURN T)) [(ILESSP (fetch (TFTP BLOCK#) of UDP) NEXT#) [COND (IPTRACEFLG (COND ((EQ IPTRACEFLG T) (printout IPTRACEFILE "Retransmitting ACK for block " (SUB1 NEXT#) T)) (T (PRIN1 "R" IPTRACEFILE] (\TFTP.ACKNOWLEDGE STREAM (SUB1 NEXT#)) (\RELEASE.ETHERPACKET UDP) (SETQ UDP NIL) (COND ((EQ (add RETRYCOUNT 1) TFTP.MAXRETRIES) (\TFTP.SEND.ERROR TFTPCON 0 "Timeout awaiting next data packet; aborting") (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (ERROR "Timeout awaiting next data packet; aborting" STREAM)) (T (GO LP] (T (\TFTP.SEND.ERROR TFTPCON 0 "Protocol error: Block # too high. Aborting...") (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (ERROR "Protocol error: Block # too high. Aborting..." STREAM] ((EQ (fetch (TFTP OPCODE) of UDP) \TFTP.ERROR) (replace (STREAM STRMBINFN) of STREAM with (FUNCTION STREAM.NOT.OPEN)) (\TFTP.ERROR UDP TFTPCON)) (T [\TFTP.SEND.ERROR TFTPCON 0 (CONCAT "Protocol error: Illegal TFTP opcode, expected DATA but got " (SELECTC (fetch (TFTP OPCODE) of UDP) (\TFTP.RRQ "read request.") (\TFTP.WRQ "write request.") (\TFTP.ACK "ack.") (CONCAT "unknown type " (fetch (TFTP OPCODE) of UDP) "."] (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (ERROR "Illegal TFTP opcode rec'd" STREAM] (T (\TFTP.SEND.ERROR TFTPCON 0 "Timeout awaiting next data packet; aborting") (replace (STREAM STRMBINFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (ERROR "Timeout awaiting next data packet; aborting" STREAM]) (WRITE [COND [(fetch (TFTPSTREAM LASTPACKETIN) of STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (COND (NOERRORFLG NIL) (T (\EOF.ACTION STREAM] (T (PROG (ACK# NBYTES) (SETQ ACK# (fetch (TFTP BLOCK#) of BUFFER)) (SETQ NBYTES (IDIFFERENCE (fetch (STREAM COFFSET) of STREAM) (UNFOLD (IDIFFERENCE (\LOLOC (fetch (TFTP TFTPCONTENTS ) of BUFFER)) (\LOLOC BUFFER)) BYTESPERWORD))) [replace (IP IPTOTALLENGTH) of BUFFER with (IPLUS NBYTES (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN \IPOVLEN] [replace (UDP UDPLENGTH) of BUFFER with (IPLUS NBYTES (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN ] (COND ((ILESSP NBYTES 512) (replace (TFTPSTREAM LASTPACKETIN) of STREAM with T))) LP (for I from 1 to TFTP.MAXRETRIES until UDP do (SETQ UDP (UDP.EXCHANGE IPSOCKET BUFFER))) (COND [(AND UDP (EQ (fetch (TFTP OPCODE) of UDP) \TFTP.ACK)) (COND ((EQ (fetch (TFTP BLOCK#) of UDP) ACK#) [COND ((EQ NBYTES 512) (\TFTP.SETUP UDP TFTPCON \TFTP.DATA NIL) (UDP.APPEND.WORD UDP (ADD1 ACK#)) (replace (UDP UDPLENGTH) of UDP with (CONSTANT (IPLUS 512 \UDPOVLEN \TFTPOVLEN))) (\TFTP.INPUT.BUFFER STREAM UDP)) (T (replace (STREAM CBUFPTR) of STREAM with NIL) (replace (STREAM ACCESS) of STREAM with NIL) (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON] (RETURN T)) [(ILESSP (fetch (TFTP BLOCK#) of UDP) ACK#) [COND (IPTRACEFLG (COND ((EQ IPTRACEFLG T) (printout IPTRACEFILE "TFTP retransmission on block# " ACK# T )) (T (PRIN1 "R" IPTRACEFILE] (\RELEASE.ETHERPACKET UDP) (SETQ UDP NIL) (COND [(EQ (add RETRYCOUNT 1) TFTP.MAXRETRIES) (\TFTP.SEND.ERROR TFTPCON 0 "Timeout awaiting acknowledgement. Aborting...") (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (COND (NOERRORFLG NIL) (T (\EOF.ACTION STREAM] (T (GO LP] (T (\TFTP.SEND.ERROR TFTPCON 0 "Protocol error: Block # too high. Aborting...") (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (COND (NOERRORFLG NIL) (T (\EOF.ACTION STREAM] ((AND UDP (EQ (fetch (TFTP OPCODE) of UDP) \TFTP.ERROR)) (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (\TFTP.ERROR UDP TFTPCON)) [UDP [\TFTP.SEND.ERROR TFTPCON 0 (CONCAT "Protocol error: Illegal TFTP opcode, expected ACK but got " (SELECTC (fetch (TFTP OPCODE) of UDP) (\TFTP.RRQ "read request.") (\TFTP.WRQ "write request.") (\TFTP.DATA "data.") (CONCAT "unknown type " (fetch (TFTP OPCODE) of UDP) "."] (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (COND (NOERRORFLG NIL) (T (\EOF.ACTION STREAM] (T (\TFTP.SEND.ERROR TFTPCON 0 "Protocol error, aborting...") (replace (STREAM STRMBOUTFN) of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (COND (NOERRORFLG NIL) (T (\EOF.ACTION STREAM]) (ERROR "Illegal ACCESS" WHATFOR]) (\TFTP.INIT [LAMBDA NIL (* ejs%: " 2-Feb-86 12:00") (DECLARE (GLOBALVARS \TFTP.DEVICE)) (OR \TFTP.DEVICE (\DEFINEDEVICE NIL (SETQ \TFTP.DEVICE (create FDEV FDBINABLE _ T FDBOUTABLE _ T NODIRECTORIES _ T RESETABLE _ NIL RANDOMACCESSP _ NIL BUFFERED _ T PAGEMAPPED _ NIL DEVICENAME _ 'TFTP HOSTNAMEP _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) FORCEOUTPUT _ (FUNCTION NILL) BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION \BUFFERED.BOUT) GETNEXTBUFFER _ (FUNCTION \TFTP.GETNEXTBUFFER) READP _ (FUNCTION \TFTP.READP) EOFP _ (FUNCTION \TFTP.EOFP) CLOSEFILE _ (FUNCTION \TFTP.CLOSEFILE]) (\TFTP.INPUT.BUFFER [LAMBDA (STREAM UDP) (* ejs%: " 9-Feb-85 20:51") (* * Sets up the fields of the stream necessary to support buffered operation,  with UDP as the next packet) (LET [(OFFSET (UNFOLD (IDIFFERENCE (\LOLOC (fetch (TFTP TFTPCONTENTS) of UDP)) (\LOLOC UDP)) BYTESPERWORD)) (LENGTH (IDIFFERENCE (fetch (UDP UDPLENGTH) of UDP) (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN] [COND ((type? ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM)) (\RELEASE.ETHERPACKET (fetch (STREAM CBUFPTR) of STREAM] (replace (STREAM CBUFPTR) of STREAM with UDP) (replace (STREAM COFFSET) of STREAM with OFFSET) (replace (STREAM CBUFSIZE) of STREAM with (replace (STREAM CBUFMAXSIZE) of STREAM with (IPLUS OFFSET LENGTH))) (COND ((ILESSP LENGTH 512) (replace (TFTPSTREAM LASTPACKETIN) of STREAM with T]) (\TFTP.OPENFILE [LAMBDA (FILENAME ACCESS RECOG PARAMETERS) (* ejs%: "15-Sep-85 17:48") (* * Open a file using TFTP) (LET* ((HOSTNAME (FILENAMEFIELD FILENAME 'HOST)) [DEVICE (COND ((DODIP.HOSTP HOSTNAME) (create FDEV using \TFTP.DEVICE DEVICENAME _ HOSTNAME)) (T (ERROR "Unknown IP host: " HOSTNAME] (STREAM (create STREAM DEVICE _ DEVICE)) [TFTPCON (replace (FDEV DEVICEINFO) of DEVICE with (create TFTPCON UDPSOCKET _ (UDP.OPEN.SOCKET) STREAM _ STREAM HOST _ (DODIP.HOSTP HOSTNAME] (UDP (\ALLOCATE.ETHERPACKET)) UDPIN) (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SOCKET) (AND RESETSTATE (UDP.CLOSE.SOCKET SOCKET T] (fetch (TFTPCON UDPSOCKET) of TFTPCON))) (replace (TFTPCON DESTSOCKET) of TFTPCON with \TFTP.SOCKET) (\TFTP.SETUP UDP TFTPCON (SELECTQ ACCESS (INPUT \TFTP.RRQ) (OUTPUT \TFTP.WRQ) (ERROR "ACCESS must be INPUT or OUTPUT" ACCESS))) (UDP.APPEND.STRING UDP (SUBATOM FILENAME (STRPOS '} FILENAME NIL NIL NIL T))) (UDP.APPEND.BYTE UDP 0) (UDP.APPEND.STRING UDP (COND ((EQ (CADR (FASSOC 'TYPE PARAMETERS)) 'BINARY) "OCTET") (T "NETASCII"))) (UDP.APPEND.BYTE UDP 0) (for I from 1 to \MAXETHERTRIES do (SETQ UDPIN (UDP.EXCHANGE (fetch (TFTPCON UDPSOCKET ) of TFTPCON) UDP)) until UDPIN finally (\RELEASE.ETHERPACKET UDP)) (COND [UDPIN (SELECTC (fetch (TFTP OPCODE) of UDPIN) (\TFTP.ACK (COND ((AND (EQ ACCESS 'OUTPUT) (EQ (fetch (TFTP BLOCK#) of UDPIN) 0)) (replace (TFTPSTREAM TFTPCON) of STREAM with TFTPCON) (replace (STREAM ACCESS) of STREAM with ACCESS) (replace (STREAM FULLFILENAME) of STREAM with FILENAME) (replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT) of UDPIN)) (\TFTP.SETUP UDPIN TFTPCON \TFTP.DATA NIL) (UDP.APPEND.WORD UDPIN 1) (add (fetch (UDP UDPLENGTH) of UDPIN) 512) (\TFTP.INPUT.BUFFER STREAM UDPIN) STREAM))) (\TFTP.DATA (COND ((AND (EQ ACCESS 'INPUT) (EQ (fetch (TFTP BLOCK#) of UDPIN) 1)) (replace (TFTPSTREAM TFTPCON) of STREAM with TFTPCON) (replace (STREAM ACCESS) of STREAM with ACCESS) (replace (STREAM FULLFILENAME) of STREAM with FILENAME ) (replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT) of UDPIN)) (\TFTP.INPUT.BUFFER STREAM UDPIN) (\TFTP.ACKNOWLEDGE STREAM 1) STREAM))) (\TFTP.ERROR (\TFTP.ERROR UDPIN)) (ERROR "Unknown TFTP opcode" (fetch (TFTP OPCODE) of UDPIN] (T (UDP.CLOSE.SOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON) T) NIL]) (\TFTP.READP [LAMBDA (STREAM) (* ejs%: " 9-Feb-85 20:48") (ILESSP (fetch (STREAM COFFSET) of STREAM) (fetch (STREAM CBUFSIZE) of STREAM]) (\TFTP.SEND.ERROR [LAMBDA (TFTPCON ERRORCODE ERRORSTRING) (* ejs%: " 1-Jun-85 15:34") (* * Send an error back to the requestor) (LET ((TFTP (\ALLOCATE.ETHERPACKET))) (\TFTP.SETUP TFTP TFTPCON \TFTP.ERROR NIL) (UDP.APPEND.WORD TFTP ERRORCODE) (UDP.APPEND.STRING TFTP ERRORSTRING) (UDP.APPEND.BYTE TFTP 0) (UDP.SEND (fetch (TFTPCON UDPSOCKET) of TFTPCON) TFTP]) (\TFTP.SETUP [LAMBDA (UDP TFTPCON OPCODE REQUEUE) (* ejs%: " 9-Feb-85 20:32") (UDP.SETUP UDP (fetch (TFTPCON HOST) of TFTPCON) (fetch (TFTPCON DESTSOCKET) of TFTPCON) 0 (fetch (TFTPCON UDPSOCKET) of TFTPCON)) (replace EPREQUEUE of UDP with REQUEUE) (UDP.APPEND.WORD UDP OPCODE]) ) (FILESLOAD (SYSLOAD) TCPUDP) (* ;; "TFTP Server functions") (RPAQ? \TFTP.SERVER.CONNECTIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TFTP.SERVER.CONNECTIONS) ) (DEFINEQ (TFTP.SERVER.PROCESS [LAMBDA (LOGSTREAM) (* ejs%: " 3-Jun-85 01:52") (* * A server for TFTP file transfer) (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS)) (LET* ((DEVICE (create FDEV using \TFTP.DEVICE DEVICENAME _ 'TFTPSERVER)) (SERVERSOCKET (UDP.OPEN.SOCKET \TFTP.SOCKET T)) CONNECTION) [COND ((NULL LOGSTREAM) (COND ((NOT (HASTTYWINDOWP)) (\CREATE.TTYDISPLAYSTREAM))) (SETQ LOGSTREAM (TTYDISPLAYSTREAM] (SETQ \TFTP.SERVER.CONNECTIONS NIL) (COND (SERVERSOCKET (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SOCKET) (UDP.CLOSE.SOCKET SOCKET T] SERVERSOCKET)) (while T do (LET ((UDP (UDP.GET SERVERSOCKET T))) (SETQ CONNECTION (CONS (fetch (IP IPSOURCEADDRESS) of UDP) (fetch (UDP UDPSOURCEPORT) of UDP))) (COND [(NOT (MEMBER CONNECTION \TFTP.SERVER.CONNECTIONS)) (push \TFTP.SERVER.CONNECTIONS CONNECTION) (SELECTC (fetch (TFTP OPCODE) of UDP) (\TFTP.RRQ (ADD.PROCESS `(\TFTP.SEND.FILE %, UDP (QUOTE %, (create TFTPCON UDPSOCKET _ (UDP.OPEN.SOCKET) )) %, DEVICE %, LOGSTREAM))) (\TFTP.WRQ (ADD.PROCESS `(\TFTP.GET.FILE %, UDP (QUOTE %, (create TFTPCON UDPSOCKET _ (UDP.OPEN.SOCKET) )) %, DEVICE %, LOGSTREAM))) (PROGN (printout LOGSTREAM "TFTP Server: Unexpected opcode " (fetch (TFTP OPCODE) of UDP) T) (SETQ \TFTP.SERVER.CONNECTIONS (DREMOVE CONNECTION \TFTP.SERVER.CONNECTIONS )) (\RELEASE.ETHERPACKET UDP] (T (* Duplicate request) (\RELEASE.ETHERPACKET UDP]) (\TFTP.GET.FILE [LAMBDA (UDP TFTPCON DEVICE LOGSTREAM) (* ; "Edited 14-Apr-87 20:19 by FS") (* ;; "Try to start receiving a file from the requestor as directed by the contents of the received UDP packet") (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS)) (LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP) I)) finally (RETURN (IDIFFERENCE I BYTESPERWORD] (FILENAME (ALLOCSTRING FILENAMELENGTH)) [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1) until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP) I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD FILENAMELENGTH 1] (MODE (ALLOCSTRING MODELENGTH)) (HOST (fetch (IP IPSOURCEADDRESS) of UDP)) FILE TYPE TFTPSTREAM RESULT) (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (TFTPCON) (LET* [(UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)) (CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON) (fetch (TFTPCON DESTSOCKET ) of TFTPCON] (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS)) (AND RESETSTATE (UDP.CLOSE.SOCKET UDPSOCKET T] TFTPCON)) (replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT) of UDP)) (replace (TFTPCON HOST) of TFTPCON with HOST) (* ;; "Read the filename out of the packet") (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP) BYTESPERWORD (fetch (STRINGP BASE) of FILENAME) (fetch (STRINGP OFFST) of FILENAME) FILENAMELENGTH) (* ;; "Read the mode out of the packet") (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP) (IPLUS BYTESPERWORD FILENAMELENGTH 1) (fetch (STRINGP BASE) of MODE) (fetch (STRINGP OFFST) of MODE) MODELENGTH) (SETQ MODE (U-CASE MODE)) (printout LOGSTREAM "TFTP Server: Will attempt to receive " FILENAME " in " MODE " mode from host " (\IP.ADDRESS.TO.STRING HOST) T) (SETQ RESULT (COND [[AND (SETQ TYPE (COND ((STREQUAL MODE "NETASCII") 'TEXT) ((STREQUAL MODE "OCTET") 'BINARY) (T (\TFTP.SEND.ERROR TFTPCON 0 (CONCAT "Unknown transfer type--" MODE)) NIL))) (SETQ FILE (LET [(OUTSTREAM (CAR (NLSETQ (OPENSTREAM FILENAME 'OUTPUT 'NEW (LIST (LIST 'TYPE TYPE] (COND ((NULL OUTSTREAM) (\TFTP.SEND.ERROR TFTPCON 1 (CONCAT "Can't open file--" FILENAME)) NIL) (T OUTSTREAM] (* ;; "Mode is OK, and file is open for input. Open the TFTP stream back to the requestor") (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FILE) (COND (RESETSTATE (CLOSEF? FILE) (DELFILE (FULLNAME FILE] FILE)) (SETQ TFTPSTREAM (create STREAM DEVICE _ DEVICE)) (replace (TFTPCON STREAM) of TFTPCON with TFTPSTREAM) (replace (STREAM ACCESS) of TFTPSTREAM with 'INPUT) (replace (TFTPSTREAM TFTPCON) of TFTPSTREAM with TFTPCON) (* ;; "Send the first acknowledgement") (\TFTP.ACKNOWLEDGE TFTPSTREAM 0) (\RELEASE.ETHERPACKET UDP) (printout LOGSTREAM "TFTP Server: receiving " (FULLNAME FILE) T) (COND ((NLSETQ (COPYBYTES TFTPSTREAM FILE)) (printout LOGSTREAM "TFTP Server: Done receiving " (FULLNAME FILE) T) (CLOSEF? FILE)) (T (printout LOGSTREAM "TFTP Server: Failed to receive " (FULLNAME FILE) T) (DELFILE (FULLNAME (CLOSEF? FILE] (T (printout LOGSTREAM "TFTP Server: Failed to receive " (FULLNAME FILE) T) (\RELEASE.ETHERPACKET UDP) NIL))) (* ;; "Remove connection from list.") (LET (UDPSOCKET CONNECTION) (SETQ UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)) (SETQ CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON) (fetch (UDP UDPDESTPORT) of UDPSOCKET))) (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS))) RESULT]) (\TFTP.SEND.FILE [LAMBDA (UDP TFTPCON DEVICE LOGSTREAM) (* ; "Edited 30-Jun-87 22:12 by scp") (* ;; "Try to start sending a file to the requestor as directed by the contents of the received UDP packet") (DECLARE (GLOBALVARS \TFTP.SERVER.CONNECTIONS)) (LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP) I)) finally (RETURN (IDIFFERENCE I BYTESPERWORD] (FILENAME (ALLOCSTRING FILENAMELENGTH)) [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1) until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of UDP) I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD FILENAMELENGTH 1] (MODE (ALLOCSTRING MODELENGTH)) (HOST (fetch (IP IPSOURCEADDRESS) of UDP)) FILE TYPE TFTPSTREAM RESULT) (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (TFTPCON) (LET* [(UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)) (CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON) (fetch (TFTPCON DESTSOCKET) of TFTPCON] (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS )) (AND RESETSTATE (UDP.CLOSE.SOCKET UDPSOCKET T] TFTPCON)) (replace (TFTPCON DESTSOCKET) of TFTPCON with (fetch (UDP UDPSOURCEPORT) of UDP)) (replace (TFTPCON HOST) of TFTPCON with HOST) (* ;; "Read the filename out of the packet") (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP) BYTESPERWORD (fetch (STRINGP BASE) of FILENAME) (fetch (STRINGP OFFST) of FILENAME) FILENAMELENGTH) (* ;; "Read the mode out of the packet") (\MOVEBYTES (fetch (TFTP TFTPBASE) of UDP) (IPLUS BYTESPERWORD FILENAMELENGTH 1) (fetch (STRINGP BASE) of MODE) (fetch (STRINGP OFFST) of MODE) MODELENGTH) (SETQ MODE (U-CASE MODE)) (printout LOGSTREAM "TFTP Server: Will attempt to send " FILENAME " in " MODE " mode to host " (\IP.ADDRESS.TO.STRING HOST) T) (SETQ RESULT (COND ([AND (SETQ TYPE (COND ((STREQUAL MODE "NETASCII") 'TEXT) ((STREQUAL MODE "OCTET") 'BINARY) (T (\TFTP.SEND.ERROR TFTPCON 0 (CONCAT "Unknown transfer type--" MODE)) NIL))) (SETQ FILE (LET* [(FULLFILENAME (INFILEP FILENAME)) (INSTREAM (AND FULLFILENAME (CAR (NLSETQ (OPENSTREAM FULLFILENAME 'INPUT 'OLD (LIST (LIST 'TYPE TYPE] (COND ((NULL INSTREAM) (\TFTP.SEND.ERROR TFTPCON 1 (CONCAT "Can't open file--" FILENAME)) NIL) (T INSTREAM] (* ;; "Mode is OK, and file is open for input. Open the TFTP stream back to the requestor") (SETQ TFTPSTREAM (create STREAM DEVICE _ DEVICE)) (replace (TFTPCON STREAM) of TFTPCON with TFTPSTREAM) (replace (STREAM ACCESS) of TFTPSTREAM with 'OUTPUT) (replace (TFTPSTREAM TFTPCON) of TFTPSTREAM with TFTPCON) (* ;; "Use the incoming packet as the first data packet on the way out") (\TFTP.SETUP UDP TFTPCON \TFTP.DATA NIL) (* ;; "This is block number 1") (UDP.APPEND.WORD UDP 1) (add (fetch (UDP UDPLENGTH) of UDP) 512) (\TFTP.INPUT.BUFFER TFTPSTREAM UDP) (printout LOGSTREAM "TFTP Server: Sending " FILENAME T) (COND ((NLSETQ (PROGN (COPYBYTES FILE TFTPSTREAM) (\TFTP.GETNEXTBUFFER TFTPSTREAM 'WRITE T) (\TFTP.CLOSEFILE TFTPSTREAM))) (printout LOGSTREAM "TFTP Server: Done sending " FILENAME T)) (T (printout LOGSTREAM "TFTP Server: Failed to send " FILENAME T))) (CLOSEF? FILE)) (T (printout LOGSTREAM "TFTP Server: Failed to send " FILENAME T) (\RELEASE.ETHERPACKET UDP) NIL))) (* ;; "Remove connection from list.") (LET (UDPSOCKET CONNECTION) (SETQ UDPSOCKET (fetch (TFTPCON UDPSOCKET) of TFTPCON)) (SETQ CONNECTION (CONS (fetch (TFTPCON HOST) of TFTPCON) (fetch (UDP UDPDESTPORT) of UDPSOCKET))) (SETQ \TFTP.SERVER.CONNECTIONS (REMOVE CONNECTION \TFTP.SERVER.CONNECTIONS))) RESULT]) ) (* ;; "User functions") (DEFINEQ (TFTP.SERVER [LAMBDA (LOGSTREAM) (* MPL " 2-Jun-85 19:39") (* * Create a new TFTP server. LOGSTREAM defaults to a popup window) (ADD.PROCESS `(TFTP.SERVER.PROCESS %, LOGSTREAM) 'RESTARTABLE 'HARDRESET]) (TFTP.GET [LAMBDA (FROM TO PARAMETERS) (* MPL " 2-Jun-85 17:15") (LET ((EOLCONVENTION (CADR (FASSOC 'EOLCONVENTION PARAMETERS))) (TYPE (FASSOC 'TYPE PARAMETERS)) (FROMNAME FROM) (TONAME TO)) (RESETLST [SETQ TO (OPENSTREAM TO 'OUTPUT 'NEW NIL (COND (TYPE (LIST TYPE] (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM) (COND ((AND STREAM RESETSTATE) (CLOSEF? STREAM) (DELFILE (FULLNAME STREAM] TO)) (SETQ FROM (\TFTP.OPENFILE FROM 'INPUT 'OLD PARAMETERS)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM) (AND STREAM RESETSTATE (CLOSEF STREAM] FROM)) (COND (EOLCONVENTION (replace (STREAM EOLCONVENTION) of FROM with EOLCONVENTION))) (COND ((AND FROM TO) (COPYCHARS FROM TO) (AND (OPENP FROM) (CLOSEF FROM)) (FULLNAME (CLOSEF TO))) (TO (ERRORX (LIST 9 FROMNAME))) (FROM (ERRORX (LIST 9 TONAME]) (TFTP.PUT [LAMBDA (FROM TO PARAMETERS) (* ; "Edited 15-Apr-87 20:55 by FS") (LET ((EOLCONVENTION (CADR (FASSOC 'EOLCONVENTION PARAMETERS))) (TYPE (FASSOC 'TYPE PARAMETERS))) (* ;; "Why is TYPE not used anywhere?") (RESETLST (SETQ FROM (OPENSTREAM FROM 'INPUT 'OLD)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM) (AND RESETSTATE (CLOSEF STREAM] FROM)) (SETQ TO (\TFTP.OPENFILE TO 'OUTPUT 'NEW PARAMETERS)) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM) (AND RESETSTATE (CLOSEF STREAM] TO)) (COND (EOLCONVENTION (replace (STREAM EOLCONVENTION) of TO with EOLCONVENTION))) (COPYCHARS FROM TO) (CLOSEF FROM) (* ;; "Removed (FULLNAME (CLOSEF TO))") (CLOSEF TO]) ) (* ;; "Tracing functions") (DEFINEQ (PRINTTFTP [LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 14:00") (DECLARE (GLOBALVARS TFTPOPCODES)) (PRINTCONSTANT (fetch (TFTP OPCODE) of TFTP) TFTPOPCODES FILE "TFTP Opcode: ") (SELECTC (fetch (TFTP OPCODE) of TFTP) (\TFTP.RRQ (printout FILE " ") (\TFTP.PRINT.REQUEST TFTP FILE)) (\TFTP.WRQ (printout FILE " ") (\TFTP.PRINT.REQUEST TFTP FILE)) (\TFTP.ACK (printout FILE " ") (\TFTP.PRINT.ACK TFTP FILE)) (\TFTP.DATA (printout FILE " ") (\TFTP.PRINT.DATA TFTP FILE)) (\TFTP.ERROR (printout FILE " ") (\TFTP.PRINT.ERROR TFTP FILE)) NIL) (TERPRI FILE) (TERPRI FILE]) (\TFTP.PRINT.ACK [LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 12:48") (printout FILE "Block #: " (fetch (TFTP BLOCK#) of TFTP) T]) (\TFTP.PRINT.DATA [LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 14:00") (printout FILE "Block #: " (fetch (TFTP BLOCK#) of TFTP) T) (PRINTPACKETDATA (fetch (TFTP TFTPCONTENTS) of TFTP) \TFTPOVLEN '(CHARS 12 |...|) (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP) (CONSTANT (IPLUS \TFTPOVLEN \UDPOVLEN]) (\TFTP.PRINT.ERROR [LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 13:15") (printout FILE "Error code: " (fetch (TFTP ERRORCODE) of TFTP) T) (PRINTPACKETDATA (fetch (TFTP TFTPCONTENTS) of TFTP) 0 '(CHARS |...|) (IDIFFERENCE (fetch (UDP UDPLENGTH) of TFTP) (CONSTANT (IPLUS \UDPOVLEN \TFTPOVLEN))) FILE]) (\TFTP.PRINT.REQUEST [LAMBDA (TFTP FILE) (* ejs%: " 2-Jun-85 13:16") (* * Try to start sending a file to the requestor as directed by the contents  of the received TFTP packet) (LET* ([FILENAMELENGTH (for I from BYTESPERWORD until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of TFTP) I)) finally (RETURN (IDIFFERENCE I BYTESPERWORD] (FILENAME (ALLOCSTRING FILENAMELENGTH)) [MODELENGTH (for I from (IPLUS BYTESPERWORD FILENAMELENGTH 1) until (EQ 0 (\GETBASEBYTE (fetch (TFTP TFTPBASE) of TFTP) I)) finally (RETURN (IDIFFERENCE I (IPLUS BYTESPERWORD FILENAMELENGTH 1] (MODE (ALLOCSTRING MODELENGTH))) (* * Read the filename out of the packet) (\MOVEBYTES (fetch (TFTP TFTPBASE) of TFTP) BYTESPERWORD (fetch (STRINGP BASE) of FILENAME) (fetch (STRINGP OFFST) of FILENAME) FILENAMELENGTH) (* * Read the mode out of the packet) (\MOVEBYTES (fetch (TFTP TFTPBASE) of TFTP) (IPLUS BYTESPERWORD FILENAMELENGTH 1) (fetch (STRINGP BASE) of MODE) (fetch (STRINGP OFFST) of MODE) MODELENGTH) (printout FILE (SELECTC (fetch (TFTP OPCODE) of TFTP) (\TFTP.RRQ "Read request for ") (\TFTP.WRQ "Write request for ") (SHOULDNT)) FILENAME " in mode " MODE T]) ) (\TFTP.INIT) (PUTPROPS TCPTFTP COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3785 28418 (\TFTP.ACKNOWLEDGE 3795 . 4474) (\TFTP.CLOSEFILE 4476 . 5171) (\TFTP.EOFP 5173 . 5530) (\TFTP.ERROR 5532 . 6308) (\TFTP.GETNEXTBUFFER 6310 . 19593) (\TFTP.INIT 19595 . 20684) ( \TFTP.INPUT.BUFFER 20686 . 21902) (\TFTP.OPENFILE 21904 . 27296) (\TFTP.READP 27298 . 27522) ( \TFTP.SEND.ERROR 27524 . 28019) (\TFTP.SETUP 28021 . 28416)) (28610 46223 (TFTP.SERVER.PROCESS 28620 . 31874) (\TFTP.GET.FILE 31876 . 39527) (\TFTP.SEND.FILE 39529 . 46221)) (46256 49207 (TFTP.SERVER 46266 . 46555) (TFTP.GET 46557 . 48098) (TFTP.PUT 48100 . 49205)) (49243 53309 (PRINTTFTP 49253 . 50082) (\TFTP.PRINT.ACK 50084 . 50285) (\TFTP.PRINT.DATA 50287 . 50726) (\TFTP.PRINT.ERROR 50728 . 51181) (\TFTP.PRINT.REQUEST 51183 . 53307))))) STOP \ No newline at end of file diff --git a/obsolete/tcp/TCPUDP b/obsolete/tcp/TCPUDP deleted file mode 100644 index 9f0f5b90..00000000 --- a/obsolete/tcp/TCPUDP +++ /dev/null @@ -1 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "12-Jun-90 17:46:11" {DSK}local>lde>lispcore>library>TCPUDP.;2 11429 changes to%: (VARS TCPUDPCOMS) previous date%: " 6-Jan-89 16:37:55" {DSK}local>lde>lispcore>library>TCPUDP.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TCPUDPCOMS) (RPAQQ TCPUDPCOMS [(COMS (* ;; "User Datagram Protocol --- Definitions") [DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS UDP) (CONSTANTS (\UDPOVLEN 8] (FILES (SYSLOAD) TCPLLIP)) (COMS (* ;; "Internal functions") (FNS UDP.GET.BYTE UDP.GET.CELL UDP.GET.STRING UDP.GET.WORD \UDP.FLUSH.SOCKET.QUEUE \UDP.PORTCOMPARE \UDP.CHECKSUM \UDP.SET.CHECKSUM) (FNS \UDP.HANDLE.ICMP)) (COMS (* ;; "External functions") (FNS PRINTUDP UDP.INIT UDP.STOP UDP.OPEN.SOCKET UDP.CLOSE.SOCKET UDP.SOCKET.EVENT UDP.SOCKET.NUMBER UDP.GET UDP.SEND UDP.EXCHANGE UDP.SETUP UDP.APPEND.BYTE UDP.APPEND.CELL UDP.APPEND.STRING UDP.APPEND.WORD UDP.INCREMENT.LENGTH) (ADDVARS (IPPRINTMACROS (17 . PRINTUDP))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? 'NILL 'PRINTRPCDATA) (UDP.INIT]) (* ;; "User Datagram Protocol --- Definitions") (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (ACCESSFNS UDP ((UDPBASE (\IPDATABASE DATUM))) (BLOCKRECORD UDPBASE ((UDPSOURCEPORT WORD) (UDPDESTPORT WORD) (UDPLENGTH WORD) (UDPCHECKSUM WORD))) [ACCESSFNS UDP ((UDPCONTENTS (\ADDBASE (\IPDATABASE DATUM) (FOLDHI \UDPOVLEN BYTESPERWORD]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \UDPOVLEN 8) (CONSTANTS (\UDPOVLEN 8)) ) (* "END EXPORTED DEFINITIONS") ) (FILESLOAD (SYSLOAD) TCPLLIP) (* ;; "Internal functions") (DEFINEQ (UDP.GET.BYTE (LAMBDA (UDP BYTE#) (* ejs%: "25-Jun-85 21:04") (* * Return a byte from the UDP data area) (COND ((AND (IGEQ BYTE# 0) (ILESSP BYTE# (fetch (UDP UDPLENGTH) of UDP))) (\GETBASEBYTE (fetch (UDP UDPCONTENTS) of UDP) BYTE#)))) ) (UDP.GET.CELL (LAMBDA (UDP CELL#) (* ejs%: "25-Jun-85 21:09") (* * Return a cell from the UDP data area) (COND ((AND (IGEQ CELL# 0) (ILESSP CELL# (FOLDLO (fetch (UDP UDPLENGTH) of UDP) BYTESPERCELL))) (\MAKENUMBER (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) (UNFOLD CELL# WORDSPERCELL)) (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) (ADD1 (UNFOLD CELL# WORDSPERCELL))))))) ) (UDP.GET.STRING (LAMBDA (UDP OFFSET) (* ejs%: "25-Jun-85 21:12") (* * Fetch a string out of the UDP packet) (OR (SMALLP OFFSET) (SETQ OFFSET 0)) (LET* ((LENGTH (IDIFFERENCE (fetch (UDP UDPLENGTH) of UDP) OFFSET)) (STRING (ALLOCSTRING LENGTH))) (\MOVEBYTES (fetch (UDP UDPCONTENTS) of UDP) OFFSET (fetch (STRINGP BASE) of STRING) (fetch (STRINGP OFFST) of STRING) LENGTH) STRING)) ) (UDP.GET.WORD (LAMBDA (UDP WORD#) (* ejs%: "25-Jun-85 21:06") (* * Return a word from the UDP data area) (COND ((AND (IGEQ WORD# 0) (ILESSP WORD# (FOLDLO (fetch (UDP UDPLENGTH) of UDP) BYTESPERWORD))) (\GETBASE (fetch (UDP UDPCONTENTS) of UDP) WORD#)))) ) (\UDP.FLUSH.SOCKET.QUEUE (LAMBDA (IPSOCKET) (* ; "Edited 25-Aug-88 12:57 by bvm") (* ;;; "Called to flush input packet queue on an IPSOCKET") (LET ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) PACKET) (UNINTERRUPTABLY (while (SETQ PACKET (\DEQUEUE QUEUE)) do (\RELEASE.ETHERPACKET PACKET) finally (replace (IPSOCKET IPSQUEUELENGTH) of IPSOCKET with 0))))) ) (\UDP.PORTCOMPARE (LAMBDA (UDP IPSOCKET) (* ejs%: " 9-Feb-85 14:37") (* * Compare IPSOCKET until we find the one this UDP was destined for) (EQ (fetch (UDP UDPDESTPORT) of UDP) (fetch (IPSOCKET IPSOCKET) of IPSOCKET))) ) (\UDP.CHECKSUM (LAMBDA (UDP ZeroCheckSumIsOK) (* HAS%: "19-Aug-86 16:47") (* * Compute the UDP checksum for the packet UDP. The packet is assumed to have been setup by UDP.SETUP so that source and destination addresses, protocol, and UDP length have already been set.) (COND ((AND ZeroCheckSumIsOK (EQ (fetch (UDP UDPCHECKSUM) of UDP) 0)) (* * BSD Unix strikes again!) 0) (T (LET ((SOURCE (fetch (IP IPSOURCEADDRESS) of UDP)) (DEST (fetch (IP IPDESTINATIONADDRESS) of UDP)) (LENGTH (fetch (UDP UDPLENGTH) of UDP)) CHECKSUM) (SETQ CHECKSUM (IPLUS (bind (BASE _ (LOCF (fetch (IP IPSOURCEADDRESS) of UDP))) for I from 0 to (CONSTANT (SUB1 (TIMES 2 WORDSPERCELL))) sum (\GETBASE BASE I)) (ffetch (IP IPPROTOCOL) of UDP) LENGTH (\IPCHECKSUM UDP (\IPDATABASE UDP) LENGTH))) (SETQ CHECKSUM (IPLUS (LDB (BYTE 16 16) CHECKSUM) (LDB (BYTE 16 0) CHECKSUM))) (COND ((NOT (EQ (LDB (BYTE 16 16) CHECKSUM) 0)) (SETQ CHECKSUM (IPLUS (LDB (BYTE 16 16) CHECKSUM) (LDB (BYTE 16 0) CHECKSUM))))) CHECKSUM)))) ) (\UDP.SET.CHECKSUM (LAMBDA (UDP) (* ejs%: " 3-Jun-85 00:19") (* * Called to set the UDP checksum in a packet ready to be transmitted) (LET (CHECKSUM) (replace (UDP UDPCHECKSUM) of UDP with 0) (SETQ CHECKSUM (\UDP.CHECKSUM UDP)) (replace (UDP UDPCHECKSUM) of UDP with (COND ((NEQ CHECKSUM MAX.SMALLP) (LOGAND (LOGNOT CHECKSUM) (CONSTANT (MASK.1'S 0 16)))) (T MAX.SMALLP))))) ) ) (DEFINEQ (\UDP.HANDLE.ICMP (LAMBDA (ICMP SENTIP PROTOCOL) (* ; "Edited 13-Sep-88 14:26 by bvm") (* ;; "Handle an ICMP packet sent to a UDP socket. We allow each UDP client to decide how to handle these.") (LET ((SOCKET (\IP.FIND.SOCKET (ffetch (UDP UDPSOURCEPORT) of SENTIP) PROTOCOL)) FN) (if (OR (NULL SOCKET) (EQ (SETQ FN (ffetch (IPSOCKET IPSICMPFN) of SOCKET)) (QUOTE \UDP.HANDLE.ICMP))) then (* ; "Sender went away already, or else didn't specify a handler (so inherited the default)") (\RELEASE.ETHERPACKET ICMP) else (CL:FUNCALL FN ICMP SENTIP SOCKET)))) ) ) (* ;; "External functions") (DEFINEQ (PRINTUDP (LAMBDA (UDP FILE) (* ; "Edited 6-Jan-89 16:18 by Briggs") (printout FILE "UDP Source port: " (fetch (UDP UDPSOURCEPORT) of UDP) " Dest port: " (fetch (UDP UDPDESTPORT) of UDP) T "Length: " (fetch (UDP UDPLENGTH) of UDP) " Checksum: " (fetch (UDP UDPCHECKSUM) of UDP) T) (COND ((OR (EQ (fetch (UDP UDPDESTPORT) of UDP) \TFTP.SOCKET) (EQ (fetch (UDP UDPSOURCEPORT) of UDP) \TFTP.SOCKET)) (PRINTTFTP UDP FILE)) (T (PRINTRPCDATA (fetch (UDP UDPCONTENTS) of UDP) (- (fetch (UDP UDPLENGTH) of UDP) \UDPOVLEN) FILE)))) ) (UDP.INIT (LAMBDA NIL (* ; "Edited 25-Aug-88 12:54 by bvm") (COND ((OR \IPFLG (SELECTQ (ASKUSER 15 (QUOTE Y) "IP is not running. Shall I attempt to initialize it? ") (Y (\IPINIT) \IPFLG) NIL)) (\IP.ADD.PROTOCOL \UDP.PROTOCOL (FUNCTION \UDP.PORTCOMPARE) NIL NIL (FUNCTION \UDP.HANDLE.ICMP))))) ) (UDP.STOP (LAMBDA NIL (* ejs%: " 9-Feb-85 14:43") (\IP.DELETE.PROTOCOL \UDP.PROTOCOL))) (UDP.OPEN.SOCKET (LAMBDA (SKT# IFCLASH ICMPFN) (* ; "Edited 25-Aug-88 13:03 by bvm") (LET ((UDPCHAIN (\IP.FIND.PROTOCOL \UDP.PROTOCOL))) (if (OR UDPCHAIN (SETQ UDPCHAIN (UDP.INIT))) then (if (NULL SKT#) then (* ; "Open any free socket") (\IP.OPEN.SOCKET \UDP.PROTOCOL NIL NIL NIL NIL NIL ICMPFN) else (* ; "Check for clash") (LET ((IPSOCKET (\IP.FIND.SOCKET SKT# UDPCHAIN))) (if (NULL IPSOCKET) then (\IP.OPEN.SOCKET \UDP.PROTOCOL SKT# NIL NIL NIL NIL ICMPFN) else (SELECTQ IFCLASH ((T ACCEPT) (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) IPSOCKET) ((DON'T FAIL) NIL) (ERROR "UDP Port is already in use" SKT#))))) else (* ; "IP not inited") (SELECTQ IFCLASH ((DON'T FAIL) NIL) (ERROR!))))) ) (UDP.CLOSE.SOCKET (LAMBDA (IPSOCKET NOERRORFLG) (* ejs%: " 9-Feb-85 15:00") (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) (\IP.CLOSE.SOCKET (fetch (IPSOCKET IPSOCKET) of IPSOCKET) \UDP.PROTOCOL NOERRORFLG)) ) (UDP.SOCKET.EVENT (LAMBDA (IPSOCKET) (* ejs%: " 9-Feb-85 15:07") (fetch (IPSOCKET IPSEVENT) of IPSOCKET))) (UDP.SOCKET.NUMBER (LAMBDA (IPSOCKET) (* ejs%: " 9-Feb-85 15:08") (fetch (IPSOCKET IPSOCKET) of IPSOCKET))) (UDP.GET (LAMBDA (IPSOCKET WAIT) (* ; "Edited 13-Sep-88 11:59 by bvm") (* ;;; "Returns the next UDP packet on the queue, or NIL if none exist and WAIT is NIL. If WAIT is T, this function waits forever. If WAIT is an integer, it is interpreted as the number of milliseconds to wait before returning NIL or a packet which arrives during that time. This function therefore is like GETXIP and GETPUP") (PROG ((QUEUE (fetch (IPSOCKET IPSQUEUE) of IPSOCKET)) UDP TIMER) LP (UNINTERRUPTABLY (COND ((SETQ UDP (\DEQUEUE QUEUE)) (add (fetch (IPSOCKET IPSQUEUELENGTH) of IPSOCKET) -1)))) (COND ((NULL UDP) (COND (WAIT (COND ((EQ WAIT T) (* ; "Wait forever")) (TIMER (COND ((TIMEREXPIRED? TIMER) (RETURN)))) (T (OR (FIXP WAIT) (LISPERROR "NON-NUMERIC ARG" WAIT)) (SETQ TIMER (SETUPTIMER WAIT)) T)) (AWAIT.EVENT (fetch (IPSOCKET IPSEVENT) of IPSOCKET) TIMER T) (GO LP)) (T (BLOCK)))) ((AND (EQ (fetch (IP IPPROTOCOL) of UDP) \UDP.PROTOCOL) (NEQ (fetch (UDP UDPCHECKSUM) of UDP) 0) (NOT (\IP.CHECKSUM.OK (\UDP.CHECKSUM UDP)))) (* ; "Bad checksum on UDP packet. Any other kind of packet must have been put there by someone else") (\RELEASE.ETHERPACKET UDP) (GO LP))) (RETURN UDP))) ) (UDP.SEND (LAMBDA (IPSOCKET UDP) (* ejs%: " 9-Feb-85 15:24") (* * Sends a UDP packet. IP and UDP header assumed set up by UDP.SETUP and \IP.SETUPIP) (\UDP.SET.CHECKSUM UDP) (\IP.TRANSMIT UDP)) ) (UDP.EXCHANGE (LAMBDA (IPSOCKET OUTUDP TIMEOUT) (* ejs%: " 9-Feb-85 22:28") (* * Send a UDP packet and wait for TIMEOUT to receive a packet (TIMEOUT defaults to \ETHERTIMEOUT)) (\UDP.FLUSH.SOCKET.QUEUE IPSOCKET) (UDP.SEND IPSOCKET OUTUDP) (BLOCK) (UDP.GET IPSOCKET (OR (FIXP TIMEOUT) \ETHERTIMEOUT))) ) (UDP.SETUP (LAMBDA (UDP DESTHOST DESTSOCKET ID IPSOCKET REQUEUE) (* ejs%: " 9-Feb-85 16:04") (\IP.SETUPIP UDP DESTHOST ID IPSOCKET REQUEUE) (add (fetch (IP IPTOTALLENGTH) of UDP) \UDPOVLEN) (AND (SMALLP DESTSOCKET) (replace (UDP UDPDESTPORT) of UDP with DESTSOCKET)) (replace (UDP UDPSOURCEPORT) of UDP with (fetch (IPSOCKET IPSOCKET) of IPSOCKET)) (replace (UDP UDPLENGTH) of UDP with \UDPOVLEN) UDP) ) (UDP.APPEND.BYTE (LAMBDA (UDP BYTE) (* ejs%: " 9-Feb-85 16:07") (\IP.APPEND.BYTE UDP BYTE) (add (fetch (UDP UDPLENGTH) of UDP) 1)) ) (UDP.APPEND.CELL (LAMBDA (UDP CELL) (* ejs%: " 9-Feb-85 16:06") (\IP.APPEND.CELL UDP CELL) (add (fetch (UDP UDPLENGTH) of UDP) BYTESPERCELL)) ) (UDP.APPEND.STRING (LAMBDA (UDP STRING) (* ejs%: " 9-Feb-85 16:10") (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (\IP.APPEND.STRING UDP STRING) (add (fetch (UDP UDPLENGTH) of UDP) (NCHARS STRING))) ) (UDP.APPEND.WORD (LAMBDA (UDP WORD) (* ejs%: " 9-Feb-85 16:07") (\IP.APPEND.WORD UDP WORD) (add (fetch (UDP UDPLENGTH) of UDP) WORDSPERCELL)) ) (UDP.INCREMENT.LENGTH (LAMBDA (UDP INCREMENT) (* ejs%: "12-Apr-86 18:50") (add (fetch (IP IPTOTALLENGTH) of UDP) INCREMENT) (add (fetch (UDP UDPLENGTH) of UDP) INCREMENT) INCREMENT) ) ) (ADDTOVAR IPPRINTMACROS (17 . PRINTUDP)) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD? 'NILL 'PRINTRPCDATA) (UDP.INIT) ) (PUTPROPS TCPUDP COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2357 5603 (UDP.GET.BYTE 2367 . 2608) (UDP.GET.CELL 2610 . 2984) (UDP.GET.STRING 2986 . 3371) (UDP.GET.WORD 3373 . 3632) (\UDP.FLUSH.SOCKET.QUEUE 3634 . 3998) (\UDP.PORTCOMPARE 4000 . 4224) (\UDP.CHECKSUM 4226 . 5220) (\UDP.SET.CHECKSUM 5222 . 5601)) (5604 6176 (\UDP.HANDLE.ICMP 5614 . 6174) ) (6213 11197 (PRINTUDP 6223 . 6752) (UDP.INIT 6754 . 7053) (UDP.STOP 7055 . 7146) (UDP.OPEN.SOCKET 7148 . 7833) (UDP.CLOSE.SOCKET 7835 . 8036) (UDP.SOCKET.EVENT 8038 . 8148) (UDP.SOCKET.NUMBER 8150 . 8261) (UDP.GET 8263 . 9439) (UDP.SEND 9441 . 9639) (UDP.EXCHANGE 9641 . 9947) (UDP.SETUP 9949 . 10356) (UDP.APPEND.BYTE 10358 . 10494) (UDP.APPEND.CELL 10496 . 10643) (UDP.APPEND.STRING 10645 . 10857) ( UDP.APPEND.WORD 10859 . 11006) (UDP.INCREMENT.LENGTH 11008 . 11195))))) STOP \ No newline at end of file diff --git a/scripts/loadups/loadup-init.sh b/scripts/loadups/loadup-init.sh index c1d5b75e..8c007bed 100755 --- a/scripts/loadups/loadup-init.sh +++ b/scripts/loadups/loadup-init.sh @@ -8,6 +8,7 @@ main() { cmfile="-" cat >"${initfile}" <<-"EOF" + (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) (* "make init files; this file is loaded as a 'greet' file by scripts/loadup-init.sh") (SETQ MEDLEYDIR NIL) diff --git a/sources/ADIR b/sources/ADIR index 5dc4d1ab..43bdab1a 100644 --- a/sources/ADIR +++ b/sources/ADIR @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "15-Oct-2025 15:20:48" {WMEDLEY}ADIR.;62 70135 +(FILECREATED " 5-Feb-2026 10:27:45" {WMEDLEY}ADIR.;67 70247 :EDIT-BY rmk - :CHANGES-TO (MACROS \UPF.EXTRACT) + :CHANGES-TO (FNS INTERPRET.REM.CM) - :PREVIOUS-DATE " 6-Feb-2025 17:48:54" {WMEDLEY}ADIR.;61) + :PREVIOUS-DATE " 1-Feb-2026 13:17:10" {WMEDLEY}ADIR.;66) (PRETTYCOMPRINT ADIRCOMS) @@ -1179,7 +1179,8 @@ HERALDSTRING]) (INTERPRET.REM.CM - [LAMBDA (RETFLG) (* ; "Edited 15-Mar-2021 12:27 by larry") + [LAMBDA (RETFLG) (* ; "Edited 1-Feb-2026 17:49 by rmk") + (* ; "Edited 15-Mar-2021 12:27 by larry") (DECLARE (GLOBALVARS STARTUPFORM)) (* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote. If it's a string, it will be unread,, else the form will be evaluated at the next prompt. For use in INIT.LISP, among others. If RETFLG is true, the expression read is simply returned") @@ -1187,23 +1188,22 @@ (PROG ([FILE (INFILEP (PACKFILENAME 'HOST '{DSK} 'BODY (UNIX-GETENV "LDEREMCM"] COM) (OR FILE (RETURN)) - (SETQ FILE (OPENSTREAM FILE 'INPUT)) + [SETQ FILE (OPENSTREAM FILE 'INPUT 'OLD '((:EXTERNAL-FORMAT :UTF-8] (COND - [[AND (IGREATERP (GETFILEINFO FILE 'LENGTH) + ([AND (IGREATERP (GETFILEINFO FILE 'LENGTH) 0) (EQ (SKIPSEPRS FILE T) '%") (SETQ COM (CAR (NLSETQ (READ FILE T] (CLOSEF FILE) - (COND - (RETFLG (* ; "Save it to return")) - (T (* ; "Unread a string") + (CL:UNLESS RETFLG (* ; + "Save it to return; otherwise unread a string") (* ;  "RMK: Replace CR and LF by space to avoid EOL convention issues") - (for I from 1 to (NCHARS COM) when (FMEMB (NTHCHARCODE COM I) - (CHARCODE (CR LF EOL))) - do (RPLCHARCODE COM I (CHARCODE EOL))) - (BKSYSBUF COM] + (for I from 1 to (NCHARS COM) when (FMEMB (NTHCHARCODE COM I) + (CHARCODE (CR LF EOL))) + do (RPLCHARCODE COM I (CHARCODE EOL))) + (BKSYSBUF COM))) (T (CLOSEF FILE))) (RETURN (COND (RETFLG COM) @@ -1282,14 +1282,14 @@ (ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3170 15997 (DELFILE 3180 . 3341) (FULLNAME 3343 . 3710) (INFILE 3712 . 3971) (INFILEP -3973 . 4108) (IOFILE 4110 . 4361) (OPENFILE 4363 . 4666) (OPENSTREAM 4668 . 9008) (OUTFILE 9010 . 9272 -) (OUTFILEP 9274 . 9410) (RENAMEFILE 9412 . 9718) (SIMPLE.FINDFILE 9720 . 10130) (VMEMSIZE 10132 . -10299) (\COPYSYS 10301 . 14592) (\FLUSHVM 14594 . 15666) (\LOGOUT0 15668 . 15995)) (16496 41156 ( -UNPACKFILENAME.STRING 16506 . 38342) (\UPF.DIRECTORY 38344 . 41154)) (42741 45047 (UNPACKFILENAME -42751 . 42937) (LASTCHPOS 42939 . 43633) (FILENAMEFIELD 43635 . 43929) (FILENAMEFIELD.STRING 43931 . -44335) (PACKFILENAME 44337 . 44680) (PACKFILENAME.STRING 44682 . 45045)) (59517 60430 ( -FILEDIRCASEARRAY 59527 . 60428)) (60597 67894 (LOGOUT 60607 . 61652) (MAKESYS 61654 . 63283) (SYSOUT -63285 . 64837) (SAVEVM 64839 . 65639) (HERALD 65641 . 65801) (INTERPRET.REM.CM 65803 . 67517) ( -\USEREVENT 67519 . 67892)) (68076 69803 (USERNAME 68086 . 69042) (SETUSERNAME 69044 . 69801))))) + (FILEMAP (NIL (3171 15998 (DELFILE 3181 . 3342) (FULLNAME 3344 . 3711) (INFILE 3713 . 3972) (INFILEP +3974 . 4109) (IOFILE 4111 . 4362) (OPENFILE 4364 . 4667) (OPENSTREAM 4669 . 9009) (OUTFILE 9011 . 9273 +) (OUTFILEP 9275 . 9411) (RENAMEFILE 9413 . 9719) (SIMPLE.FINDFILE 9721 . 10131) (VMEMSIZE 10133 . +10300) (\COPYSYS 10302 . 14593) (\FLUSHVM 14595 . 15667) (\LOGOUT0 15669 . 15996)) (16497 41157 ( +UNPACKFILENAME.STRING 16507 . 38343) (\UPF.DIRECTORY 38345 . 41155)) (42742 45048 (UNPACKFILENAME +42752 . 42938) (LASTCHPOS 42940 . 43634) (FILENAMEFIELD 43636 . 43930) (FILENAMEFIELD.STRING 43932 . +44336) (PACKFILENAME 44338 . 44681) (PACKFILENAME.STRING 44683 . 45046)) (59518 60431 ( +FILEDIRCASEARRAY 59528 . 60429)) (60598 68006 (LOGOUT 60608 . 61653) (MAKESYS 61655 . 63284) (SYSOUT +63286 . 64838) (SAVEVM 64840 . 65640) (HERALD 65642 . 65802) (INTERPRET.REM.CM 65804 . 67629) ( +\USEREVENT 67631 . 68004)) (68188 69915 (USERNAME 68198 . 69154) (SETUSERNAME 69156 . 69913))))) STOP diff --git a/sources/ADIR.LCOM b/sources/ADIR.LCOM index 8deb5dba..3839849d 100644 Binary files a/sources/ADIR.LCOM and b/sources/ADIR.LCOM differ diff --git a/sources/ADISPLAY b/sources/ADISPLAY index bccc0ab8..2f3772bc 100644 --- a/sources/ADISPLAY +++ b/sources/ADISPLAY @@ -1,14 +1,10 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) -(FILECREATED " 8-Jul-2025 20:19:58"  -{DSK}kaplan>Local>medley3.5>working-medley>sources>ADISPLAY.;14 244883 +(FILECREATED "19-Feb-2026 12:09:16" {WMEDLEY}ADISPLAY.;15 244850 :EDIT-BY rmk - :CHANGES-TO (VARS ADISPLAYCOMS) - - :PREVIOUS-DATE "19-Dec-2023 11:23:08" -{DSK}kaplan>Local>medley3.5>working-medley>sources>ADISPLAY.;13) + :PREVIOUS-DATE " 8-Jul-2025 20:19:58" {WMEDLEY}ADISPLAY.;14) (PRETTYCOMPRINT ADISPLAYCOMS) @@ -130,7 +126,7 @@ (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (RECORD REGION (LEFT BOTTOM WIDTH HEIGHT) - LEFT _ -16383 BOTTOM _ -16383 WIDTH _ 32767 HEIGHT _ 32767 + LEFT ↠-16383 BOTTOM ↠-16383 WIDTH ↠32767 HEIGHT ↠32767 [ACCESSFNS ((TOP (IPLUS (fetch (REGION BOTTOM) of DATUM) (fetch (REGION HEIGHT) of DATUM) -1)) @@ -150,7 +146,7 @@ (BITMAPHEIGHT WORD) (BITMAPWIDTH WORD) (BITMAPBITSPERPIXEL WORD)) - BITMAPBITSPERPIXEL _ 1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD) + BITMAPBITSPERPIXEL ↠1 (BLOCKRECORD BITMAP ((BitMapHiLoc WORD) (BitMapLoLoc WORD)) (* ; "overlay initial pointer") ) @@ -398,7 +394,7 @@ (T (printout T "******** " BITMAP " is not a BITMAP." T) (RETURN NIL))) (printout FILE "(" .P2 (BITMAPWIDTH BM) - %, .P2 (BITMAPHEIGHT BM)) (* ; + %, .P2 (BITMAPHEIGHT BM)) (* ;  "if the number of bits per pixel is not 1, write it out.") (COND ((NEQ (BITSPERPIXEL BM) @@ -431,7 +427,7 @@ (* ;; "Print this bitmap in the preferred way.") (LET* ((WIDTH (BITMAPWIDTH BITMAP)) - (HEIGHT (BITMAPHEIGHT BITMAP)) + (HEIGHT (BITMAPHEIGHT BITMAP)) (BITS-PER-PIXEL (BITSPERPIXEL BITMAP)) (BASE (fetch BITMAPBASE of BITMAP)) (QUAD-CHARS-PER-ROW (FOLDHI (CL:* WIDTH BITS-PER-PIXEL) @@ -712,20 +708,20 @@ NIL) ((CURSORP DEFAULTCARET) (create CARET1 - CURSOR _ DEFAULTCARET)) + CURSOR ↠DEFAULTCARET)) (T (ERROR "DEFAULTCARET is not a cursor" DEFAULTCARET)))) (OFF NIL) (COND ((CURSORP NEWCARET) (create CARET1 - CURSOR _ NEWCARET)) + CURSOR ↠NEWCARET)) (T (LISPERROR "ILLEGAL ARG" NEWCARET])]) (\CARET.CREATE [LAMBDA (CURSOR) (* jds "11-Jul-85 19:38") (create CARET1 - CURSOR _ (OR CURSOR DEFAULTCARET]) + CURSOR ↠(OR CURSOR DEFAULTCARET]) (\CARET.DOWN [LAMBDA (STREAM INTERVAL UNLESSOCCLUDED) (* lmm " 4-May-84 18:15") @@ -815,7 +811,7 @@ (LET ((OCARET \CARET.UP)) (COND ([AND OCARET CARET (DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM] - (for (OC _ OCARET) by (fetch (CARET1 NEXT) of OC) + (for (OC ↠OCARET) by (fetch (CARET1 NEXT) of OC) do (COND [(NULL OC) (RETURN (COND @@ -1008,10 +1004,10 @@ [LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* rrb "17-JUN-83 08:56") (* ; "creates a region structure.") (create REGION - LEFT _ LEFT - BOTTOM _ BOTTOM - WIDTH _ WIDTH - HEIGHT _ HEIGHT]) + LEFT ↠LEFT + BOTTOM ↠BOTTOM + WIDTH ↠WIDTH + HEIGHT ↠HEIGHT]) (REGIONP [LAMBDA (X) (* rrb "29-Jun-84 18:00") @@ -1029,11 +1025,11 @@ (* ;; "this is documented as returning a very large region. This one covers the entire FIXP range so should work for many purposes. rrb") (create REGION - LEFT _ (SUB1 MIN.FIXP) - BOTTOM _ (SUB1 MIN.FIXP) - WIDTH _ (PLUS (TIMES 2 MAX.FIXP) + LEFT ↠(SUB1 MIN.FIXP) + BOTTOM ↠(SUB1 MIN.FIXP) + WIDTH ↠(PLUS (TIMES 2 MAX.FIXP) 4) - HEIGHT _ (PLUS (TIMES 2 MAX.FIXP) + HEIGHT ↠(PLUS (TIMES 2 MAX.FIXP) 4))) (T (PROG (REG LFT RGHT BTTM TP) (SETQ REG (ARG REGIONS 1)) @@ -1062,10 +1058,10 @@ ((AND (IGEQ RGHT LFT) (IGEQ TP BTTM)) (create REGION - LEFT _ LFT - BOTTOM _ BTTM - WIDTH _ (ADD1 (IDIFFERENCE RGHT LFT)) - HEIGHT _ (ADD1 (IDIFFERENCE TP BTTM]) + LEFT ↠LFT + BOTTOM ↠BTTM + WIDTH ↠(ADD1 (IDIFFERENCE RGHT LFT)) + HEIGHT ↠(ADD1 (IDIFFERENCE TP BTTM]) (UNIONREGIONS [LAMBDA REGIONS (* rrb "30-Dec-85 17:07") @@ -1099,10 +1095,10 @@ TP) (SETQ TP (fetch (REGION PTOP) of REG] (RETURN (create REGION - LEFT _ LFT - BOTTOM _ BTTM - WIDTH _ (DIFFERENCE RGHT LFT) - HEIGHT _ (DIFFERENCE TP BTTM]) + LEFT ↠LFT + BOTTOM ↠BTTM + WIDTH ↠(DIFFERENCE RGHT LFT) + HEIGHT ↠(DIFFERENCE TP BTTM]) (REGIONSINTERSECTP [LAMBDA (REGION1 REGION2) (* rrb "16-AUG-81 08:29") @@ -1233,11 +1229,11 @@ (* ;; "returns the region taken up by STR if it were printed at the current position of STREAM") (create REGION - LEFT _ (DSPXPOSITION NIL STREAM) - BOTTOM _ (IDIFFERENCE (DSPYPOSITION NIL STREAM) + LEFT ↠(DSPXPOSITION NIL STREAM) + BOTTOM ↠(IDIFFERENCE (DSPYPOSITION NIL STREAM) (FONTPROP STREAM 'DESCENT)) - WIDTH _ (STRINGWIDTH STR STREAM PRIN2FLG RDTBL) - HEIGHT _ (FONTPROP STREAM 'HEIGHT]) + WIDTH ↠(STRINGWIDTH STR STREAM PRIN2FLG RDTBL) + HEIGHT ↠(FONTPROP STREAM 'HEIGHT]) ) @@ -1443,8 +1439,8 @@ (SETQ BRUSHARRAY (ARRAY 16 'POINTER NIL 1)) (for X from 1 to 16 do (SETA BRUSHARRAY X (APPLY* BRUSHFN X] (push \BrushAList (CONS BRUSHNAME (create BRUSHITEM - BRUSHARRAY _ BRUSHARRAY - CREATEMETHOD _ BRUSHFN))) + BRUSHARRAY ↠BRUSHARRAY + CREATEMETHOD ↠BRUSHFN))) (push KNOWN.BRUSHES BRUSHNAME]) ) @@ -1506,12 +1502,12 @@ CBottom) (SETQ BITMAP (ffetch DDDestination of DD)) (SETQ BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP)) - (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) + (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) (SETQ ClippingTop (ffetch DDClippingTop of DD)) (SETQ ClippingBottom (ffetch DDClippingBottom of DD)) (SETQ BM (GetNewFragment BIGBMLIST)) (while (AND BM (IGREATERP HEIGHT ClippingBottom)) - do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) + do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) [SETQ CTop (COND ((IGREATERP ClippingTop HEIGHT) (IDIFFERENCE HEIGHT BOTTOM)) @@ -1576,7 +1572,7 @@ (SUB1 (ffetch DDClippingTop of DD)) DISPLAYSTREAM COLOR)) (T (PROG ((BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP)) - (HEIGHT (BITMAPHEIGHT BITMAP)) + (HEIGHT (BITMAPHEIGHT BITMAP)) BOTTOM BM CTop CBottom (ClippingTop (ffetch DDClippingTop of DD)) (ClippingBottom (ffetch DDClippingBottom of DD)) (YY1 (\DSPTRANSFORMY (OR (FIXP Y1) @@ -1587,7 +1583,7 @@ DD))) (SETQ BM (GetNewFragment BIGBMLIST)) (while (AND BM (IGREATERP HEIGHT ClippingBottom)) - do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) + do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) [SETQ CTop (COND ((IGREATERP ClippingTop HEIGHT) (IDIFFERENCE HEIGHT BOTTOM)) @@ -2038,7 +2034,7 @@ (DECLARE%: EVAL@COMPILE (PUTPROPS .DRAWLINEX. MACRO [(MODE) - (bind (NY _ 0) for PT from 1 to PIXELSINX + (bind (NY ↠0) for PT from 1 to PIXELSINX do (* ; "main loop") [replace (BITMAPWORD BITS) of FIRSTADDR with (SELECTQ MODE @@ -2068,7 +2064,7 @@ (SETQ MASK 32768]) (PUTPROPS .DRAWLINEY. MACRO [(MODE) - (bind (NX _ 0) for PT from 1 to PIXELSINY + (bind (NX ↠0) for PT from 1 to PIXELSINY do (* ; "main loop") [replace (BITMAPWORD BITS) of FIRSTADDR with (SELECTQ MODE @@ -2295,9 +2291,9 @@ (RETURN (for ANGLE from STARTANGLE to (PLUS STARTANGLE ANGLESIZE (QUOTIENT ANGLEINCR 5.0)) by ANGLEINCR collect (create POSITION - XCOORD _ [FIXR (PLUS CENTERX (TIMES RADIUS + XCOORD ↠[FIXR (PLUS CENTERX (TIMES RADIUS (COS ANGLE] - YCOORD _ (FIXR (PLUS CENTERY (TIMES RADIUS + YCOORD ↠(FIXR (PLUS CENTERY (TIMES RADIUS (SIN ANGLE]) (\DRAWELLIPSE.DISPLAY @@ -2609,7 +2605,7 @@ ((EQ (fetch (BRUSH BRUSHSHAPE) of BRUSH) 'ROUND) BRUSH) - (T (create BRUSH using BRUSH BRUSHSHAPE _ 'ROUND] + (T (create BRUSH using BRUSH BRUSHSHAPE ↠'ROUND] (SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of PTBRUSH)) (for PTAIL on POINTS while (CDR PTAIL) do (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD ) @@ -2991,15 +2987,15 @@ (ELT DDY I] (SETQ SPLINE (create SPLINE - %#KNOTS _ %#KNOTS - SPLINEX _ X - SPLINEY _ Y - SPLINEDX _ DX - SPLINEDY _ DY - SPLINEDDX _ DDX - SPLINEDDY _ DDY - SPLINEDDDX _ DDDX - SPLINEDDDY _ DDDY)) + %#KNOTS ↠%#KNOTS + SPLINEX ↠X + SPLINEY ↠Y + SPLINEDX ↠DX + SPLINEDY ↠DY + SPLINEDDX ↠DDX + SPLINEDDY ↠DDY + SPLINEDDDX ↠DDDX + SPLINEDDDY ↠DDDY)) (RETURN SPLINE]) (\CURVE @@ -3187,7 +3183,7 @@ (SETQ POINTSPERSEG 64) (SETQ NPOINTS (UNFOLD NSEGS 64] (SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (* ; - "Set up ÿ&Eÿt, ÿ&Eÿt**2 and ÿ&Eÿt**3, for computing the next point.") + "Set up Δt, Δt**2 and Δt**3, for computing the next point.") (SETQ D2 (FTIMES D1 D1)) (SETQ D3 (FTIMES D2 D1)) (SETQ D3X (FTIMES D3 DDDX)) @@ -3219,11 +3215,11 @@ (SETQ PERSEG (FQUOTIENT 1.0 NSEGS)) (LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0) (LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0) - (bind (TT _ 0.0) - (DDDX/PER/SEG _ (FTIMES DDDX PERSEG)) - (DDDY/PER/SEG _ (FTIMES DDDY PERSEG)) - [D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0] - [D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I + (bind (TT ↠0.0) + (DDDX/PER/SEG ↠(FTIMES DDDX PERSEG)) + (DDDY/PER/SEG ↠(FTIMES DDDY PERSEG)) + [D3XFACTOR ↠(FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0] + [D3YFACTOR ↠(FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I from 0 to (SUB1 NSEGS) do (* ;; @@ -4224,9 +4220,9 @@ (SETQ Min (FDIFFERENCE (FTIMES L 2) Max)) (RETURN (create RGB - RED _ (\HLSVALUEFN Min Max H) - GREEN _ (\HLSVALUEFN Min Max (IDIFFERENCE H 120)) - BLUE _ (\HLSVALUEFN Min Max (IDIFFERENCE H 240]) + RED ↠(\HLSVALUEFN Min Max H) + GREEN ↠(\HLSVALUEFN Min Max (IDIFFERENCE H 120)) + BLUE ↠(\HLSVALUEFN Min Max (IDIFFERENCE H 240]) (\HLSVALUEFN [LAMBDA (MIN MAX HUE) (* rrb "25-OCT-82 10:47") @@ -4424,40 +4420,40 @@ (ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (10589 10783 (SCREENREGIONP 10599 . 10781)) (12227 19588 (\BBTCURVEPT 12237 . 19586)) ( -19589 29405 (CREATETEXTUREFROMBITMAP 19599 . 21529) (PRINTBITMAP 21531 . 22882) (PRINT-BITMAPS-NICELY -22884 . 26735) (PRINTCURSOR 26737 . 27770) (\WRITEBITMAP 27772 . 29403)) (29448 31996 (\GETINTEGERPART - 29458 . 31003) (\CONVERTTOFRACTION 31005 . 31994)) (32133 33005 (CURSORP 32143 . 32362) (CURSORBITMAP - 32364 . 32410) (CreateCursorBitMap 32412 . 33003)) (37367 46290 (CARET 37377 . 39137) (\CARET.CREATE -39139 . 39317) (\CARET.DOWN 39319 . 40671) (\CARET.FLASH? 40673 . 42367) (\CARET.SHOW 42369 . 42938) ( -CARETRATE 42940 . 43598) (\CARET.FLASH.AGAIN 43600 . 44766) (\CARET.FLASH.MULTIPLE 44768 . 45291) ( -\CARET.FLASH 45293 . 46288)) (46291 51363 (\MEDW.CARET.SHOW 46301 . 51361)) (51727 53562 ( -\AREAVISIBLE? 51737 . 52661) (\REGIONOVERLAPAREAP 52663 . 53208) (\AREAINREGIONP 53210 . 53560)) ( -53611 66087 (CREATEREGION 53621 . 53957) (REGIONP 53959 . 54105) (INTERSECTREGIONS 54107 . 56877) ( -UNIONREGIONS 56879 . 59030) (REGIONSINTERSECTP 59032 . 59640) (SUBREGIONP 59642 . 60287) (EXTENDREGION - 60289 . 62446) (EXTENDREGIONBOTTOM 62448 . 63090) (EXTENDREGIONLEFT 63092 . 63711) (EXTENDREGIONRIGHT - 63713 . 64266) (EXTENDREGIONTOP 64268 . 64809) (INSIDEP 64811 . 65579) (STRINGREGION 65581 . 66085)) -(66332 71606 (\BRUSHBITMAP 66342 . 68059) (\GETBRUSH 68061 . 68372) (\GETBRUSHBBT 68374 . 70402) ( -\InitCurveBrushes 70404 . 71470) (\BrushFromWidth 71472 . 71604)) (71607 74674 (\MAKEBRUSH.DIAGONAL -71617 . 71897) (\MAKEBRUSH.HORIZONTAL 71899 . 72293) (\MAKEBRUSH.VERTICAL 72295 . 72607) ( -\MAKEBRUSH.SQUARE 72609 . 72886) (\MAKEBRUSH.ROUND 72888 . 74672)) (74675 75840 (INSTALLBRUSH 74685 . -75838)) (76241 87643 (\DRAWLINE.DISPLAY 76251 . 86358) (RELMOVETO 86360 . 86747) (MOVETOUPPERLEFT -86749 . 87641)) (87644 111129 (\CLIPANDDRAWLINE 87654 . 94100) (\CLIPANDDRAWLINE1 94102 . 105850) ( -\CLIPCODE 105852 . 107226) (\LEASTPTAT 107228 . 107826) (\GREATESTPTAT 107828 . 108456) (\DRAWLINE1 -108458 . 109574) (\DRAWLINE.UFN 109576 . 111127)) (115659 161706 (\DRAWCIRCLE.DISPLAY 115669 . 124482) - (\DRAWARC.DISPLAY 124484 . 124774) (\DRAWARC.GENERIC 124776 . 125529) (\COMPUTE.ARC.POINTS 125531 . -127796) (\DRAWELLIPSE.DISPLAY 127798 . 143467) (\DRAWCURVE.DISPLAY 143469 . 145758) ( -\DRAWPOINT.DISPLAY 145760 . 146956) (\DRAWPOLYGON.DISPLAY 146958 . 150486) (\LINEWITHBRUSH 150488 . -161704)) (161707 193399 (LOADPOLY 161717 . 162277) (PARAMETRICSPLINE 162279 . 172476) (\CURVE 172478 - . 178080) (\CURVE2 178082 . 189413) (\CURVEEND 189415 . 189897) (\CURVESLOPE 189899 . 192382) ( -\CURVESTART 192384 . 192708) (\FDIFS/FROM/DERIVS 192710 . 193397)) (205928 220264 (\FILLCIRCLE.DISPLAY - 205938 . 216686) (\LINEBLT 216688 . 220262)) (220308 221930 (SCREENBITMAP 220318 . 220795) (BITMAPP -220797 . 221031) (BITSPERPIXEL 221033 . 221928)) (222571 223564 (DSPFILL 222581 . 223264) (INVERTW -223266 . 223562)) (223565 227208 (\DSPCOLOR.DISPLAY 223575 . 224872) (\DSPBACKCOLOR.DISPLAY 224874 . -226253) (DSPEOLFN 226255 . 227206)) (227641 232295 (DSPCLEOL 227651 . 228527) (DSPRUBOUTCHAR 228529 . -228961) (\DSPMOVELR 228963 . 232293)) (232425 233543 (\CURSOR.DEFPRINT 232435 . 233541)) (233955 -242529 (TEXTUREOFCOLOR 233965 . 235227) (\PRIMARYTEXTURE 235229 . 235811) (\LEVELTEXTURE 235813 . -236314) (INSURE.B&W.TEXTURE 236316 . 237711) (INSURE.RGB.COLOR 237713 . 239141) (\LOOKUPCOLORNAME -239143 . 239413) (RGBP 239415 . 240180) (HLSP 240182 . 240557) (HLSTORGB 240559 . 241699) (\HLSVALUEFN - 241701 . 242527))))) + (FILEMAP (NIL (10493 10687 (SCREENREGIONP 10503 . 10685)) (12131 19492 (\BBTCURVEPT 12141 . 19490)) ( +19493 29301 (CREATETEXTUREFROMBITMAP 19503 . 21433) (PRINTBITMAP 21435 . 22782) (PRINT-BITMAPS-NICELY +22784 . 26631) (PRINTCURSOR 26633 . 27666) (\WRITEBITMAP 27668 . 29299)) (29344 31892 (\GETINTEGERPART + 29354 . 30899) (\CONVERTTOFRACTION 30901 . 31890)) (32029 32901 (CURSORP 32039 . 32258) (CURSORBITMAP + 32260 . 32306) (CreateCursorBitMap 32308 . 32899)) (37263 46194 (CARET 37273 . 39037) (\CARET.CREATE +39039 . 39219) (\CARET.DOWN 39221 . 40573) (\CARET.FLASH? 40575 . 42269) (\CARET.SHOW 42271 . 42840) ( +CARETRATE 42842 . 43500) (\CARET.FLASH.AGAIN 43502 . 44670) (\CARET.FLASH.MULTIPLE 44672 . 45195) ( +\CARET.FLASH 45197 . 46192)) (46195 51267 (\MEDW.CARET.SHOW 46205 . 51265)) (51631 53466 ( +\AREAVISIBLE? 51641 . 52565) (\REGIONOVERLAPAREAP 52567 . 53112) (\AREAINREGIONP 53114 . 53464)) ( +53515 66031 (CREATEREGION 53525 . 53869) (REGIONP 53871 . 54017) (INTERSECTREGIONS 54019 . 56805) ( +UNIONREGIONS 56807 . 58966) (REGIONSINTERSECTP 58968 . 59576) (SUBREGIONP 59578 . 60223) (EXTENDREGION + 60225 . 62382) (EXTENDREGIONBOTTOM 62384 . 63026) (EXTENDREGIONLEFT 63028 . 63647) (EXTENDREGIONRIGHT + 63649 . 64202) (EXTENDREGIONTOP 64204 . 64745) (INSIDEP 64747 . 65515) (STRINGREGION 65517 . 66029)) +(66276 71550 (\BRUSHBITMAP 66286 . 68003) (\GETBRUSH 68005 . 68316) (\GETBRUSHBBT 68318 . 70346) ( +\InitCurveBrushes 70348 . 71414) (\BrushFromWidth 71416 . 71548)) (71551 74618 (\MAKEBRUSH.DIAGONAL +71561 . 71841) (\MAKEBRUSH.HORIZONTAL 71843 . 72237) (\MAKEBRUSH.VERTICAL 72239 . 72551) ( +\MAKEBRUSH.SQUARE 72553 . 72830) (\MAKEBRUSH.ROUND 72832 . 74616)) (74619 75788 (INSTALLBRUSH 74629 . +75786)) (76189 87575 (\DRAWLINE.DISPLAY 76199 . 86290) (RELMOVETO 86292 . 86679) (MOVETOUPPERLEFT +86681 . 87573)) (87576 111061 (\CLIPANDDRAWLINE 87586 . 94032) (\CLIPANDDRAWLINE1 94034 . 105782) ( +\CLIPCODE 105784 . 107158) (\LEASTPTAT 107160 . 107758) (\GREATESTPTAT 107760 . 108388) (\DRAWLINE1 +108390 . 109506) (\DRAWLINE.UFN 109508 . 111059)) (115595 161648 (\DRAWCIRCLE.DISPLAY 115605 . 124418) + (\DRAWARC.DISPLAY 124420 . 124710) (\DRAWARC.GENERIC 124712 . 125465) (\COMPUTE.ARC.POINTS 125467 . +127736) (\DRAWELLIPSE.DISPLAY 127738 . 143407) (\DRAWCURVE.DISPLAY 143409 . 145698) ( +\DRAWPOINT.DISPLAY 145700 . 146896) (\DRAWPOLYGON.DISPLAY 146898 . 150428) (\LINEWITHBRUSH 150430 . +161646)) (161649 193360 (LOADPOLY 161659 . 162219) (PARAMETRICSPLINE 162221 . 172436) (\CURVE 172438 + . 178040) (\CURVE2 178042 . 189374) (\CURVEEND 189376 . 189858) (\CURVESLOPE 189860 . 192343) ( +\CURVESTART 192345 . 192669) (\FDIFS/FROM/DERIVS 192671 . 193358)) (205889 220225 (\FILLCIRCLE.DISPLAY + 205899 . 216647) (\LINEBLT 216649 . 220223)) (220269 221891 (SCREENBITMAP 220279 . 220756) (BITMAPP +220758 . 220992) (BITSPERPIXEL 220994 . 221889)) (222532 223525 (DSPFILL 222542 . 223225) (INVERTW +223227 . 223523)) (223526 227169 (\DSPCOLOR.DISPLAY 223536 . 224833) (\DSPBACKCOLOR.DISPLAY 224835 . +226214) (DSPEOLFN 226216 . 227167)) (227602 232256 (DSPCLEOL 227612 . 228488) (DSPRUBOUTCHAR 228490 . +228922) (\DSPMOVELR 228924 . 232254)) (232386 233504 (\CURSOR.DEFPRINT 232396 . 233502)) (233916 +242496 (TEXTUREOFCOLOR 233926 . 235188) (\PRIMARYTEXTURE 235190 . 235772) (\LEVELTEXTURE 235774 . +236275) (INSURE.B&W.TEXTURE 236277 . 237672) (INSURE.RGB.COLOR 237674 . 239102) (\LOOKUPCOLORNAME +239104 . 239374) (RGBP 239376 . 240141) (HLSP 240143 . 240518) (HLSTORGB 240520 . 241666) (\HLSVALUEFN + 241668 . 242494))))) STOP diff --git a/sources/ADISPLAY.LCOM b/sources/ADISPLAY.LCOM index 106b5996..a967e4e1 100644 Binary files a/sources/ADISPLAY.LCOM and b/sources/ADISPLAY.LCOM differ diff --git a/sources/ATBL b/sources/ATBL index b8edac7d..86d4db20 100644 --- a/sources/ATBL +++ b/sources/ATBL @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Apr-2025 21:52:35" {WMEDLEY}ATBL.;33 91754 +(FILECREATED "25-Feb-2026 12:02:51" {WMEDLEY}ATBL.;35 92262 :EDIT-BY rmk - :CHANGES-TO (FNS \ATBLSET EQUAL-READER-ENVIRONMENT) + :CHANGES-TO (VARS ATBLCOMS) - :PREVIOUS-DATE "26-Dec-2021 14:32:50" {WMEDLEY}ATBL.;32) + :PREVIOUS-DATE "24-Apr-2025 21:52:35" {WMEDLEY}ATBL.;33) (PRETTYCOMPRINT ATBLCOMS) @@ -56,12 +56,13 @@ (CONSTANTS * READCLASSES) (CONSTANTS * READMACROWAKEUPS) (CONSTANTS * READMACROESCAPES) - (RECORDS READCODE READMACRODEF READTABLEP)) + (RECORDS READCODE READMACRODEF READTABLEP) + (RECORDS READER-ENVIRONMENT)) (GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE)) - (INITRECORDS READTABLEP)) + (INITRECORDS READTABLEP) + (INITRECORDS READER-ENVIRONMENT)) [COMS (INITVARS (\READTABLEHASH)) (FNS \ATBLSET) - (INITRECORDS READER-ENVIRONMENT) (* ;  "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*") (FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT) @@ -1691,6 +1692,19 @@ (READTABLEP 8 (BITS . 7)) (READTABLEP 10 POINTER)) '12) +(DECLARE%: EVAL@COMPILE + +(DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE REPACKAGEFORM REFORMAT REREADTABLEFORM)) +) + +(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER) + '((READER-ENVIRONMENT 0 POINTER) + (READER-ENVIRONMENT 2 POINTER) + (READER-ENVIRONMENT 4 POINTER) + (READER-ENVIRONMENT 6 POINTER) + (READER-ENVIRONMENT 8 POINTER) + (READER-ENVIRONMENT 10 POINTER)) + '12) (* "END EXPORTED DEFINITIONS") @@ -1726,6 +1740,15 @@ (READTABLEP 10 POINTER)) '12) +(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER) + '((READER-ENVIRONMENT 0 POINTER) + (READER-ENVIRONMENT 2 POINTER) + (READER-ENVIRONMENT 4 POINTER) + (READER-ENVIRONMENT 6 POINTER) + (READER-ENVIRONMENT 8 POINTER) + (READER-ENVIRONMENT 10 POINTER)) + '12) + (RPAQ? \READTABLEHASH ) (DEFINEQ @@ -1813,15 +1836,6 @@ NIL]) ) -(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER) - '((READER-ENVIRONMENT 0 POINTER) - (READER-ENVIRONMENT 2 POINTER) - (READER-ENVIRONMENT 4 POINTER) - (READER-ENVIRONMENT 6 POINTER) - (READER-ENVIRONMENT 8 POINTER) - (READER-ENVIRONMENT 10 POINTER)) - '12) - (* ; "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*") @@ -1922,22 +1936,22 @@ (ADDTOVAR LAMA READTABLEPROP) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (17619 28771 (GETSYNTAX 17629 . 22460) (SETSYNTAX 22462 . 23535) (SYNTAXP 23537 . 26034) - (\COPYSYNTAX 26036 . 26753) (\GETCHARCODE 26755 . 27043) (\SETFATSYNCODE 27045 . 28336) ( -\MAPCHARTABLE 28338 . 28769)) (28804 43770 (CONTROL 28814 . 29066) (COPYTERMTABLE 29068 . 29435) ( -DELETECONTROL 29437 . 32078) (GETDELETECONTROL 32080 . 33042) (ECHOCHAR 33044 . 34485) (ECHOCONTROL -34487 . 34944) (ECHOMODE 34946 . 35192) (GETECHOMODE 35194 . 35358) (GETCONTROL 35360 . 35526) ( -GETTERMTABLE 35528 . 35595) (RAISE 35597 . 36023) (GETRAISE 36025 . 36187) (RESETTERMTABLE 36189 . -37273) (SETTERMTABLE 37275 . 37509) (TERMTABLEP 37511 . 37672) (\GETTERMSYNTAX 37674 . 37945) ( -\GTTERMTABLE 37947 . 38283) (\ORIGTERMTABLE 38285 . 41895) (\SETTERMSYNTAX 41897 . 42532) ( -\TERMCLASSTOCODE 42534 . 42963) (\TERMCODETOCLASS 42965 . 43352) (\LITCHECK 43354 . 43768)) (46281 -70105 (COPYREADTABLE 46291 . 46489) (FIND-READTABLE 46491 . 46638) (IN-READTABLE 46640 . 46800) ( -ESCAPE 46802 . 47055) (GETBRK 47057 . 47195) (GETREADTABLE 47197 . 47333) (GETSEPR 47335 . 47473) ( -READMACROS 47475 . 47738) (READTABLEP 47740 . 47903) (READTABLEPROP 47905 . 53063) (RESETREADTABLE -53065 . 57312) (SETBRK 57314 . 58924) (SETREADTABLE 58926 . 59114) (SETSEPR 59116 . 60658) ( -\GETREADSYNTAX 60660 . 63350) (\GTREADTABLE 63352 . 63577) (\GTREADTABLE1 63579 . 63835) ( -\ORIGREADTABLE 63837 . 65745) (\READCLASSTOCODE 65747 . 66198) (\SETMACROSYNTAX 66200 . 67995) ( -\SETREADSYNTAX 67997 . 69058) (\READTABLEP.DEFPRINT 69060 . 70103)) (82937 87494 (\ATBLSET 82947 . -87492)) (87941 91385 (MAKE-READER-ENVIRONMENT 87951 . 89608) (EQUAL-READER-ENVIRONMENT 89610 . 90787) -(SET-READER-ENVIRONMENT 90789 . 91383))))) + (FILEMAP (NIL (17652 28804 (GETSYNTAX 17662 . 22493) (SETSYNTAX 22495 . 23568) (SYNTAXP 23570 . 26067) + (\COPYSYNTAX 26069 . 26786) (\GETCHARCODE 26788 . 27076) (\SETFATSYNCODE 27078 . 28369) ( +\MAPCHARTABLE 28371 . 28802)) (28837 43803 (CONTROL 28847 . 29099) (COPYTERMTABLE 29101 . 29468) ( +DELETECONTROL 29470 . 32111) (GETDELETECONTROL 32113 . 33075) (ECHOCHAR 33077 . 34518) (ECHOCONTROL +34520 . 34977) (ECHOMODE 34979 . 35225) (GETECHOMODE 35227 . 35391) (GETCONTROL 35393 . 35559) ( +GETTERMTABLE 35561 . 35628) (RAISE 35630 . 36056) (GETRAISE 36058 . 36220) (RESETTERMTABLE 36222 . +37306) (SETTERMTABLE 37308 . 37542) (TERMTABLEP 37544 . 37705) (\GETTERMSYNTAX 37707 . 37978) ( +\GTTERMTABLE 37980 . 38316) (\ORIGTERMTABLE 38318 . 41928) (\SETTERMSYNTAX 41930 . 42565) ( +\TERMCLASSTOCODE 42567 . 42996) (\TERMCODETOCLASS 42998 . 43385) (\LITCHECK 43387 . 43801)) (46314 +70138 (COPYREADTABLE 46324 . 46522) (FIND-READTABLE 46524 . 46671) (IN-READTABLE 46673 . 46833) ( +ESCAPE 46835 . 47088) (GETBRK 47090 . 47228) (GETREADTABLE 47230 . 47366) (GETSEPR 47368 . 47506) ( +READMACROS 47508 . 47771) (READTABLEP 47773 . 47936) (READTABLEPROP 47938 . 53096) (RESETREADTABLE +53098 . 57345) (SETBRK 57347 . 58957) (SETREADTABLE 58959 . 59147) (SETSEPR 59149 . 60691) ( +\GETREADSYNTAX 60693 . 63383) (\GTREADTABLE 63385 . 63610) (\GTREADTABLE1 63612 . 63868) ( +\ORIGREADTABLE 63870 . 65778) (\READCLASSTOCODE 65780 . 66231) (\SETMACROSYNTAX 66233 . 68028) ( +\SETREADSYNTAX 68030 . 69091) (\READTABLEP.DEFPRINT 69093 . 70136)) (83789 88346 (\ATBLSET 83799 . +88344)) (88449 91893 (MAKE-READER-ENVIRONMENT 88459 . 90116) (EQUAL-READER-ENVIRONMENT 90118 . 91295) +(SET-READER-ENVIRONMENT 91297 . 91891))))) STOP diff --git a/sources/ATBL.LCOM b/sources/ATBL.LCOM index 0ca35895..21f08bb3 100644 Binary files a/sources/ATBL.LCOM and b/sources/ATBL.LCOM differ diff --git a/sources/ATERM b/sources/ATERM index 19ac20c9..4dade0a9 100644 --- a/sources/ATERM +++ b/sources/ATERM @@ -1,16 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "20-Jul-2022 17:05:17" {DSK}kaplan>Local>medley3.5>working-medley>sources>ATERM.;5 57463 +(FILECREATED " 9-Feb-2026 15:49:51" {WMEDLEY}ATERM.;7 56918 - :CHANGES-TO (FNS \CHDEL1) + :EDIT-BY rmk - :PREVIOUS-DATE "19-Jul-2022 22:49:20" -{DSK}kaplan>Local>medley3.5>working-medley>sources>ATERM.;4) + :CHANGES-TO (FNS \CREATELINEBUFFER) + :PREVIOUS-DATE "20-Jul-2022 17:05:17" {WMEDLEY}ATERM.;5) -(* ; " -Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation. -") (PRETTYCOMPRINT ATERMCOMS) @@ -915,39 +912,33 @@ Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation. (RETURN STREAM]) (\CREATELINEBUFFER - [LAMBDA (TERMINAL.STREAM) (* ; "Edited 29-Apr-2021 09:38 by rmk:") + [LAMBDA (TERMINAL.STREAM) (* ; "Edited 9-Feb-2026 15:49 by rmk") + (* ; "Edited 29-Apr-2021 09:38 by rmk:") - (* ;; - "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).") + (* ;; + "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).") - (LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((CHARSET T] + (LET* ([STREAM (\OPENFILE '{LINEBUFFER} 'BOTH 'NEW '((:EXTERNAL-FORMAT :THROUGH16] (DEV (fetch (STREAM DEVICE) of STREAM)) EOFMETHOD) (replace LINEBUFSTATE of STREAM with READING.LBS) - (replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM - \KEYBOARD.STREAM)) + (replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM)) (replace USERCLOSEABLE of STREAM with NIL) - (replace USERVISIBLE of STREAM with NIL) - (* ; - "Other linebuffer fields default properly") + (replace USERVISIBLE of STREAM with NIL) (* ; + "Other linebuffer fields default properly") [replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM) - (CL:FUNCALL \RefillBufferFn] + (CL:FUNCALL \RefillBufferFn] (replace (STREAM EOLCONVENTION) of STREAM with CR.EOLC) - (* ; - "RMK: Terminal is CR, even if stream default is LF") - (if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of - TERMINAL.STREAM - )) - 'NILL)) + (* ; + "RMK: Terminal is CR, even if stream default is LF") + (if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of TERMINAL.STREAM)) + 'NILL)) then + (* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.") - (* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.") - - (replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE - 'FDEV DEV))) - (* ; - "Copy the basic linebuffer device") - (replace (FDEV EOFP) of DEV with EOFMETHOD)) + (replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE 'FDEV DEV))) + (* ; "Copy the basic linebuffer device") + (replace (FDEV EOFP) of DEV with EOFMETHOD)) STREAM]) (\LINEBUF.READP @@ -1142,20 +1133,19 @@ Copyright (c) 1982-1988, 1990, 2021 by Venue & Xerox Corporation. (ADDTOVAR LAMA VIDEOCOLOR TERMINAL-OUTPUT TERMINAL-INPUT) ) -(PUTPROPS ATERM COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 2021)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2982 32059 (BKLINBUF 2992 . 3467) (CLEARBUF 3469 . 4801) (LINBUF 4803 . 4989) ( -PAGEFULLFN 4991 . 6472) (SETLINELENGTH 6474 . 6670) (SYSBUF 6672 . 6858) (TERMCHARWIDTH 6860 . 7277) ( -TERMINAL-INPUT 7279 . 7847) (TERMINAL-OUTPUT 7849 . 8435) (\CHDEL1 8437 . 8826) (\CLOSELINE 8828 . -9117) (\DECPARENCOUNT 9119 . 10702) (\ECHOCHAR 10704 . 11396) (\FILLBUFFER 11398 . 24389) ( -\FILLBUFFER.WORDSEPRP 24391 . 24636) (\FILLBUFFER.BACKUP 24638 . 24817) (\GETCHAR 24819 . 25208) ( -\INCPARENCOUNT 25210 . 27822) (\RESETLINE 27824 . 28148) (\RESETTERMINAL 28150 . 28914) (\SAVELINEBUF -28916 . 30887) (\STOPSCROLL? 30889 . 32057)) (32262 36118 (\DSCCOUT 32272 . 35412) (\INITBCPLDISPLAY -35414 . 36116)) (36311 37561 (VIDEOCOLOR 36321 . 37559)) (38329 44183 (\PEEKREFILL 38339 . 42450) ( -\READREFILL 42452 . 43046) (\RATOM/RSTRING-REFILL 43048 . 43626) (\READCREFILL 43628 . 44181)) (44184 -46013 (DRIBBLE 44194 . 45795) (DRIBBLEFILE 45797 . 46011)) (46014 52689 (\SETUP.DEFAULT.LINEBUF 46024 - . 48481) (\CREATELINEBUFFER 48483 . 50905) (\LINEBUF.READP 50907 . 51256) (\LINEBUF.EOFP 51258 . -51597) (\LINEBUF.PEEKBIN 51599 . 51806) (\OPENLINEBUF 51808 . 52687)) (52764 54003 (LINEBUFFER-EOFP -52774 . 53232) (LINEBUFFER-SKIPSEPRS 53234 . 54001)) (54360 54634 (\INTERMP 54370 . 54501) (\OUTTERMP -54503 . 54632))))) + (FILEMAP (NIL (2854 31931 (BKLINBUF 2864 . 3339) (CLEARBUF 3341 . 4673) (LINBUF 4675 . 4861) ( +PAGEFULLFN 4863 . 6344) (SETLINELENGTH 6346 . 6542) (SYSBUF 6544 . 6730) (TERMCHARWIDTH 6732 . 7149) ( +TERMINAL-INPUT 7151 . 7719) (TERMINAL-OUTPUT 7721 . 8307) (\CHDEL1 8309 . 8698) (\CLOSELINE 8700 . +8989) (\DECPARENCOUNT 8991 . 10574) (\ECHOCHAR 10576 . 11268) (\FILLBUFFER 11270 . 24261) ( +\FILLBUFFER.WORDSEPRP 24263 . 24508) (\FILLBUFFER.BACKUP 24510 . 24689) (\GETCHAR 24691 . 25080) ( +\INCPARENCOUNT 25082 . 27694) (\RESETLINE 27696 . 28020) (\RESETTERMINAL 28022 . 28786) (\SAVELINEBUF +28788 . 30759) (\STOPSCROLL? 30761 . 31929)) (32134 35990 (\DSCCOUT 32144 . 35284) (\INITBCPLDISPLAY +35286 . 35988)) (36183 37433 (VIDEOCOLOR 36193 . 37431)) (38201 44055 (\PEEKREFILL 38211 . 42322) ( +\READREFILL 42324 . 42918) (\RATOM/RSTRING-REFILL 42920 . 43498) (\READCREFILL 43500 . 44053)) (44056 +45885 (DRIBBLE 44066 . 45667) (DRIBBLEFILE 45669 . 45883)) (45886 52246 (\SETUP.DEFAULT.LINEBUF 45896 + . 48353) (\CREATELINEBUFFER 48355 . 50462) (\LINEBUF.READP 50464 . 50813) (\LINEBUF.EOFP 50815 . +51154) (\LINEBUF.PEEKBIN 51156 . 51363) (\OPENLINEBUF 51365 . 52244)) (52321 53560 (LINEBUFFER-EOFP +52331 . 52789) (LINEBUFFER-SKIPSEPRS 52791 . 53558)) (53917 54191 (\INTERMP 53927 . 54058) (\OUTTERMP +54060 . 54189))))) STOP diff --git a/sources/ATERM.LCOM b/sources/ATERM.LCOM index c4e8dec5..a1b7ecbf 100644 Binary files a/sources/ATERM.LCOM and b/sources/ATERM.LCOM differ diff --git a/sources/BOOTSTRAP b/sources/BOOTSTRAP index 6dc3543d..ebcd8a76 100644 --- a/sources/BOOTSTRAP +++ b/sources/BOOTSTRAP @@ -1,12 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) -(FILECREATED "23-Apr-2025 23:39:10" {WMEDLEY}BOOTSTRAP.;61 47417 +(FILECREATED " 2-Mar-2026 12:03:05" {WMEDLEY}BOOTSTRAP.;71 47856 :EDIT-BY rmk - :CHANGES-TO (FNS PRINT-READER-ENVIRONMENT \DO-DEFINE-FILE-INFO) + :CHANGES-TO (FNS READ-READER-ENVIRONMENT) - :PREVIOUS-DATE "27-Sep-2021 10:25:31" {WMEDLEY}BOOTSTRAP.;59) + :PREVIOUS-DATE "25-Feb-2026 15:03:24" {WMEDLEY}BOOTSTRAP.;69) (PRETTYCOMPRINT BOOTSTRAPCOMS) @@ -365,15 +365,15 @@ (\LOAD-STREAM [LAMBDA (STREAM LDFLG PRINTFLG LOAD-VERBOSE-STREAM PACKAGE) - (DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM)) - (* ; "Edited 17-Jul-2021 21:58 by rmk:") + (DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM)) (* ; "Edited 25-Feb-2026 13:46 by rmk") + (* ; "Edited 17-Jul-2021 21:58 by rmk:") -(* ;;; "Internal function that loads from an already open stream. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.") +(* ;;; "Internal function that loads from an already open stream. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.") (PROG ((*STANDARD-INPUT* STREAM) (FILE (FULLNAME STREAM)) (*PACKAGE* *PACKAGE*) - (*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read") + (*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read") )) (DFNFLG DFNFLG) (BUILDMAPFLG BUILDMAPFLG) @@ -385,176 +385,168 @@ FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P FILECREATEDLOC) (DECLARE (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST - DEFINEDENV FILECREATEDLOC FILE)) + DEFINEDENV FILECREATEDLOC FILE)) (if (AND LOAD-VERBOSE-STREAM FILE) then (LISPXTERPRI LOAD-VERBOSE-STREAM) - (if (NEQ LOAD-VERBOSE-STREAM T) - then (* ; - "CL:LOAD says to prefix this stuff with comment marker") - (PRIN1 "; Loading " LOAD-VERBOSE-STREAM)) - (* ; - "Might use EXEC-FORMAT here except that it isn't defined early in loadup") - (LISPXPRIN1 FILE LOAD-VERBOSE-STREAM) - (LISPXTERPRI LOAD-VERBOSE-STREAM)) + (if (NEQ LOAD-VERBOSE-STREAM T) + then (* ; + "CL:LOAD says to prefix this stuff with comment marker") + (PRIN1 "; Loading " LOAD-VERBOSE-STREAM)) + (* ; + "Might use EXEC-FORMAT here except that it isn't defined early in loadup") + (LISPXPRIN1 FILE LOAD-VERBOSE-STREAM) + (LISPXTERPRI LOAD-VERBOSE-STREAM)) (if (EQ (SETQ DFNFLG LDFLG) - 'SYSLOAD) + 'SYSLOAD) then (SETQ DFNFLG T) - (SETQ ADDSPELLFLG NIL) - (SETQ BUILDMAPFLG NIL) - (SETQ FILEPKGFLG NIL) - (SETQ LISPXHIST NIL)) + (SETQ ADDSPELLFLG NIL) + (SETQ BUILDMAPFLG NIL) + (SETQ FILEPKGFLG NIL) + (SETQ LISPXHIST NIL)) (if LISPXHIST - then (* ; - "Want UNDOSAVE to keep saving regardless of how many undosaves are involved") - (if (SETQ LOADA (FMEMB 'SIDE LISPXHIST)) - then (FRPLACA (CADR LOADA) - -1) - else (LISPXPUT 'SIDE (LIST -1) - NIL LISPXHIST))) + then (* ; + "Want UNDOSAVE to keep saving regardless of how many undosaves are involved") + (if (SETQ LOADA (FMEMB 'SIDE LISPXHIST)) + then (FRPLACA (CADR LOADA) + -1) + else (LISPXPUT 'SIDE (LIST -1) + NIL LISPXHIST))) (if (EQ (SETQ TEM (SKIPSEPRCODES STREAM)) - FASL:SIGNATURE) - then (* ; - "FASL file handled by FASL loader") - (FASL:PROCESS-FILE STREAM) - [LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T)) - 'FILEDATES] - (if (NOT (MEMB FILE LOADEDFILELST)) - then (* ; - "Keep track of every file loaded.") - (SETQ LOADEDFILELST (CONS FILE LOADEDFILELST))) - (if MANAGED-FILE-P - then (if (EQ LDFLG 'SYSLOAD) - then + FASL:SIGNATURE) + then (* ; "FASL file handled by FASL loader") + (FASL:PROCESS-FILE STREAM) + [LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T)) + 'FILEDATES] + (if (NOT (MEMB FILE LOADEDFILELST)) + then (* ; "Keep track of every file loaded.") + (SETQ LOADEDFILELST (CONS FILE LOADEDFILELST))) + (if MANAGED-FILE-P + then (if (EQ LDFLG 'SYSLOAD) + then + (* ;; + "Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag") - (* ;; - "Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag") - - (if (NOT (MEMB ROOTNAME SYSFILES)) - then (SETQ SYSFILES (NCONC1 SYSFILES - ROOTNAME))) - (SMASHFILECOMS ROOTNAME) - elseif FILEPKGFLG - then (ADDFILE ROOTNAME 'Compiled] - (RETURN FILE) + (if (NOT (MEMB ROOTNAME SYSFILES)) + then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME))) + (SMASHFILECOMS ROOTNAME) + elseif FILEPKGFLG + then (ADDFILE ROOTNAME 'Compiled] + (RETURN FILE) elseif (NEQ TEM (CHARCODE "(")) then (RETURN (\CML-LOAD STREAM PRINTFLG LOAD-VERBOSE-STREAM PACKAGE))) (if (AND BUILDMAPFLG (RANDACCESSP STREAM)) then (SETQ MAYBEWANTFILEMAP T)) - (* ;; "Get the environment from the DEFINE-FILE-INFO expression. This is read in the DEFINE-FILE-INFO-ENVIRONMENT.") + (* ;; "Get the environment from the DEFINE-FILE-INFO expression. This is read in the DEFINE-FILE-INFO-ENVIRONMENT.") - (SETQ DEFINEDENV (READ-READER-ENVIRONMENT STREAM *OLD-INTERLISP-READ-ENVIRONMENT*)) + (SETQ DEFINEDENV (READ-READER-ENVIRONMENT STREAM)) (CL:WHEN PACKAGE - (* ;; "Caller better really mean it--overrides what's on file! But we don't want to smash what the reader returned, couldbe the old-interlisp-file-env.") + (* ;; "Caller better really mean it--overrides what's on file! But we don't want to smash what the reader returned, couldbe the old-interlisp-file-env.") [SETQ DEFINEDENV (CREATE READER-ENVIRONMENT USING DEFINEDENV REPACKAGE _ - (SETQ *PACKAGE* - (\DTEST PACKAGE 'PACKAGE]) + (SETQ *PACKAGE* (\DTEST PACKAGE + 'PACKAGE]) - (* ;; "At this point we have the environment for the file, the external format is set. We now read/interpret all the other forms.") + (* ;; "At this point we have the environment for the file, the external format is set. We now read/interpret all the other forms.") (WITH-READER-ENVIRONMENT DEFINEDENV (PROG (ADR) LP (if FILEMAP - then (* ; - "need to build map, so read carefully") - (SETQ LOADA (SKIPSEPRCODES STREAM)) - (if (OR (SYNTAXP LOADA 'LEFTPAREN) - (SYNTAXP LOADA 'LEFTBRACKET)) - then (* ; "See if we have a DEFINEQ") - (SETQ ADR (GETFILEPTR STREAM)) - (READCCODE STREAM) (* ; "Eat paren") - (if (EQ (RATOM STREAM) - 'DEFINEQ) - then (SETQ FNADRLST (TCONC NIL ADR)) - (TCONC FNADRLST NIL) - (TCONC FILEMAP (CAR FNADRLST)) - (GO DEFQLP)) - (* ; "Not a DEFINEQ, so back out") - (SETFILEPTR STREAM ADR))) + then (* ; + "need to build map, so read carefully") + (SETQ LOADA (SKIPSEPRCODES STREAM)) + (if (OR (SYNTAXP LOADA 'LEFTPAREN) + (SYNTAXP LOADA 'LEFTBRACKET)) + then (* ; "See if we have a DEFINEQ") + (SETQ ADR (GETFILEPTR STREAM)) + (READCCODE STREAM) (* ; "Eat paren") + (if (EQ (RATOM STREAM) + 'DEFINEQ) + then (SETQ FNADRLST (TCONC NIL ADR)) + (TCONC FNADRLST NIL) + (TCONC FILEMAP (CAR FNADRLST)) + (GO DEFQLP)) (* ; "Not a DEFINEQ, so back out") + (SETFILEPTR STREAM ADR))) (SELECTQ (SETQ LOADA (READ STREAM)) - ((STOP NIL) - (if (EQ LDFLG 'SYSLOAD) - then (if (NOT (MEMB (SETQ ROOTNAME - (ROOTFILENAME FILE - (CDR FILECREATEDLST))) - SYSFILES)) - then (SETQ SYSFILES (NCONC1 SYSFILES - ROOTNAME))) - (SMASHFILECOMS ROOTNAME) - elseif FILEPKGFLG - then + ((STOP NIL) + (if (EQ LDFLG 'SYSLOAD) + then (if (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR + FILECREATEDLST + ))) + SYSFILES)) + then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME))) + (SMASHFILECOMS ROOTNAME) + elseif FILEPKGFLG + then - (* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.") + (* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.") - (ADDFILE FILE T PRLST FILECREATEDLST)) - [if FILEMAP - then (PUTFILEMAP FILE (CAR FILEMAP) - FILECREATEDLST DEFINEDENV NIL FILECREATEDLOC) - (if UPDATEMAPFLG - then (SETFILEPTR STREAM ADR) - (* ; - "address of last expression read. good hint for finding filemap") - (UPDATEFILEMAP STREAM (CAR FILEMAP] - (if (NOT (MEMB FILE LOADEDFILELST)) - then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST))) - (RETURN)) - NIL) + (ADDFILE FILE T PRLST FILECREATEDLST)) + [if FILEMAP + then (PUTFILEMAP FILE (CAR FILEMAP) + FILECREATEDLST DEFINEDENV NIL FILECREATEDLOC) + (if UPDATEMAPFLG + then (SETFILEPTR STREAM ADR) + (* ; + "address of last expression read. good hint for finding filemap") + (UPDATEFILEMAP STREAM (CAR FILEMAP] + (if (NOT (MEMB FILE LOADEDFILELST)) + then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST))) + (RETURN)) + NIL) [if (LISTP LOADA) then (SELECTQ (CAR LOADA) - (FILECREATED (if MAYBEWANTFILEMAP - then (* ; "See if we have a valid file map") - (SETQ ADR (GETFILEPTR STREAM)) - (if [AND (FIXP (SETQ TEM (CADDDR LOADA))) - [SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM - TEM) - (READ STREAM] - (EQ (CAR TEM) - 'FILEMAP) - (NULL (CAR (SETQ TEM (CADR TEM] - then (* ; "Has ok map") - (PUTFILEMAP FILE TEM NIL DEFINEDENV) - else (* ; - "Need to build a file map as we go") - (SETQ FILEMAP (TCONC NIL NIL))) - (SETFILEPTR STREAM ADR) - (SETQ MAYBEWANTFILEMAP NIL)) - (SETQ LOADA (\EVAL LOADA))) - (SETQ LOADA (\EVAL LOADA))) - else (* ; - "Atom found. Compiled code definition.") - (if ADDSPELLFLG - then (ADDSPELL LOADA)) - (if FILEMAP - then (SETQ ADR (GETFILEPTR STREAM))) - (LAPRD LOADA) - (if FILEMAP - then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM) - LOADA] + (FILECREATED (if MAYBEWANTFILEMAP + then (* ; "See if we have a valid file map") + (SETQ ADR (GETFILEPTR STREAM)) + (if [AND (FIXP (SETQ TEM (CADDDR LOADA))) + [SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM + TEM) + (READ STREAM] + (EQ (CAR TEM) + 'FILEMAP) + (NULL (CAR (SETQ TEM (CADR TEM] + then (* ; "Has ok map") + (PUTFILEMAP FILE TEM NIL DEFINEDENV) + else (* ; "Need to build a file map as we go") + (SETQ FILEMAP (TCONC NIL NIL))) + (SETFILEPTR STREAM ADR) + (SETQ MAYBEWANTFILEMAP NIL)) + (SETQ LOADA (\EVAL LOADA))) + (SETQ LOADA (\EVAL LOADA))) + else (* ; + "Atom found. Compiled code definition.") + (if ADDSPELLFLG + then (ADDSPELL LOADA)) + (if FILEMAP + then (SETQ ADR (GETFILEPTR STREAM))) + (LAPRD LOADA) + (if FILEMAP + then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM) + LOADA] LP1 (if PRINTFLG then (PRINT LOADA PRINTFLG)) (GO LP) DEFQLP (SELCHARQ (SKIPSEPRCODES STREAM) - ((%) %]) (* ; "Closes DEFINEQ.") + ((%) %]) (* ; "Closes DEFINEQ.") (READCCODE STREAM) (if FNADRLST then (RPLACA (CDAR FNADRLST) - (GETFILEPTR STREAM))) - (* ; - "FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.") + (GETFILEPTR STREAM))) + (* ; + "FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.") (SETQ LOADA (DEFINE (DREVERSE LOADA))) (GO LP1)) - ((%( %[) (* ; - "another function/definition pair") + ((%( %[) (* ; "another function/definition pair") (SETQ ADR (GETFILEPTR STREAM)) (SETQ LOADA (CONS (READ STREAM) LOADA)) [if FNADRLST then (TCONC FNADRLST (CONS (CAAR LOADA) - (CONS ADR (GETFILEPTR STREAM] + (CONS ADR (GETFILEPTR STREAM] (GO DEFQLP)) NIL) (ERROR "illegal argument in defineq"))) @@ -808,73 +800,82 @@ (TERPRI STREAM)))]) (READ-READER-ENVIRONMENT - [LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 26-Sep-2021 23:31 by rmk:") + [LAMBDA (STREAM DEFAULTENV RETURNFORM) (* ; "Edited 2-Mar-2026 12:03 by rmk") + (* ; "Edited 1-Mar-2026 10:49 by rmk") + (* ; "Edited 25-Feb-2026 14:15 by rmk") + (* ; "Edited 26-Sep-2021 23:31 by rmk:") (* ;; "Starting environment is the old interlisp file, just for the seprchar scans.") + (* ;; "On exit, if the stream begins with a DEFINE-FILE-INFO expression, it is positioned just after that expression. If not, it is left at its starting position. ") + (* ;; "RETURNFORM=T means return the DEFINE-FILE-INFO as a second value, for READFILE") - (CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*)) - (LET ((START (GETFILEPTR STREAM)) - ARGS - (ENV DEFAULTENV) - (*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF + (if (\GETSTREAM STREAM 'INPUT T) + then (CL:UNLESS DEFAULTENV (SETQ DEFAULTENV *OLD-INTERLISP-READ-ENVIRONMENT*)) + (LET ((START (GETFILEPTR STREAM)) + ARGS + (ENV DEFAULTENV) + (*READTABLE* (FETCH (READER-ENVIRONMENT REREADTABLE) OF *OLD-INTERLISP-READ-ENVIRONMENT* - ))) - (DECLARE (SPECVARS *READTABLE*)) - (SELCHARQ (SKIPSEPRCODES STREAM) - (";" (* ; "Assume it's a common lisp file") - (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF + ))) + (DECLARE (SPECVARS *READTABLE*)) + (SETFILEPTR STREAM 0) (* ; "Hope we are RANDACCESSP") + (SELCHARQ (SKIPSEPRCODES STREAM) + (";" (* ; "Assume it's a common lisp file") + (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF *COMMON-LISP-READ-ENVIRONMENT* - )) - *COMMON-LISP-READ-ENVIRONMENT*) - ("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF + )) + *COMMON-LISP-READ-ENVIRONMENT*) + ("(" (\EXTERNALFORMAT STREAM (FETCH (READER-ENVIRONMENT REFORMAT) OF *DEFINE-FILE-INFO-ENV* - )) (* ; - "Should we reset the format if we fail?") - (READCCODE STREAM) - (WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV* - (IF (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM)) - THEN + ))(* ; + "Should we reset the format if we fail?") + (READCCODE STREAM) + (WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV* + (if (STREQUAL "DEFINE-FILE-INFO" (RSTRING STREAM)) + then + (* ;; + "After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.") - (* ;; - "After the \DO-DEFINE-FILE-INFO, we have the new environment and we have set the new format.") + (SETQ ARGS (CL:READ-DELIMITED-LIST (CHARCODE ")") + STREAM)) + (SETQ ENV (\DO-DEFINE-FILE-INFO STREAM ARGS)) + else (SETFILEPTR STREAM START)) - [SETQ ENV (\DO-DEFINE-FILE-INFO STREAM (SETQ ARGS - (CL:READ-DELIMITED-LIST - (CHARCODE ")") - STREAM] - ELSE (* ; "Hope we are RANDACCESSP") - (SETFILEPTR STREAM START)) + (* ;; + "If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.") - (* ;; - "If we didn't see ARGS, then we didn't see a DEFINE-FILE-INFO, no form to return.") - - (CL:IF (AND RETURNFORM ARGS) - (CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS)) - ENV))) - DEFAULTENV]) + (CL:IF (AND RETURNFORM ARGS) + (CL:VALUES ENV (CONS 'DEFINE-FILE-INFO ARGS)) + ENV))) + DEFAULTENV)) + else (CL:WITH-OPEN-FILE (STRM (OR (FINDFILE STREAM T) + STREAM) + :DIRECTION :INPUT) + (READ-READER-ENVIRONMENT STRM DEFAULTENV RETURNFORM]) (MAKE-DEFINE-FILE-INFO-ENV - [LAMBDA NIL (* ; "Edited 29-Jul-2021 20:29 by rmk:") + [LAMBDA NIL (* ; "Edited 25-Feb-2026 15:03 by rmk") + (* ; "Edited 29-Jul-2021 20:29 by rmk:") - (* ;; "Makes the reader environment and read table used for printing and reading the DEFINE-FILE-INFO expression. Like the OLD-INTERLISP-FILE, but : is the preferred package delim") + (* ;; "Makes the reader environment and read table used for printing and reading the DEFINE-FILE-INFO expression. Like the OLD-INTERLISP-FILE, but : is the preferred package delim") (LET [(RTBL (COPYREADTABLE (FETCH REREADTABLE OF *OLD-INTERLISP-READ-ENVIRONMENT*] - (* ;; - "But this is all rather silly: Why not just have ordinary Interlisp atoms for the key words. ") - (* (READTABLEPROP RTBL - (QUOTE PACKAGECHAR) - (CHARCODE %:))) + (* ;; + "But this is all rather silly: Why not just have ordinary Interlisp atoms for the key words. ") + (* (READTABLEPROP RTBL + (QUOTE PACKAGECHAR) (CHARCODE %:))) (SETSYNTAX (CHARCODE %:) - 'PACKAGEDELIM RTBL) (* ; - "In transition: read : but don't yet put it out") + 'PACKAGEDELIM RTBL) + (replace (READTABLEP PACKAGECHAR) of RTBL with (CHARCODE %:)) + (* ; + "Use : instead of ^^ for printing too") - (* ;; "The INTERLISP package doesn't exist in bootstrap, the REPACKAGE field is filled in in PACKAGE-ENABLE in PACKAGE-STARTUP") + (* ;; "The INTERLISP package doesn't exist in bootstrap, the REPACKAGE field is filled in in PACKAGE-ENABLE in PACKAGE-STARTUP") - (CREATE READER-ENVIRONMENT USING *OLD-INTERLISP-READ-ENVIRONMENT* REREADTABLE _ RTBL - ]) + (CREATE READER-ENVIRONMENT USING *OLD-INTERLISP-READ-ENVIRONMENT* REREADTABLE _ RTBL]) ) (RPAQ? *DEFINE-FILE-INFO-ENV* (MAKE-DEFINE-FILE-INFO-ENV)) @@ -977,13 +978,13 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (4617 14289 (GETPROP 4627 . 5199) (SETATOMVAL 5201 . 5330) (RPAQQ 5332 . 5385) (RPAQ -5387 . 5699) (RPAQ? 5701 . 6071) (MOVD 6073 . 7937) (MOVD? 7939 . 8369) (SELECTQ 8371 . 8558) ( -SELECTQ1 8560 . 8902) (NCONC1 8904 . 9100) (PUTPROP 9102 . 10586) (PROPNAMES 10588 . 10779) (ADDPROP -10781 . 12844) (REMPROP 12846 . 13700) (MEMB 13702 . 13961) (CLOSEF? 13963 . 14287)) (14362 34926 ( -LOAD 14372 . 15541) (\LOAD-STREAM 15543 . 28617) (FILECREATED 28619 . 30037) (FILECREATED1 30039 . -31147) (PRETTYCOMPRINT 31149 . 31634) (BOOTSTRAP-NAMEFIELD 31636 . 32596) (PUTPROPS 32598 . 32966) ( -DECLARE%: 32968 . 33100) (DECLARE%:1 33102 . 33974) (ROOTFILENAME 33976 . 34924)) (34964 45363 ( -DEFINE-FILE-INFO 34974 . 35409) (\DO-DEFINE-FILE-INFO 35411 . 39554) (PRINT-READER-ENVIRONMENT 39556 - . 41308) (READ-READER-ENVIRONMENT 41310 . 44085) (MAKE-DEFINE-FILE-INFO-ENV 44087 . 45361))))) + (FILEMAP (NIL (4595 14267 (GETPROP 4605 . 5177) (SETATOMVAL 5179 . 5308) (RPAQQ 5310 . 5363) (RPAQ +5365 . 5677) (RPAQ? 5679 . 6049) (MOVD 6051 . 7915) (MOVD? 7917 . 8347) (SELECTQ 8349 . 8536) ( +SELECTQ1 8538 . 8880) (NCONC1 8882 . 9078) (PUTPROP 9080 . 10564) (PROPNAMES 10566 . 10757) (ADDPROP +10759 . 12822) (REMPROP 12824 . 13678) (MEMB 13680 . 13939) (CLOSEF? 13941 . 14265)) (14340 34317 ( +LOAD 14350 . 15519) (\LOAD-STREAM 15521 . 28008) (FILECREATED 28010 . 29428) (FILECREATED1 29430 . +30538) (PRETTYCOMPRINT 30540 . 31025) (BOOTSTRAP-NAMEFIELD 31027 . 31987) (PUTPROPS 31989 . 32357) ( +DECLARE%: 32359 . 32491) (DECLARE%:1 32493 . 33365) (ROOTFILENAME 33367 . 34315)) (34355 45802 ( +DEFINE-FILE-INFO 34365 . 34800) (\DO-DEFINE-FILE-INFO 34802 . 38945) (PRINT-READER-ENVIRONMENT 38947 + . 40699) (READ-READER-ENVIRONMENT 40701 . 44368) (MAKE-DEFINE-FILE-INFO-ENV 44370 . 45800))))) STOP diff --git a/sources/BOOTSTRAP.LCOM b/sources/BOOTSTRAP.LCOM index ea5f8795..74f0d1d8 100644 Binary files a/sources/BOOTSTRAP.LCOM and b/sources/BOOTSTRAP.LCOM differ diff --git a/sources/CLISP b/sources/CLISP index e0c640c0..35ec32c1 100644 --- a/sources/CLISP +++ b/sources/CLISP @@ -1,18 +1,11 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "16-May-90 12:27:02" {DSK}local>lde>lispcore>sources>CLISP.;2 45083 +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) - changes to%: (VARS CLISPCOMS) +(FILECREATED "19-Feb-2026 12:00:55" {WMEDLEY}CLISP.;2 44501 - previous date%: "26-Nov-86 12:32:58" {DSK}local>lde>lispcore>sources>CLISP.;1) + :EDIT-BY rmk + :PREVIOUS-DATE "16-May-90 12:27:02" {WMEDLEY}CLISP.;1) -(* ; " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. -The following program was created in 1982 but has not been published -within the meaning of the copyright law, is furnished under license, -and may not be used, copied and/or disclosed except in accordance -with the terms of said license. -") (PRETTYCOMPRINT CLISPCOMS) @@ -57,16 +50,16 @@ with the terms of said license. (COMS (* CLISP props) (PROP CLISPTYPE %') [E (SETQQ CLISPCHARS - (^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­)) + (↑ * / + - = ↠%: %' ~ +- ~= < > @ ! _ ^)) (CLISPDEC '(STANDARD MIXED] [VARS (CLISPFLG T) - (CLISPCHARS '(^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­] + (CLISPCHARS '(↑ * / + - = ↠%: %' ~ +- ~= < > @ ! _ ^] (INITVARS (CLISPHELPFLG T) (TREATASCLISPFLG) (CLISPINFIXSPLST) (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) - [LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(_ ¬] - (LEFT.ARROW '_) + [LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(↠_] + (LEFT.ARROW 'â†) (CLISPISWORDSPLST) (CLISPLASTSUB (CONS)) (CHECKCARATOMFLG) @@ -74,7 +67,7 @@ with the terms of said license. (CLISPARITHCLASSLST '(INTEGER FIXED MIXED FLOATING)) (DWIMINMACROSFLG NIL)) (IFPROP (CLISPTYPE LISPFN UNARYOP CLISPCLASS CLISPCLASSDEF CLISPNEG CLISPBRACKET) - ­ ^ * / + - = _ ¬ %: %' ~ +- ~= < > @ !) + ^ ↑ * / + - = ↠_ %: %' ~ +- ~= < > @ !) (VARS DECLWORDS) (IFPROP (CLISPTYPE LISPFN UNARYOP CLISPINFIX CLISPCLASS CLISPCLASSDEF CLISPNEG BROADSCOPE) @@ -160,34 +153,14 @@ with the terms of said license. (RPAQ? RPARKEY 0) -(RPAQ? WTFIXCHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL - NIL NIL)) +(RPAQ? WTFIXCHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL + NIL)) -(RPAQ? WTFIXCHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL - NIL NIL)) +(RPAQ? WTFIXCHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL + NIL)) (ADDTOVAR EDITMACROS - (FIX9 (X N) - (BIND (E (SETQ %#1 (EDITFPAT 'X)) - T) - (IF (NOT (ATOM (%##))) - (1)) - (COMS (SPLIT89 RPARKEY N)) - (I F RPARKEY T) - (E [SETQ %#2 (ADD1 (LENGTH (CAR L] - T) - !0 MARK (LPQ [IF (OR (NULL %#1) - (NOT (EDIT4E %#1 (%## 1] - UP - (E (SETQ %#3 (LENGTH (CAR L))) - T) - (I RI 1 (MINUS %#2)) - (E (SETQ %#2 %#3) - T) - 1 !0) - __ - (DELETE NX))) - (FIX9 NIL (FIX9)) + (FIX8 NIL (FIX8)) (FIX8 (X N) (BIND (E (SETQ %#1 (EDITFPAT 'X)) T) @@ -206,14 +179,34 @@ with the terms of said license. UP (RO 1) !0))) - (FIX8 NIL (FIX8))) + (FIX9 NIL (FIX9)) + (FIX9 (X N) + (BIND (E (SETQ %#1 (EDITFPAT 'X)) + T) + (IF (NOT (ATOM (%##))) + (1)) + (COMS (SPLIT89 RPARKEY N)) + (I F RPARKEY T) + (E [SETQ %#2 (ADD1 (LENGTH (CAR L] + T) + !0 MARK (LPQ [IF (OR (NULL %#1) + (NOT (EDIT4E %#1 (%## 1] + UP + (E (SETQ %#3 (LENGTH (CAR L))) + T) + (I RI 1 (MINUS %#2)) + (E (SETQ %#2 %#3) + T) + 1 !0) + â†â† + (DELETE NX)))) (ADDTOVAR DWIMUSERFORMS ) (ADDTOVAR LAMBDASPLST LAMBDA NLAMBDA) -(ADDTOVAR OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1 - APPEND NEQ NOT NULL) +(ADDTOVAR OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1 APPEND + NEQ NOT NULL) (ADDTOVAR NOFIXFNSLST ) @@ -266,6 +259,17 @@ with the terms of said license. (ADDTOVAR DWIMEQUIVLST ) (ADDTOVAR EDITMACROS + (CLISP%: NIL (BIND (E (COND ((SETQ %#1 (AND CLISPARRAY (GETHASH (%##) + CLISPARRAY))) + (SETQQ COM CLISP%:) + (EDITE %#1)) + (T (PRIN1 '"not translated. +" T))) + T))) + (NOCLISP COMS (RESETVAR CLISPTRANFLG NIL . COMS)) + (NOCLISP NIL (NOCLISP TTY%:)) + (!DW NIL (RESETVAR CLISPRETRANFLG T DW)) + (PPT NIL (RESETVAR PRETTYTRANFLG T PP)) (DW NIL (BIND (E (PROGN (SETQ %#1 (%##)) (AND (CDR L) (%## !0 (E (SETQ %#2 L) @@ -280,18 +284,7 @@ with the terms of said license. (IF (LISTP %#3) (1) NIL)) - NIL))) - (PPT NIL (RESETVAR PRETTYTRANFLG T PP)) - (!DW NIL (RESETVAR CLISPRETRANFLG T DW)) - (NOCLISP NIL (NOCLISP TTY%:)) - (NOCLISP COMS (RESETVAR CLISPTRANFLG NIL . COMS)) - (CLISP%: NIL (BIND (E (COND ((SETQ %#1 (AND CLISPARRAY (GETHASH (%##) - CLISPARRAY))) - (SETQQ COM CLISP%:) - (EDITE %#1)) - (T (PRIN1 '"not translated. -" T))) - T)))) + NIL)))) (ADDTOVAR EDITCOMSA PPT DW !DW CLISP%:) @@ -304,7 +297,7 @@ with the terms of said license. (RPAQQ CLISPFLG T) -(RPAQQ CLISPCHARS (^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­)) +(RPAQQ CLISPCHARS (↑ * / + - = ↠%: %' ~ +- ~= < > @ ! _ ^)) (RPAQ? CLISPHELPFLG T) @@ -314,9 +307,9 @@ with the terms of said license. (RPAQ? CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) -(RPAQ? LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(_ ¬))) +(RPAQ? LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(↠_))) -(RPAQ? LEFT.ARROW '_) +(RPAQ? LEFT.ARROW 'â†) (RPAQ? CLISPISWORDSPLST ) @@ -330,10 +323,10 @@ with the terms of said license. (RPAQ? DWIMINMACROSFLG NIL) -(PUTPROPS ­ CLISPTYPE 6) - (PUTPROPS ^ CLISPTYPE 6) +(PUTPROPS ↑ CLISPTYPE 6) + (PUTPROPS * CLISPTYPE 4) (PUTPROPS / CLISPTYPE 4) @@ -344,9 +337,9 @@ with the terms of said license. (PUTPROPS = CLISPTYPE -20) -(PUTPROPS _ CLISPTYPE (8 . -12)) +(PUTPROPS ↠CLISPTYPE (8 . -12)) -(PUTPROPS ¬ CLISPTYPE (8 . -12)) +(PUTPROPS _ CLISPTYPE (8 . -12)) (PUTPROPS %: CLISPTYPE (14 . 13)) @@ -360,10 +353,10 @@ with the terms of said license. (PUTPROPS > CLISPTYPE BRACKET) -(PUTPROPS ­ LISPFN EXPT) - (PUTPROPS ^ LISPFN EXPT) +(PUTPROPS ↑ LISPFN EXPT) + (PUTPROPS * LISPFN TIMES) (PUTPROPS / LISPFN QUOTIENT) @@ -374,9 +367,9 @@ with the terms of said license. (PUTPROPS = LISPFN EQ) -(PUTPROPS _ LISPFN SETQ) +(PUTPROPS ↠LISPFN SETQ) -(PUTPROPS ¬ LISPFN SETQ) +(PUTPROPS _ LISPFN SETQ) (PUTPROPS %' LISPFN QUOTE) @@ -750,7 +743,7 @@ with the terms of said license. (PUTPROPS OR CLISPINFIX or) -(PUTPROPS SETQ CLISPINFIX _) +(PUTPROPS SETQ CLISPINFIX â†) (PUTPROPS IPLUS CLISPINFIX +) @@ -780,7 +773,7 @@ with the terms of said license. (PUTPROPS GREATERP CLISPINFIX gt) -(PUTPROPS EXPT CLISPINFIX ^) +(PUTPROPS EXPT CLISPINFIX ↑) (PUTPROPS LT CLISPCLASS LT) @@ -931,7 +924,7 @@ with the terms of said license. (PUTPROPS SETA SETFN (ELT)) (DEFOPTIMIZER CLISP%  (X &REST Y) - X) + X) (PUTPROPS AND CLISPWORD T) @@ -1146,83 +1139,82 @@ with the terms of said license. (PUTPROPS while CLISPWORD (FORWORD . while)) (PUTPROPS always I.S.OPR ((COND ((NULL BODY) - (SETQ $$VAL NIL) - (GO $$OUT))) - BIND - (SETQ $$VAL T))) + (SETQ $$VAL NIL) + (GO $$OUT))) + BIND + (SETQ $$VAL T))) (PUTPROPS collect I.S.OPR ((SETQ $$VAL (NCONC1 $$VAL BODY)))) (PUTPROPS count I.S.OPR ((AND BODY (SETQ $$VAL (ADD1 $$VAL))) - BIND - ($$VAL _ 0))) + BIND + ($$VAL ↠0))) (PUTPROPS do I.S.OPR (BODY)) (PUTPROPS fcollect I.S.OPR [(= SUBPAIR '(VAR1 VAR2) - (LIST (GETDUMMYVAR T) - (GETDUMMYVAR T)) - '(PROGN (SETQ VAR1 BODY) - (COND [VAR2 (FRPLACD VAR2 (SETQ VAR2 (LIST VAR1] - (T (SETQ $$VAL (SETQ VAR2 (LIST VAR1]) + (LIST (GETDUMMYVAR T) + (GETDUMMYVAR T)) + '(PROGN (SETQ VAR1 BODY) + (COND [VAR2 (FRPLACD VAR2 (SETQ VAR2 (LIST VAR1] + (T (SETQ $$VAL (SETQ VAR2 (LIST VAR1]) (PUTPROPS inside I.S.OPR [NIL = SUBST (GETDUMMYVAR) - 'VAR - '(bind (VAR _ BODY) - eachtime - (COND ((NULL VAR) - (GO $$OUT)) - ((NLISTP VAR) - (SETQ I.V. VAR) - (SETQ VAR NIL)) - (T (SETQ I.V. (CAR VAR)) - (SETQ VAR (CDR VAR]) + 'VAR + '(bind (VAR ↠BODY) + eachtime + (COND ((NULL VAR) + (GO $$OUT)) + ((NLISTP VAR) + (SETQ I.V. VAR) + (SETQ VAR NIL)) + (T (SETQ I.V. (CAR VAR)) + (SETQ VAR (CDR VAR]) (PUTPROPS join I.S.OPR ((SETQ $$VAL (NCONC $$VAL BODY)))) (PUTPROPS largest I.S.OPR [NIL = SUBST (GETDUMMYVAR) - '$$TEMP - '(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY) - (COND ((OR (NULL $$EXTREME) - (GREATERP $$TEMP $$EXTREME)) - (SETQ $$EXTREME $$TEMP) - (SETQ $$VAL I.V.]) + '$$TEMP + '(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY) + (COND ((OR (NULL $$EXTREME) + (GREATERP $$TEMP $$EXTREME)) + (SETQ $$EXTREME $$TEMP) + (SETQ $$VAL I.V.]) (PUTPROPS never I.S.OPR ((COND (BODY (SETQ $$VAL NIL) - (GO $$OUT))) - BIND - ($$VAL _ T))) + (GO $$OUT))) + BIND + ($$VAL ↠T))) (PUTPROPS old I.S.OPR MODIFIER) (PUTPROPS smallest I.S.OPR [NIL = SUBST (GETDUMMYVAR) - '$$TEMP - '(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY) - (COND ((OR (NULL $$EXTREME) - (LESSP $$TEMP $$EXTREME)) - (SETQ $$EXTREME $$TEMP) - (SETQ $$VAL I.V.]) + '$$TEMP + '(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY) + (COND ((OR (NULL $$EXTREME) + (LESSP $$TEMP $$EXTREME)) + (SETQ $$EXTREME $$TEMP) + (SETQ $$VAL I.V.]) (PUTPROPS sum I.S.OPR ((SETQ $$VAL (PLUS $$VAL BODY)) - BIND - ($$VAL _ 0))) + BIND + ($$VAL ↠0))) (PUTPROPS thereis I.S.OPR [(COND (BODY (SETQ $$VAL (OR I.V. T)) - (GO $$OUT]) + (GO $$OUT]) -(ADDTOVAR I.S.OPRLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT - FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD - ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU - TO UNLESS UNTIL WHEN WHERE WHILE always as bind by collect count - declare declare%: do eachtime fcollect finally find first for from in - inside isthere join largest never old on original repeatuntil - repeatwhile smallest suchthat sum thereis thru to unless until when - where while) +(ADDTOVAR I.S.OPRLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY + FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL + REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL + WHEN WHERE WHILE always as bind by collect count declare declare%: do + eachtime fcollect finally find first for from in inside isthere join + largest never old on original repeatuntil repeatwhile smallest suchthat + sum thereis thru to unless until when where while) -(ADDTOVAR CLISPFORWORDSPLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME - FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN - LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST - SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE) +(ADDTOVAR CLISPFORWORDSPLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT + FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER + OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM + THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE) (RPAQQ CLISPDUMMYFORVARS ($$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6)) @@ -1241,17 +1233,18 @@ with the terms of said license. (DEFINEQ (DUMPI.S.OPRS - [NLAMBDA X (* lmm "14-Aug-84 18:34") - - (* Dump I.S.OPRS definitions. - - redefined to dump out same case as given) - + [NLAMBDA X (* lmm "14-Aug-84 18:34") + (* Dump I.S.OPRS definitions. + - + redefined to dump out same case as + given) (for Y in X collect (OR (GETDEF.I.S.OPR Y) - (PROG1 NIL (LISPXPRINT (LIST 'I.S.OPR Y 'not 'defined) - T T]) + (PROG1 NIL + (LISPXPRINT (LIST 'I.S.OPR Y 'not 'defined) + T T))]) (GETDEF.I.S.OPR - [LAMBDA (Y) (* lmm "14-Aug-84 18:34") + [LAMBDA (Y) (* lmm "14-Aug-84 18:34") (PROG (TEM BODY EVALFLG) (RETURN (CONS 'I.S.OPR @@ -1279,9 +1272,9 @@ with the terms of said license. [(CDR BODY) (COND (EVALFLG (SHOULDNT))) - - (* somehow there was an = in front of the i.s.type and not in front of the - others. this shouldnt happen) + + (* somehow there was an = in front of the i.s.type and not in front of the + others. this shouldnt happen) (LIST (KWOTE (CDR BODY] (EVALFLG '(NIL T] @@ -1298,11 +1291,11 @@ with the terms of said license. (ADDTOVAR DURATIONCLISPWORDS (TIMERUNITS timerUnits timerunits) - (USINGBOX usingBox usingbox) - (USINGTIMER usingTimer usingtimer) - (FORDURATION forDuration forduration DURING during) - (RESOURCENAME resourceName resourcename) - (UNTILDATE untilDate untildate)) + (USINGBOX usingBox usingbox) + (USINGTIMER usingTimer usingtimer) + (FORDURATION forDuration forduration DURING during) + (RESOURCENAME resourceName resourcename) + (UNTILDATE untilDate untildate)) (PUTPROPS TIMERUNITS CLISPWORD (FORWORD . timerUnits)) @@ -1477,7 +1470,6 @@ with the terms of said license. (ADDTOVAR LAMA ) ) -(PUTPROPS CLISP COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1990)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (37614 40224 (DUMPI.S.OPRS 37624 . 38032) (GETDEF.I.S.OPR 38034 . 40222))))) + (FILEMAP (NIL (36881 39751 (DUMPI.S.OPRS 36891 . 37559) (GETDEF.I.S.OPR 37561 . 39749))))) STOP diff --git a/sources/CLISP.DFASL b/sources/CLISP.DFASL new file mode 100644 index 00000000..6948cd7a Binary files /dev/null and b/sources/CLISP.DFASL differ diff --git a/sources/CLISP.LCOM b/sources/CLISP.LCOM deleted file mode 100644 index cb47bd38..00000000 --- a/sources/CLISP.LCOM +++ /dev/null @@ -1,3 +0,0 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "25-Jan-98 09:32:34" ("compiled on " {DSK}sources>CLISP.;1) "30-Mar-95 20:33:04" "COMPILE-FILEd" in "Medley 14-Aug-95 ..." dated "14-Aug-95 15:27:48") (FILECREATED "16-May-90 12:27:02" {DSK}local>lde>lispcore>sources>CLISP.;2 45083 changes to%: ( VARS CLISPCOMS) previous date%: "26-Nov-86 12:32:58" {DSK}local>lde>lispcore>sources>CLISP.;1) (RPAQQ CLISPCOMS ((COMS (* ; "DWIM stuff") (INITVARS (NOFIXFNSLST0) (NOFIXVARSLST0) (NOSPELLFLG) ( LPARKEY 9) (RPARKEY 0) (WTFIXCHCONLST (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (WTFIXCHCONLST1 (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)))) (USERMACROS FIX8 FIX9) (ADDVARS (DWIMUSERFORMS) (LAMBDASPLST LAMBDA NLAMBDA) (OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1 APPEND NEQ NOT NULL) (NOFIXFNSLST) (NOFIXVARSLST) (GLOBALVARS) (LOCALVARS) (SPECVARS) (NLAMA) (NLAML) (LAMA) ( LAMS)) (P (MOVD? (QUOTE NILL) (QUOTE FREEVARS))) (PROP FILEDEF BREAKDOWN CALLS CLISPRECORD SETUPHASHARRAY MAKEMATCH) (VARS (DWIMIFYFLG (QUOTE EVAL)) (COMPILEUSERFN (QUOTE COMPILEUSERFN)) ( CLISPTRANFLG (QUOTE CLISP% )) (DWIMESSGAG)) (INITVARS (DWIMCHECK#ARGSFLG T) (DWIMCHECKPROGLABELSFLG T) (%#CLISPARRAY 250) (RECORDHASHFLG T) (CLISPRETRANFLG)) (ADDVARS (DWIMEQUIVLST)) (USERMACROS DW !DW CLISP%: NOCLISP PPT)) (COMS (* CLISP props) (PROP CLISPTYPE %') (E (SETQQ CLISPCHARS (^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­)) (CLISPDEC (QUOTE (STANDARD MIXED)))) (VARS (CLISPFLG T) (CLISPCHARS (QUOTE ( ^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­)))) (INITVARS (CLISPHELPFLG T) (TREATASCLISPFLG) ( CLISPINFIXSPLST) (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) (LEFT.ARROWS.BITTABLE (MAKEBITTABLE (QUOTE ( _ ¬)))) (LEFT.ARROW (QUOTE _)) (CLISPISWORDSPLST) (CLISPLASTSUB (CONS)) (CHECKCARATOMFLG) ( CLISPARITHOPLST (QUOTE (+ - * / +- LT GT lt gt GEQ LEQ GE LE geq leq ge le))) (CLISPARITHCLASSLST ( QUOTE (INTEGER FIXED MIXED FLOATING))) (DWIMINMACROSFLG NIL)) (IFPROP (CLISPTYPE LISPFN UNARYOP CLISPCLASS CLISPCLASSDEF CLISPNEG CLISPBRACKET) ­ ^ * / + - = _ ¬ %: %' ~ +- ~= < > @ !) (VARS DECLWORDS) (IFPROP (CLISPTYPE LISPFN UNARYOP CLISPINFIX CLISPCLASS CLISPCLASSDEF CLISPNEG BROADSCOPE) * (PROGN DECLWORDS)) (IFPROP (CLISPTYPE LISPFN UNARYOP CLISPINFIX CLISPCLASS CLISPCLASSDEF CLISPNEG BROADSCOPE) LT lt GT gt LE le GE ge LEQ leq GEQ geq EQ NEQ EQP EQUAL EQUALS NOT AND OR and or NOR nor MEMBER SETQ IPLUS IMINUS IDIFFERENCE ITIMES IQUOTIENT ILESSP IGREATERP FPLUS FMINUS FDIFFERENCE FTIMES FQUOTIENT FGTP PLUS MINUS DIFFERENCE TIMES QUOTIENT LESSP GREATERP EXPT -> =>) (PROP SETFN ELT SETA) (OPTIMIZERS CLISP% )) (PROP CLISPWORD AND OR and or ! !! CLISP clisp MATCH match) (COMS (* IF) (VARS CLISPIFWORDSPLST) (INITVARS (CLISPIFTRANFLG T)) (PROP CLISPWORD IF THEN ELSE ELSEIF if then else elseif)) (COMS (* I.S.OPR) (VARS (CLISPI.S.GAG)) (PROP CLISPWORD * INITISOPRS) (IFPROP I.S.OPR * ( PROGN INITISOPRS)) (ADDVARS * (LIST (CONS (QUOTE I.S.OPRLST) INITISOPRS) (CONS (QUOTE CLISPFORWORDSPLST) (SUBSET INITISOPRS (QUOTE U-CASEP))))) (VARS (CLISPDUMMYFORVARS (QUOTE ($$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6)))) (ADDVARS * (LIST (CONS (QUOTE SYSLOCALVARS) CLISPDUMMYFORVARS) (CONS (QUOTE INVISIBLEVARS) CLISPDUMMYFORVARS))) (ADDVARS (SYSLOCALVARS $$VAL $$TEM $$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6 $$END $$EXTREME) (INVISIBLEVARS $$VAL $$END $$TEM $$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6 $$EXTREME)) (FILEPKGCOMS I.S.OPRS) (FNS DUMPI.S.OPRS GETDEF.I.S.OPR )) (COMS (* forDuration) (ADDVARS (DURATIONCLISPWORDS (TIMERUNITS timerUnits timerunits) (USINGBOX usingBox usingbox) (USINGTIMER usingTimer usingtimer) (FORDURATION forDuration forduration DURING during) (RESOURCENAME resourceName resourcename) (UNTILDATE untilDate untildate))) (IFPROP (CLISPWORD \DURATIONTRAN) * (APPLY (QUOTE APPEND) DURATIONCLISPWORDS)) (RESOURCES \ForDurationOfBox)) (COMS (* ;; "Currently there are four possible entries for the INFO property: EVAL, BINDS, LABELS, PROGN, or a list containg any or all of these." ) (* ;; "EVAL is used to indicate that an nlambda evaluates its arguments. EVAL affects DWIMIFY and CLISPIFY: neither will touch an nlambda that does not have this property." ) (* ;; "BINDS tells clispify and dwimify that CADR of the form is a list of variables being bound, a la prog." ) (* ;; "PROGN says that only the last top level expression is being used for value. This affects the way OR's and AND's are clispified, for example." ) (* ;; "Finally, LABELS indicates that top level atoms in this expression are not being evaluated. This tells clispify not to create atoms out of lists at the top level. LABELS also implies that none of the top level expressions are being used for value." ) (* ;; "For example, FOR has info property just BINDS, (EVAL is unnecssary since FOR is not a function and its dwimifying and clispifying affected by its clispword property), whereas PROG has (BINDS EVAL LABELS), and LAMBDA has (EVAL BINDS PROGN)" ) (PROP INFO PROG PROG* RESETVARS RESETBUFS RESETLST ADV-PROG ADV-SETQ AND ARG COND ERSETQ NLSETQ OR PROG1 PROG2 PROGN RESETFORM RESETSAVE RESETVAR RPAQ RPTQ FRPTQ SAVESETQ SETN SETQ UNDONLSETQ XNLSETQ SETARG LET LET* RETURN)) (PROP FILETYPE CLISP) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DUMPI.S.OPRS) (NLAML) (LAMA))))) (RPAQ? NOFIXFNSLST0) (RPAQ? NOFIXVARSLST0) (RPAQ? NOSPELLFLG) (RPAQ? LPARKEY 9) (RPAQ? RPARKEY 0) (RPAQ? WTFIXCHCONLST (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (RPAQ? WTFIXCHCONLST1 (QUOTE (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) (ADDTOVAR EDITMACROS (FIX9 (X N) (BIND (E (SETQ %#1 (EDITFPAT (QUOTE X))) T) (IF (NOT (ATOM (%##))) (1 )) (COMS (SPLIT89 RPARKEY N)) (I F RPARKEY T) (E (SETQ %#2 (ADD1 (LENGTH (CAR L)))) T) !0 MARK (LPQ ( IF (OR (NULL %#1) (NOT (EDIT4E %#1 (%## 1))))) UP (E (SETQ %#3 (LENGTH (CAR L))) T) (I RI 1 (MINUS %#2 )) (E (SETQ %#2 %#3) T) 1 !0) __ (DELETE NX))) (FIX9 NIL (FIX9)) (FIX8 (X N) (BIND (E (SETQ %#1 ( EDITFPAT (QUOTE X))) T) (IF (LISTP (%##)) (1)) (COMS (SPLIT89 LPARKEY N)) (I F LPARKEY T) (1) (LI 1) ( IF (TAILP (CAR L) (CADR L)) (!0) NIL) (LPQ (IF (OR (NULL %#1) (NOT (EDIT4E %#1 (%## 1))))) UP (RO 1) !0))) (FIX8 NIL (FIX8))) (ADDTOVAR DWIMUSERFORMS) (ADDTOVAR LAMBDASPLST LAMBDA NLAMBDA) (ADDTOVAR OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1 APPEND NEQ NOT NULL) (ADDTOVAR NOFIXFNSLST) (ADDTOVAR NOFIXVARSLST) (ADDTOVAR GLOBALVARS) (ADDTOVAR LOCALVARS) (ADDTOVAR SPECVARS) (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA) (ADDTOVAR LAMS) (MOVD? (QUOTE NILL) (QUOTE FREEVARS)) (PUTPROPS BREAKDOWN FILEDEF BRKDWN) (PUTPROPS CALLS FILEDEF MSANALYZE) (PUTPROPS CLISPRECORD FILEDEF RECORD) (PUTPROPS SETUPHASHARRAY FILEDEF (RECORD SETUPHASHARRAY)) (PUTPROPS MAKEMATCH FILEDEF MATCH) (RPAQQ DWIMIFYFLG EVAL) (RPAQQ COMPILEUSERFN COMPILEUSERFN) (RPAQQ CLISPTRANFLG CLISP% ) (RPAQQ DWIMESSGAG NIL) (RPAQ? DWIMCHECK#ARGSFLG T) (RPAQ? DWIMCHECKPROGLABELSFLG T) (RPAQ? %#CLISPARRAY 250) (RPAQ? RECORDHASHFLG T) (RPAQ? CLISPRETRANFLG) (ADDTOVAR DWIMEQUIVLST) (ADDTOVAR EDITMACROS (DW NIL (BIND (E (PROGN (SETQ %#1 (%##)) (AND (CDR L) (%## !0 (E (SETQ %#2 L) T)) ) (AND (SETQ %#3 (DWIMIFY %#1 T (OR %#2 (QUOTE (NIL))))) EDITCHANGES (RPLACA (CDR EDITCHANGES) T))) T) (IF (NLISTP %#1) ((I %: %#3) (IF (LISTP %#3) (1) NIL)) NIL))) (PPT NIL (RESETVAR PRETTYTRANFLG T PP)) (!DW NIL (RESETVAR CLISPRETRANFLG T DW)) (NOCLISP NIL (NOCLISP TTY%:)) (NOCLISP COMS (RESETVAR CLISPTRANFLG NIL . COMS)) (CLISP%: NIL (BIND (E (COND ((SETQ %#1 (AND CLISPARRAY (GETHASH (%##) CLISPARRAY))) (SETQQ COM CLISP%:) (EDITE %#1)) (T (PRIN1 (QUOTE "not translated. ") T))) T)))) (ADDTOVAR EDITCOMSA PPT DW !DW CLISP%:) (PUTPROPS %' CLISPTYPE 15) (RPAQQ CLISPFLG T) (RPAQQ CLISPCHARS (^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­)) (RPAQ? CLISPHELPFLG T) (RPAQ? TREATASCLISPFLG) (RPAQ? CLISPINFIXSPLST) (RPAQ? CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) (RPAQ? LEFT.ARROWS.BITTABLE (MAKEBITTABLE (QUOTE (_ ¬)))) (RPAQ? LEFT.ARROW (QUOTE _)) (RPAQ? CLISPISWORDSPLST) (RPAQ? CLISPLASTSUB (CONS)) (RPAQ? CHECKCARATOMFLG) (RPAQ? CLISPARITHOPLST (QUOTE (+ - * / +- LT GT lt gt GEQ LEQ GE LE geq leq ge le))) (RPAQ? CLISPARITHCLASSLST (QUOTE (INTEGER FIXED MIXED FLOATING))) (RPAQ? DWIMINMACROSFLG NIL) (PUTPROPS ­ CLISPTYPE 6) (PUTPROPS ^ CLISPTYPE 6) (PUTPROPS * CLISPTYPE 4) (PUTPROPS / CLISPTYPE 4) (PUTPROPS + CLISPTYPE 2) (PUTPROPS - CLISPTYPE 7) (PUTPROPS = CLISPTYPE -20) (PUTPROPS _ CLISPTYPE (8 . -12)) (PUTPROPS ¬ CLISPTYPE (8 . -12)) (PUTPROPS %: CLISPTYPE (14 . 13)) (PUTPROPS %' CLISPTYPE 15) (PUTPROPS ~ CLISPTYPE 7) (PUTPROPS +- CLISPTYPE 2) (PUTPROPS < CLISPTYPE BRACKET) (PUTPROPS > CLISPTYPE BRACKET) (PUTPROPS ­ LISPFN EXPT) (PUTPROPS ^ LISPFN EXPT) (PUTPROPS * LISPFN TIMES) (PUTPROPS / LISPFN QUOTIENT) (PUTPROPS + LISPFN PLUS) (PUTPROPS - LISPFN MINUS) (PUTPROPS = LISPFN EQ) (PUTPROPS _ LISPFN SETQ) (PUTPROPS ¬ LISPFN SETQ) (PUTPROPS %' LISPFN QUOTE) (PUTPROPS ~ LISPFN NOT) (PUTPROPS +- LISPFN DIFFERENCE) (PUTPROPS - UNARYOP T) (PUTPROPS %' UNARYOP T) (PUTPROPS ~ UNARYOP T) (PUTPROPS < UNARYOP T) (PUTPROPS > UNARYOP T) (PUTPROPS * CLISPCLASS *) (PUTPROPS / CLISPCLASS /) (PUTPROPS + CLISPCLASS +) (PUTPROPS - CLISPCLASS -) (PUTPROPS +- CLISPCLASS +-) (PUTPROPS * CLISPCLASSDEF (ARITH ITIMES FTIMES TIMES)) (PUTPROPS / CLISPCLASSDEF (ARITH IQUOTIENT FQUOTIENT QUOTIENT)) (PUTPROPS + CLISPCLASSDEF (ARITH IPLUS FPLUS PLUS)) (PUTPROPS - CLISPCLASSDEF (ARITH IMINUS FMINUS MINUS)) (PUTPROPS +- CLISPCLASSDEF (ARITH IDIFFERENCE FDIFFERENCE DIFFERENCE)) (PUTPROPS = CLISPNEG ~=) (PUTPROPS < CLISPBRACKET (< > SEPARATOR ! DWIMIFY CLISPANGLEBRACKETS CLISPIFY SHRIEKIFY)) (PUTPROPS > CLISPBRACKET (< > SEPARATOR ! DWIMIFY CLISPANGLEBRACKETS CLISPIFY SHRIEKIFY)) (RPAQQ DECLWORDS (FLOATING FAST FFETCHFIELD FETCHFIELD REPLACEFIELD FREPLACEFIELD /REPLACEFIELD /LISTPUT /LISTPUT1 /MAPCON /MAPCONC /NCONC /NCONC1 /PUT /PUTASSOC /PUTHASH /PUTPROP /RPLACA /RPLACD /RPLNODE /RPLNODE2 /SETA ASSOC CLISPIFY FASSOC FIXED FLAST FMEMB FNTH FRPLACA FRPLACD FRPLNODE FRPLNODE2 INTEGER LAST LISTPUT LISTPUT1 MAPCON MAPCONC MEMB MIXED NCONC NCONC1 NTH PUT PUTASSOC PUTHASH PUTPROP RPLACA RPLACD RPLNODE RPLNODE2 SETA STANDARD UNDOABLE)) (PUTPROPS FMEMB CLISPTYPE -20) (PUTPROPS MEMB CLISPTYPE -20) (PUTPROPS FETCHFIELD LISPFN FETCHFIELD) (PUTPROPS REPLACEFIELD LISPFN REPLACEFIELD) (PUTPROPS FREPLACEFIELD LISPFN FREPLACEFIELD) (PUTPROPS ASSOC LISPFN ASSOC) (PUTPROPS LAST LISPFN LAST) (PUTPROPS LISTPUT LISPFN LISTPUT) (PUTPROPS LISTPUT1 LISPFN LISTPUT1) (PUTPROPS MAPCON LISPFN MAPCON) (PUTPROPS MAPCONC LISPFN MAPCONC) (PUTPROPS MEMB LISPFN MEMB) (PUTPROPS NCONC LISPFN NCONC) (PUTPROPS NCONC1 LISPFN NCONC1) (PUTPROPS NTH LISPFN NTH) (PUTPROPS PUT LISPFN PUT) (PUTPROPS PUTASSOC LISPFN PUTASSOC) (PUTPROPS PUTHASH LISPFN PUTHASH) (PUTPROPS PUTPROP LISPFN PUTPROP) (PUTPROPS RPLACA LISPFN RPLACA) (PUTPROPS RPLACD LISPFN RPLACD) (PUTPROPS RPLNODE LISPFN RPLNODE) (PUTPROPS RPLNODE2 LISPFN RPLNODE2) (PUTPROPS SETA LISPFN SETA) (PUTPROPS FLOATING CLISPCLASS (ARITH . 2)) (PUTPROPS FAST CLISPCLASS (ACCESS . 3)) (PUTPROPS FFETCHFIELD CLISPCLASS FETCHFIELD) (PUTPROPS FETCHFIELD CLISPCLASS FETCHFIELD) (PUTPROPS REPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS FREPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS /REPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS /LISTPUT CLISPCLASS LISTPUT) (PUTPROPS /MAPCON CLISPCLASS MAPCON) (PUTPROPS /MAPCONC CLISPCLASS MAPCONC) (PUTPROPS /NCONC CLISPCLASS NCONC) (PUTPROPS /NCONC1 CLISPCLASS NCONC1) (PUTPROPS /PUT CLISPCLASS PUT) (PUTPROPS /PUTASSOC CLISPCLASS PUTASSOC) (PUTPROPS /PUTHASH CLISPCLASS PUTHASH) (PUTPROPS /PUTPROP CLISPCLASS PUTPROP) (PUTPROPS /RPLACA CLISPCLASS RPLACA) (PUTPROPS /RPLACD CLISPCLASS RPLACD) (PUTPROPS /RPLNODE CLISPCLASS RPLNODE) (PUTPROPS /RPLNODE2 CLISPCLASS RPLNODE2) (PUTPROPS /SETA CLISPCLASS SETA) (PUTPROPS ASSOC CLISPCLASS ASSOC) (PUTPROPS FASSOC CLISPCLASS ASSOC) (PUTPROPS FIXED CLISPCLASS (ARITH . 1)) (PUTPROPS FLAST CLISPCLASS LAST) (PUTPROPS FMEMB CLISPCLASS MEMB) (PUTPROPS FNTH CLISPCLASS NTH) (PUTPROPS FRPLACA CLISPCLASS RPLACA) (PUTPROPS FRPLACD CLISPCLASS RPLACD) (PUTPROPS FRPLNODE CLISPCLASS RPLNODE) (PUTPROPS FRPLNODE2 CLISPCLASS RPLNODE2) (PUTPROPS INTEGER CLISPCLASS (ARITH . 1)) (PUTPROPS LAST CLISPCLASS LAST) (PUTPROPS LISTPUT CLISPCLASS LISTPUT) (PUTPROPS LISTPUT1 CLISPCLASS LISTPUT1) (PUTPROPS MAPCON CLISPCLASS MAPCON) (PUTPROPS MAPCONC CLISPCLASS MAPCONC) (PUTPROPS MEMB CLISPCLASS MEMB) (PUTPROPS MIXED CLISPCLASS (ARITH . 3)) (PUTPROPS NCONC CLISPCLASS NCONC) (PUTPROPS NCONC1 CLISPCLASS NCONC1) (PUTPROPS NTH CLISPCLASS NTH) (PUTPROPS PUT CLISPCLASS PUT) (PUTPROPS PUTASSOC CLISPCLASS PUTASSOC) (PUTPROPS PUTHASH CLISPCLASS PUTHASH) (PUTPROPS PUTPROP CLISPCLASS PUTPROP) (PUTPROPS RPLACA CLISPCLASS RPLACA) (PUTPROPS RPLACD CLISPCLASS RPLACD) (PUTPROPS RPLNODE CLISPCLASS RPLNODE) (PUTPROPS RPLNODE2 CLISPCLASS RPLNODE2) (PUTPROPS SETA CLISPCLASS SETA) (PUTPROPS STANDARD CLISPCLASS (ACCESS . 1)) (PUTPROPS UNDOABLE CLISPCLASS (ACCESS . 2)) (PUTPROPS FETCHFIELD CLISPCLASSDEF (ACCESS FETCHFIELD NIL FFETCHFIELD)) (PUTPROPS REPLACEFIELD CLISPCLASSDEF (ACCESS REPLACEFIELD /REPLACEFIELD FREPLACEFIELD)) (PUTPROPS ASSOC CLISPCLASSDEF (ACCESS ASSOC NIL FASSOC)) (PUTPROPS LAST CLISPCLASSDEF (ACCESS LAST NIL FLAST)) (PUTPROPS LISTPUT CLISPCLASSDEF (ACCESS LISTPUT /LISTPUT)) (PUTPROPS LISTPUT1 CLISPCLASSDEF (ACCESS LISTPUT1 /LISTPUT1)) (PUTPROPS MAPCON CLISPCLASSDEF (ACCESS MAPCON /MAPCON)) (PUTPROPS MAPCONC CLISPCLASSDEF (ACCESS MAPCONC /MAPCONC)) (PUTPROPS MEMB CLISPCLASSDEF (ACCESS MEMB NIL FMEMB)) (PUTPROPS NCONC CLISPCLASSDEF (ACCESS NCONC /NCONC)) (PUTPROPS NCONC1 CLISPCLASSDEF (ACCESS NCONC1 /NCONC1)) (PUTPROPS NTH CLISPCLASSDEF (ACCESS NTH NIL FNTH)) (PUTPROPS PUT CLISPCLASSDEF (ACCESS PUT /PUT)) (PUTPROPS PUTASSOC CLISPCLASSDEF (ACCESS PUTASSOC /PUTASSOC)) (PUTPROPS PUTHASH CLISPCLASSDEF (ACCESS PUTHASH /PUTHASH)) (PUTPROPS PUTPROP CLISPCLASSDEF (ACCESS PUTPROP /PUTPROP)) (PUTPROPS RPLACA CLISPCLASSDEF (ACCESS RPLACA /RPLACA FRPLACA)) (PUTPROPS RPLACD CLISPCLASSDEF (ACCESS RPLACD /RPLACD FRPLACD)) (PUTPROPS RPLNODE CLISPCLASSDEF (ACCESS RPLNODE /RPLNODE FRPLNODE)) (PUTPROPS RPLNODE2 CLISPCLASSDEF (ACCESS RPLNODE2 /RPLNODE2 FRPLNODE2)) (PUTPROPS SETA CLISPCLASSDEF (ACCESS SETA /SETA)) (PUTPROPS FMEMB CLISPNEG ~FMEMB) (PUTPROPS MEMB CLISPNEG ~MEMB) (PUTPROPS FMEMB BROADSCOPE T) (PUTPROPS MEMB BROADSCOPE T) (PUTPROPS LT CLISPTYPE -20) (PUTPROPS lt CLISPTYPE -20) (PUTPROPS GT CLISPTYPE -20) (PUTPROPS gt CLISPTYPE -20) (PUTPROPS LE CLISPTYPE -20) (PUTPROPS le CLISPTYPE -20) (PUTPROPS GE CLISPTYPE -20) (PUTPROPS ge CLISPTYPE -20) (PUTPROPS LEQ CLISPTYPE -20) (PUTPROPS leq CLISPTYPE -20) (PUTPROPS GEQ CLISPTYPE -20) (PUTPROPS geq CLISPTYPE -20) (PUTPROPS EQ CLISPTYPE -20) (PUTPROPS NEQ CLISPTYPE -20) (PUTPROPS EQP CLISPTYPE -20) (PUTPROPS EQUAL CLISPTYPE -20) (PUTPROPS EQUALS CLISPTYPE -20) (PUTPROPS AND CLISPTYPE -25) (PUTPROPS OR CLISPTYPE -26) (PUTPROPS and CLISPTYPE -25) (PUTPROPS or CLISPTYPE -26) (PUTPROPS NOR CLISPTYPE -25) (PUTPROPS nor CLISPTYPE -25) (PUTPROPS MEMBER CLISPTYPE -20) (PUTPROPS ILESSP CLISPTYPE -20) (PUTPROPS IGREATERP CLISPTYPE -20) (PUTPROPS FGTP CLISPTYPE -20) (PUTPROPS MINUS CLISPTYPE 8) (PUTPROPS LESSP CLISPTYPE -20) (PUTPROPS GREATERP CLISPTYPE -20) (PUTPROPS -> CLISPTYPE 7) (PUTPROPS => CLISPTYPE 7) (PUTPROPS LT LISPFN LESSP) (PUTPROPS lt LISPFN LESSP) (PUTPROPS GT LISPFN GREATERP) (PUTPROPS gt LISPFN GREATERP) (PUTPROPS LE LISPFN LEQ) (PUTPROPS le LISPFN LEQ) (PUTPROPS GE LISPFN GEQ) (PUTPROPS ge LISPFN GEQ) (PUTPROPS LEQ LISPFN LEQ) (PUTPROPS leq LISPFN LEQ) (PUTPROPS GEQ LISPFN GEQ) (PUTPROPS geq LISPFN GEQ) (PUTPROPS EQUALS LISPFN EQUAL) (PUTPROPS AND LISPFN AND) (PUTPROPS OR LISPFN OR) (PUTPROPS and LISPFN AND) (PUTPROPS or LISPFN OR) (PUTPROPS NOR LISPFN AND) (PUTPROPS nor LISPFN AND) (PUTPROPS NOT UNARYOP T) (PUTPROPS MINUS UNARYOP T) (PUTPROPS LEQ CLISPINFIX le) (PUTPROPS GEQ CLISPINFIX ge) (PUTPROPS EQ CLISPINFIX =) (PUTPROPS NOT CLISPINFIX ~) (PUTPROPS AND CLISPINFIX and) (PUTPROPS OR CLISPINFIX or) (PUTPROPS SETQ CLISPINFIX _) (PUTPROPS IPLUS CLISPINFIX +) (PUTPROPS IMINUS CLISPINFIX -) (PUTPROPS IDIFFERENCE CLISPINFIX +-) (PUTPROPS ITIMES CLISPINFIX *) (PUTPROPS IQUOTIENT CLISPINFIX /) (PUTPROPS ILESSP CLISPINFIX lt) (PUTPROPS IGREATERP CLISPINFIX gt) (PUTPROPS PLUS CLISPINFIX +) (PUTPROPS MINUS CLISPINFIX -) (PUTPROPS DIFFERENCE CLISPINFIX +-) (PUTPROPS TIMES CLISPINFIX *) (PUTPROPS QUOTIENT CLISPINFIX /) (PUTPROPS LESSP CLISPINFIX lt) (PUTPROPS GREATERP CLISPINFIX gt) (PUTPROPS EXPT CLISPINFIX ^) (PUTPROPS LT CLISPCLASS LT) (PUTPROPS lt CLISPCLASS LT) (PUTPROPS GT CLISPCLASS GT) (PUTPROPS gt CLISPCLASS GT) (PUTPROPS LE CLISPCLASS LEQ) (PUTPROPS le CLISPCLASS LEQ) (PUTPROPS GE CLISPCLASS GEQ) (PUTPROPS ge CLISPCLASS GEQ) (PUTPROPS LEQ CLISPCLASS LEQ) (PUTPROPS leq CLISPCLASS LEQ) (PUTPROPS GEQ CLISPCLASS GEQ) (PUTPROPS geq CLISPCLASS GEQ) (PUTPROPS IPLUS CLISPCLASS +) (PUTPROPS IMINUS CLISPCLASS -) (PUTPROPS IDIFFERENCE CLISPCLASS +-) (PUTPROPS ITIMES CLISPCLASS *) (PUTPROPS IQUOTIENT CLISPCLASS /) (PUTPROPS ILESSP CLISPCLASS LT) (PUTPROPS IGREATERP CLISPCLASS GT) (PUTPROPS FPLUS CLISPCLASS +) (PUTPROPS FMINUS CLISPCLASS -) (PUTPROPS FDIFFERENCE CLISPCLASS +-) (PUTPROPS FTIMES CLISPCLASS *) (PUTPROPS FQUOTIENT CLISPCLASS /) (PUTPROPS FGTP CLISPCLASS GT) (PUTPROPS PLUS CLISPCLASS +) (PUTPROPS MINUS CLISPCLASS -) (PUTPROPS DIFFERENCE CLISPCLASS +-) (PUTPROPS TIMES CLISPCLASS *) (PUTPROPS QUOTIENT CLISPCLASS /) (PUTPROPS LESSP CLISPCLASS LT) (PUTPROPS GREATERP CLISPCLASS GT) (PUTPROPS LT CLISPCLASSDEF (ARITH ILESSP LESSP LESSP)) (PUTPROPS GT CLISPCLASSDEF (ARITH IGREATERP FGTP GREATERP)) (PUTPROPS LE CLISPCLASSDEF (ARITH ILEQ LEQ LEQ)) (PUTPROPS GE CLISPCLASSDEF (ARITH IGEQ GEQ GEQ)) (PUTPROPS LEQ CLISPCLASSDEF (ARITH ILEQ LEQ LEQ)) (PUTPROPS GEQ CLISPCLASSDEF (ARITH IGEQ GEQ GEQ)) (PUTPROPS LT CLISPNEG GEQ) (PUTPROPS GT CLISPNEG LEQ) (PUTPROPS EQUALS CLISPNEG ~EQUAL) (PUTPROPS MEMBER CLISPNEG ~MEMBER) (PUTPROPS LT BROADSCOPE T) (PUTPROPS lt BROADSCOPE T) (PUTPROPS GT BROADSCOPE T) (PUTPROPS gt BROADSCOPE T) (PUTPROPS LE BROADSCOPE T) (PUTPROPS le BROADSCOPE T) (PUTPROPS GE BROADSCOPE T) (PUTPROPS ge BROADSCOPE T) (PUTPROPS LEQ BROADSCOPE T) (PUTPROPS leq BROADSCOPE T) (PUTPROPS GEQ BROADSCOPE T) (PUTPROPS geq BROADSCOPE T) (PUTPROPS EQ BROADSCOPE T) (PUTPROPS NEQ BROADSCOPE T) (PUTPROPS EQP BROADSCOPE T) (PUTPROPS EQUAL BROADSCOPE T) (PUTPROPS EQUALS BROADSCOPE T) (PUTPROPS NOT BROADSCOPE T) (PUTPROPS AND BROADSCOPE T) (PUTPROPS OR BROADSCOPE T) (PUTPROPS and BROADSCOPE T) (PUTPROPS or BROADSCOPE T) (PUTPROPS NOR BROADSCOPE T) (PUTPROPS nor BROADSCOPE T) (PUTPROPS MEMBER BROADSCOPE T) (PUTPROPS ILESSP BROADSCOPE T) (PUTPROPS IGREATERP BROADSCOPE T) (PUTPROPS FGTP BROADSCOPE T) (PUTPROPS LESSP BROADSCOPE T) (PUTPROPS GREATERP BROADSCOPE T) (PUTPROPS ELT SETFN SETA) (PUTPROPS SETA SETFN (ELT)) optimize-CLISP% :D8 (L (2 $$CTX 1 $$ENV 0 $$WHOLE)) @NIL NIL () (PUTPROP (QUOTE CLISP% ) (QUOTE COMPILER:OPTIMIZER-LIST) (CL:ADJOIN (QUOTE optimize-CLISP% ) (GET ( QUOTE CLISP% ) (QUOTE COMPILER:OPTIMIZER-LIST)))) (PUTPROPS AND CLISPWORD T) (PUTPROPS OR CLISPWORD T) (PUTPROPS and CLISPWORD T) (PUTPROPS or CLISPWORD T) (PUTPROPS ! CLISPWORD T) (PUTPROPS !! CLISPWORD T) (PUTPROPS CLISP CLISPWORD (PREFIXFN . clisp)) (PUTPROPS clisp CLISPWORD (PREFIXFN . clisp)) (PUTPROPS MATCH CLISPWORD (MATCHWORD . match)) (PUTPROPS match CLISPWORD (MATCHWORD . match)) (RPAQQ CLISPIFWORDSPLST (THEN ELSE ELSEIF IF)) (RPAQ? CLISPIFTRANFLG T) (PUTPROPS IF CLISPWORD (IFWORD . if)) (PUTPROPS THEN CLISPWORD (IFWORD . then)) (PUTPROPS ELSE CLISPWORD (IFWORD . else)) (PUTPROPS ELSEIF CLISPWORD (IFWORD . elseif)) (PUTPROPS if CLISPWORD (IFWORD . if)) (PUTPROPS then CLISPWORD (IFWORD . then)) (PUTPROPS else CLISPWORD (IFWORD . else)) (PUTPROPS elseif CLISPWORD (IFWORD . elseif)) (RPAQQ CLISPI.S.GAG NIL) (RPAQQ INITISOPRS (ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE always as bind by collect count declare declare%: do eachtime fcollect finally find first for from in inside isthere join largest never old on original repeatuntil repeatwhile smallest suchthat sum thereis thru to unless until when where while) ) (PUTPROPS ALWAYS CLISPWORD (FORWORD . always)) (PUTPROPS AS CLISPWORD (FORWORD . as)) (PUTPROPS BIND CLISPWORD (FORWORD . bind)) (PUTPROPS BY CLISPWORD (FORWORD . by)) (PUTPROPS COLLECT CLISPWORD (FORWORD . collect)) (PUTPROPS COUNT CLISPWORD (FORWORD . count)) (PUTPROPS DECLARE CLISPWORD (FORWORD . declare)) (PUTPROPS DECLARE%: CLISPWORD (FORWORD declare%: DECLARE)) (PUTPROPS DO CLISPWORD (FORWORD . do)) (PUTPROPS EACHTIME CLISPWORD (FORWORD . eachtime)) (PUTPROPS FCOLLECT CLISPWORD (FORWORD . fcollect)) (PUTPROPS FINALLY CLISPWORD (FORWORD . finally)) (PUTPROPS FIND CLISPWORD (FORWORD find FOR)) (PUTPROPS FIRST CLISPWORD (FORWORD . first)) (PUTPROPS FOR CLISPWORD (FORWORD . for)) (PUTPROPS FROM CLISPWORD (FORWORD . from)) (PUTPROPS IN CLISPWORD (FORWORD . in)) (PUTPROPS INSIDE CLISPWORD (FORWORD . inside)) (PUTPROPS ISTHERE CLISPWORD (FORWORD isthere THEREIS)) (PUTPROPS JOIN CLISPWORD (FORWORD . join)) (PUTPROPS LARGEST CLISPWORD (FORWORD . largest)) (PUTPROPS NEVER CLISPWORD (FORWORD . never)) (PUTPROPS OLD CLISPWORD (FORWORD . old)) (PUTPROPS ON CLISPWORD (FORWORD . on)) (PUTPROPS ORIGINAL CLISPWORD (FORWORD . original)) (PUTPROPS REPEATUNTIL CLISPWORD (FORWORD . repeatuntil)) (PUTPROPS REPEATWHILE CLISPWORD (FORWORD . repeatwhile)) (PUTPROPS SMALLEST CLISPWORD (FORWORD . smallest)) (PUTPROPS SUCHTHAT CLISPWORD (FORWORD suchthat THEREIS)) (PUTPROPS SUM CLISPWORD (FORWORD . sum)) (PUTPROPS THEREIS CLISPWORD (FORWORD . thereis)) (PUTPROPS THRU CLISPWORD (FORWORD thru TO)) (PUTPROPS TO CLISPWORD (FORWORD . to)) (PUTPROPS UNLESS CLISPWORD (FORWORD . unless)) (PUTPROPS UNTIL CLISPWORD (FORWORD . until)) (PUTPROPS WHEN CLISPWORD (FORWORD . when)) (PUTPROPS WHERE CLISPWORD (FORWORD where WHEN)) (PUTPROPS WHILE CLISPWORD (FORWORD . while)) (PUTPROPS always CLISPWORD (FORWORD . always)) (PUTPROPS as CLISPWORD (FORWORD . as)) (PUTPROPS bind CLISPWORD (FORWORD . bind)) (PUTPROPS by CLISPWORD (FORWORD . by)) (PUTPROPS collect CLISPWORD (FORWORD . collect)) (PUTPROPS count CLISPWORD (FORWORD . count)) (PUTPROPS declare CLISPWORD (FORWORD . declare)) (PUTPROPS declare%: CLISPWORD (FORWORD declare%: DECLARE)) (PUTPROPS do CLISPWORD (FORWORD . do)) (PUTPROPS eachtime CLISPWORD (FORWORD . eachtime)) (PUTPROPS fcollect CLISPWORD (FORWORD . fcollect)) (PUTPROPS finally CLISPWORD (FORWORD . finally)) (PUTPROPS find CLISPWORD (FORWORD find FOR)) (PUTPROPS first CLISPWORD (FORWORD . first)) (PUTPROPS for CLISPWORD (FORWORD . for)) (PUTPROPS from CLISPWORD (FORWORD . from)) (PUTPROPS in CLISPWORD (FORWORD . in)) (PUTPROPS inside CLISPWORD (FORWORD . inside)) (PUTPROPS isthere CLISPWORD (FORWORD isthere thereis)) (PUTPROPS join CLISPWORD (FORWORD . join)) (PUTPROPS largest CLISPWORD (FORWORD . largest)) (PUTPROPS never CLISPWORD (FORWORD . never)) (PUTPROPS old CLISPWORD (FORWORD . old)) (PUTPROPS on CLISPWORD (FORWORD . on)) (PUTPROPS original CLISPWORD (FORWORD . original)) (PUTPROPS repeatuntil CLISPWORD (FORWORD . repeatuntil)) (PUTPROPS repeatwhile CLISPWORD (FORWORD . repeatwhile)) (PUTPROPS smallest CLISPWORD (FORWORD . smallest)) (PUTPROPS suchthat CLISPWORD (FORWORD suchthat THEREIS)) (PUTPROPS sum CLISPWORD (FORWORD . sum)) (PUTPROPS thereis CLISPWORD (FORWORD . thereis)) (PUTPROPS thru CLISPWORD (FORWORD thru TO)) (PUTPROPS to CLISPWORD (FORWORD . to)) (PUTPROPS unless CLISPWORD (FORWORD . unless)) (PUTPROPS until CLISPWORD (FORWORD . until)) (PUTPROPS when CLISPWORD (FORWORD . when)) (PUTPROPS where CLISPWORD (FORWORD where WHEN)) (PUTPROPS while CLISPWORD (FORWORD . while)) (PUTPROPS always I.S.OPR ((COND ((NULL BODY) (SETQ $$VAL NIL) (GO $$OUT))) BIND (SETQ $$VAL T))) (PUTPROPS collect I.S.OPR ((SETQ $$VAL (NCONC1 $$VAL BODY)))) (PUTPROPS count I.S.OPR ((AND BODY (SETQ $$VAL (ADD1 $$VAL))) BIND ($$VAL _ 0))) (PUTPROPS do I.S.OPR (BODY)) (PUTPROPS fcollect I.S.OPR ((= SUBPAIR (QUOTE (VAR1 VAR2)) (LIST (GETDUMMYVAR T) (GETDUMMYVAR T)) ( QUOTE (PROGN (SETQ VAR1 BODY) (COND (VAR2 (FRPLACD VAR2 (SETQ VAR2 (LIST VAR1)))) (T (SETQ $$VAL (SETQ VAR2 (LIST VAR1)))))))))) (PUTPROPS inside I.S.OPR (NIL = SUBST (GETDUMMYVAR) (QUOTE VAR) (QUOTE (bind (VAR _ BODY) eachtime ( COND ((NULL VAR) (GO $$OUT)) ((NLISTP VAR) (SETQ I.V. VAR) (SETQ VAR NIL)) (T (SETQ I.V. (CAR VAR)) ( SETQ VAR (CDR VAR)))))))) (PUTPROPS join I.S.OPR ((SETQ $$VAL (NCONC $$VAL BODY)))) (PUTPROPS largest I.S.OPR (NIL = SUBST (GETDUMMYVAR) (QUOTE $$TEMP) (QUOTE (BIND $$EXTREME $$TEMP DO ( SETQ $$TEMP BODY) (COND ((OR (NULL $$EXTREME) (GREATERP $$TEMP $$EXTREME)) (SETQ $$EXTREME $$TEMP) ( SETQ $$VAL I.V.))))))) (PUTPROPS never I.S.OPR ((COND (BODY (SETQ $$VAL NIL) (GO $$OUT))) BIND ($$VAL _ T))) (PUTPROPS old I.S.OPR MODIFIER) (PUTPROPS smallest I.S.OPR (NIL = SUBST (GETDUMMYVAR) (QUOTE $$TEMP) (QUOTE (BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY) (COND ((OR (NULL $$EXTREME) (LESSP $$TEMP $$EXTREME)) (SETQ $$EXTREME $$TEMP) (SETQ $$VAL I.V.))))))) (PUTPROPS sum I.S.OPR ((SETQ $$VAL (PLUS $$VAL BODY)) BIND ($$VAL _ 0))) (PUTPROPS thereis I.S.OPR ((COND (BODY (SETQ $$VAL (OR I.V. T)) (GO $$OUT))))) (ADDTOVAR I.S.OPRLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE always as bind by collect count declare declare%: do eachtime fcollect finally find first for from in inside isthere join largest never old on original repeatuntil repeatwhile smallest suchthat sum thereis thru to unless until when where while) (ADDTOVAR CLISPFORWORDSPLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE) (RPAQQ CLISPDUMMYFORVARS ($$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6)) (ADDTOVAR SYSLOCALVARS $$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6) (ADDTOVAR INVISIBLEVARS $$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6) (ADDTOVAR SYSLOCALVARS $$VAL $$TEM $$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6 $$END $$EXTREME) (ADDTOVAR INVISIBLEVARS $$VAL $$END $$TEM $$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6 $$EXTREME) (PUTDEF (QUOTE I.S.OPRS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO (X (DECLARE%: EVAL@COMPILE (P * ( DUMPI.S.OPRS . X)))) CONTENTS NILL) (TYPE DESCRIPTION "i.s. operators" GETDEF GETDEF.I.S.OPR WHENCHANGED (CLEARCLISPARRAY))))) DUMPI.S.OPRS :D8 (P 3 Y I 0 X) A@@°7d[ d³gKgghid ¿¸IµHhZH&¹µÊJ(44 LISPXPRINT 13 GETDEF.I.S.OPR) (32 defined 27 not 21 I.S.OPR) () GETDEF.I.S.OPR :D8 (P 2 EVALFLG P 1 BODY P 0 TEM I 0 Y) 4pg@d´ddi𳿿@3µ g@h@g -Xd¢±þgð´‚±ñHd®g -YµCMLCOMPILE.;2 22597 +(FILECREATED "25-Feb-2026 23:03:38" {WMEDLEY}CMLCOMPILE.;4 25235 :EDIT-BY rmk - :CHANGES-TO (FNS COMPILE-IN-CORE) + :CHANGES-TO (FNS FAKE-COMPILE-FILE) - :PREVIOUS-DATE " 2-Jul-90 20:24:02" {WMEDLEY}CMLCOMPILE.;1) + :PREVIOUS-DATE "25-Feb-2026 19:50:29" {WMEDLEY}CMLCOMPILE.;3) -(* ; " -Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation. -") - (PRETTYCOMPRINT CMLCOMPILECOMS) (RPAQQ CMLCOMPILECOMS @@ -46,8 +42,111 @@ Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation. (DEFINEQ (FAKE-COMPILE-FILE -(CL:LAMBDA (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T) (COMPILER-OUTPUT T) (PROCESS-ENTIRE-FILE NIL PEFP)) (* ; "Edited 29-Jun-90 19:19 by nm") (LET (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML) (NLAMA NLAMA) (LAMS LAMS) (LAMA LAMA) (DFNFLG NIL)) (DECLARE (CL:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG)) (RESETLST (RESETSAVE NIL (LIST (QUOTE RESETUNDO)) (RESETUNDO)) (RESETSAVE COUTFILE COMPILER-OUTPUT) (RESETSAVE STRF REDEFINE) (RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE (QUOTE DEFER))) (RESETSAVE LAPFLG LAP) (LET ((*PACKAGE* *INTERLISP-PACKAGE*) (*READ-BASE* 10) (LOCALVARS SYSLOCALVARS) (SPECVARS T) STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM) (DECLARE (CL:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ STREAM (OPENSTREAM FILENAME (QUOTE INPUT))))) (CL:MULTIPLE-VALUE-SETQ (ENV FORM) (\PARSE-FILE-HEADER STREAM (QUOTE RETURN) T)) (SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*))) (if (NOT PEFP) then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT)) (if LAP then (SETQ LSTFIL COUTFILE)) (SETQ FILENAME (FULLNAME STREAM)) (RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET) (SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) COMPILE.EXT (QUOTE BODY) FILENAME)) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE BINARY))))) STREAM (ROOTFILENAME FILENAME))) (if OUTPUT-FILE then (RESETSAVE LCFIL OUTPUT-FILE) (PRINT-COMPILE-HEADER (LIST STREAM) (QUOTE ("COMPILE-FILEd")) ENV)) (WITH-READER-ENVIRONMENT ENV (PROG ((DEFERRED.EXPRESSIONS NIL) (*PRINT-ARRAY* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (FIRSTFORMS NIL) (AFTERS NIL) (SCRATCH.LCOM (QUOTE {CORE}SCRATCH.LCOM)) DUMMYFILE TEMPVAL) (DECLARE (CL:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL* *PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS)) (* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)") (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM (QUOTE BOTH) (QUOTE NEW))))) LPDUMP (if (EQUAL (CAR FORM) (QUOTE RPAQQ)) then (* ; "This is the support method of %"COMPILERVARS%" (2-July-1990 TT)") (SETQ TEMPVAL (CADDR FORM)) (if (SETQ TEMPVAL (ASSOC (QUOTE DECLARE%:) TEMPVAL)) then (if (SETQ TEMPVAL (FMEMB (QUOTE COMPILERVARS) (FMEMB (QUOTE DOEVAL@COMPILE) TEMPVAL))) then (SETQ DFNFLG T) (if (SETQ TEMPVAL (FMEMB (QUOTE ADDVARS) (SETQ TEMPVAL (CADR TEMPVAL)))) then (CL:DOLIST (ARG (CDR TEMPVAL)) (APPLY (QUOTE ADDTOVAR) ARG)))))) (COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE) (SKIPSEPRCODES STREAM) (if (EOFP STREAM) then (CLOSEF STREAM) (for FORM in FIRSTFORMS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE T)) (COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE)) (CLOSEF? DUMMYFILE) (DELFILE (FULLNAME DUMMYFILE)) (AND PROCESS-ENTIRE-FILE (for EXP in (REVERSE DEFERRED.EXPRESSIONS) do (APPLY* (CAR EXP) (CDR EXP) OUTPUT-FILE))) (for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE T)) (RETURN)) (SETQ FORM (READ STREAM)) (GO LPDUMP)) (PRINT NIL OUTPUT-FILE)) (SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE)))) (* ; "Do these after UNDONLSETQ entered") (MAPC (REVERSE COMPILE.FILE.AFTER) (FUNCTION EVAL)) COMPILE.FILE.VALUE)) -) + (CL:LAMBDA + (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T) + (COMPILER-OUTPUT T) + (PROCESS-ENTIRE-FILE NIL PEFP)) (* ; "Edited 25-Feb-2026 23:02 by rmk") + (* ; "Edited 29-Jun-90 19:19 by nm") + (LET + (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML) + (NLAMA NLAMA) + (LAMS LAMS) + (LAMA LAMA) + (DFNFLG NIL)) + (DECLARE (CL:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG)) + (RESETLST + (RESETSAVE NIL (LIST 'RESETUNDO) + (RESETUNDO)) + (RESETSAVE COUTFILE COMPILER-OUTPUT) + (RESETSAVE STRF REDEFINE) + (RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE 'DEFER)) + (RESETSAVE LAPFLG LAP) + (LET + ((*PACKAGE* *INTERLISP-PACKAGE*) + (*READ-BASE* 10) + (LOCALVARS SYSLOCALVARS) + (SPECVARS T) + STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM) + (DECLARE (CL:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL)) + [RESETSAVE NIL (LIST (FUNCTION CLOSEF?) + (SETQ STREAM (OPENSTREAM FILENAME 'INPUT] + (CL:MULTIPLE-VALUE-SETQ (ENV FORM) + (\PARSE-FILE-HEADER STREAM 'RETURN T)) + (SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*))) + (if (NOT PEFP) + then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT)) + (if LAP + then (SETQ LSTFIL COUTFILE)) + (SETQ FILENAME (FULLNAME STREAM)) + (RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET) + [SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING + 'VERSION NIL + 'EXTENSION COMPILE.EXT + 'BODY FILENAME)) + 'OUTPUT + 'NEW + `((TYPE BINARY) + (:EXTERNAL-FORMAT ,ENV] + STREAM + (ROOTFILENAME FILENAME))) + (if OUTPUT-FILE + then (RESETSAVE LCFIL OUTPUT-FILE) + (PRINT-COMPILE-HEADER (LIST STREAM) + '("COMPILE-FILEd") + ENV)) + (WITH-READER-ENVIRONMENT ENV + (PROG ((DEFERRED.EXPRESSIONS NIL) + (*PRINT-ARRAY* T) + (*PRINT-LEVEL* NIL) + (*PRINT-LENGTH* NIL) + (FIRSTFORMS NIL) + (AFTERS NIL) + (SCRATCH.LCOM '{CORE}SCRATCH.LCOM) + DUMMYFILE TEMPVAL) + (DECLARE (CL:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL* + *PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS)) + (* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)") + [RESETSAVE NIL (LIST (FUNCTION CLOSEF?) + (SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM 'BOTH 'NEW + `((:EXTERNAL-FORMAT ,ENV] + LPDUMP + [if (EQUAL (CAR FORM) + 'RPAQQ) + then (* ; + "This is the support method of %"COMPILERVARS%" (2-July-1990 TT)") + (SETQ TEMPVAL (CADDR FORM)) + (if (SETQ TEMPVAL (ASSOC 'DECLARE%: TEMPVAL)) + then (if (SETQ TEMPVAL (FMEMB 'COMPILERVARS (FMEMB 'DOEVAL@COMPILE + TEMPVAL))) + then (SETQ DFNFLG T) + (if [SETQ TEMPVAL (FMEMB 'ADDVARS (SETQ TEMPVAL + (CADR TEMPVAL] + then (CL:DOLIST (ARG (CDR TEMPVAL)) + (APPLY 'ADDTOVAR ARG))] + (COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE) + (SKIPSEPRCODES STREAM) + (if (EOFP STREAM) + then (CLOSEF STREAM) + (for FORM in FIRSTFORMS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL + PROCESS-ENTIRE-FILE T)) + (COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE)) + (CLOSEF? DUMMYFILE) + (DELFILE (FULLNAME DUMMYFILE)) + (CL:WHEN PROCESS-ENTIRE-FILE + (for EXP in (REVERSE DEFERRED.EXPRESSIONS) + do (APPLY* (CAR EXP) + (CDR EXP) + OUTPUT-FILE))) + (for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL + PROCESS-ENTIRE-FILE T)) + (RETURN)) + (SETQ FORM (READ STREAM)) + (GO LPDUMP)) + (PRINT NIL OUTPUT-FILE)) + (SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE)))) (* ; "Do these after UNDONLSETQ entered") + (MAPC (REVERSE COMPILE.FILE.AFTER) + (FUNCTION EVAL)) + COMPILE.FILE.VALUE))) (INTERLISP-FORMAT-P [LAMBDA (STREAM) (* bvm%: " 3-Aug-86 14:01") @@ -302,14 +401,13 @@ Copyright (c) 1985-1987, 1990 by Venue & Xerox Corporation. (ADDTOVAR LAMA FAKE-COMPILE-FILE) ) -(PUTPROPS CMLCOMPILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1636 2253 (CL:DISASSEMBLE 1636 . 2253)) (2254 17523 (FAKE-COMPILE-FILE 2264 . 5700) ( -INTERLISP-FORMAT-P 5702 . 5920) (INTERLISP-NLAMBDA-FUNCTION-P 5922 . 6156) (COMPILE-FILE-EXPRESSION -6158 . 9508) (COMPILE-FILE-WALK-FUNCTION 9510 . 9757) (ARGTYPE.STATE 9759 . 9919) ( -COMPILE.CHECK.ARGTYPE 9921 . 11913) (COMPILE.FILE.DEFINEQ 11915 . 12408) ( -COMPILE-FILE-SETF-SYMBOL-FUNCTION 12410 . 13004) (COMPILE-FILE-EX/IMPORT 13006 . 13334) ( -COMPILE.FILE.APPLY 13336 . 13596) (COMPILE.FILE.RESET 13598 . 14459) (COMPILE-IN-CORE 14461 . 17521)) -(17524 19253 (COMPILE-FILE-SCAN-FIRST 17534 . 19251)) (19796 21163 (COMPILE-FILE-DECLARE%: 19796 . -21163)) (21164 22228 (NEWDEFC 21174 . 22226))))) + (FILEMAP (NIL (1569 2186 (CL:DISASSEMBLE 1569 . 2186)) (2187 20243 (FAKE-COMPILE-FILE 2197 . 8420) ( +INTERLISP-FORMAT-P 8422 . 8640) (INTERLISP-NLAMBDA-FUNCTION-P 8642 . 8876) (COMPILE-FILE-EXPRESSION +8878 . 12228) (COMPILE-FILE-WALK-FUNCTION 12230 . 12477) (ARGTYPE.STATE 12479 . 12639) ( +COMPILE.CHECK.ARGTYPE 12641 . 14633) (COMPILE.FILE.DEFINEQ 14635 . 15128) ( +COMPILE-FILE-SETF-SYMBOL-FUNCTION 15130 . 15724) (COMPILE-FILE-EX/IMPORT 15726 . 16054) ( +COMPILE.FILE.APPLY 16056 . 16316) (COMPILE.FILE.RESET 16318 . 17179) (COMPILE-IN-CORE 17181 . 20241)) +(20244 21973 (COMPILE-FILE-SCAN-FIRST 20254 . 21971)) (22516 23883 (COMPILE-FILE-DECLARE%: 22516 . +23883)) (23884 24948 (NEWDEFC 23894 . 24946))))) STOP diff --git a/sources/CMLCOMPILE.DFASL b/sources/CMLCOMPILE.DFASL new file mode 100644 index 00000000..21cbba7f Binary files /dev/null and b/sources/CMLCOMPILE.DFASL differ diff --git a/sources/CMLREAD b/sources/CMLREAD index 2542b14f..81c044d3 100644 --- a/sources/CMLREAD +++ b/sources/CMLREAD @@ -1,12 +1,13 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) -(FILECREATED "24-Apr-2025 21:59:48" {WMEDLEY}CMLREAD.;17 12829 +(FILECREATED "25-Feb-2026 11:51:19" {WMEDLEY}CMLREAD.;24 12180 :EDIT-BY rmk :CHANGES-TO (VARS CMLREADCOMS) + (FUNCTIONS WITH-READER-ENVIRONMENT) - :PREVIOUS-DATE "23-Sep-2024 11:55:33" {WMEDLEY}CMLREAD.;16) + :PREVIOUS-DATE "25-Feb-2026 09:25:29" {WMEDLEY}CMLREAD.;21) (PRETTYCOMPRINT CMLREADCOMS) @@ -26,18 +27,14 @@ (DWIMINMACROSFLG)) (VARIABLES *READ-DEFAULT-FLOAT-FORMAT*) (GLOBALVARS CMLRDTBL READ-LINE-RDTBL)) - [COMS - (* ;; "Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup") - - (RECORDS READER-ENVIRONMENT) - (FUNCTIONS WITH-READER-ENVIRONMENT) - (ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) + [COMS (FUNCTIONS WITH-READER-ENVIRONMENT) (PROP INFO WITH-READER-ENVIRONMENT) + (ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*) - (INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _ + (INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE ↠(CL:FIND-PACKAGE "USER") - REREADTABLE _ CMLRDTBL REBASE _ 10 - REFORMAT _ :MCCS] + REREADTABLE ↠CMLRDTBL REBASE ↠10 + REFORMAT ↠:MCCS] (PROP FILETYPE CMLREAD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) @@ -53,48 +50,48 @@ (CL:COPY-READTABLE [CL:LAMBDA (&OPTIONAL (FROM-READTABLE *READTABLE*) - TO-READTABLE) (* bvm%: "13-Oct-86 15:21") + TO-READTABLE) (* bvm%: "13-Oct-86 15:21") (* ; - "If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.") + "If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.") (if (AND (NULL FROM-READTABLE) - (NULL TO-READTABLE)) - then (* ; "just make a brand new one") - (CMLRDTBL) + (NULL TO-READTABLE)) + then (* ; "just make a brand new one") + (CMLRDTBL) else (SETQ FROM-READTABLE (\DTEST (OR FROM-READTABLE (CMLRDTBL)) - 'READTABLEP)) - (if TO-READTABLE - then (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP) - FROM-READTABLE) - TO-READTABLE - else (COPYREADTABLE FROM-READTABLE]) + 'READTABLEP)) + (if TO-READTABLE + then (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP) + FROM-READTABLE) + TO-READTABLE + else (COPYREADTABLE FROM-READTABLE]) ) (DEFINEQ (CL:READ-LINE [CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T) - EOF-VALUE RECURSIVE-P) (* ; "Edited 31-Mar-87 18:36 by bvm:") + EOF-VALUE RECURSIVE-P) (* ; "Edited 31-Mar-87 18:36 by bvm:") (* ;; - "Returns a line of text read from the STREAM as a string, discarding the newline character.") + "Returns a line of text read from the STREAM as a string, discarding the newline character.") (CL:SETQ STREAM (\GETSTREAM STREAM 'INPUT)) (if (AND (NULL EOF-ERRORP) - (NULL RECURSIVE-P) - (\EOFP STREAM)) + (NULL RECURSIVE-P) + (\EOFP STREAM)) then EOF-VALUE else (LET ((RESULT (RSTRING STREAM READ-LINE-RDTBL))) - (if (\EOFP STREAM) - then (CL:VALUES RESULT T) - else (* ; "consume the eol") - (READCCODE STREAM) - (CL:VALUES RESULT NIL]) + (if (\EOFP STREAM) + then (CL:VALUES RESULT T) + else (* ; "consume the eol") + (READCCODE STREAM) + (CL:VALUES RESULT NIL]) (CL:READ-CHAR [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*) (EOF-ERRORP T) - EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 20:41 by bvm:") + EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 20:41 by bvm:") - (* ;; "Inputs a character from STREAM and returns it.") + (* ;; "Inputs a character from STREAM and returns it.") (LET [(STREAM (\GETSTREAM STREAM 'INPUT] (COND @@ -105,10 +102,10 @@ (T (CL:CODE-CHAR (READCCODE STREAM]) (CL:UNREAD-CHAR - (CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*)) - (* ; "Edited 23-Jun-2021 13:05 by rmk:") + (CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*)) + (* ; "Edited 23-Jun-2021 13:05 by rmk:") - (* ;; "Puts the CHARACTER back on the front of the input STREAM. According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'") + (* ;; "Puts the CHARACTER back on the front of the input STREAM. According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'") (\BACKCCODE (\GETSTREAM INPUT-STREAM 'INPUT)) NIL)) @@ -153,7 +150,7 @@ else (\ILLEGAL.ARG PEEK-TYPE]) (CL:LISTEN - (CL:LAMBDA (&OPTIONAL STREAM) (* ; "Edited 14-Apr-87 16:49 by bvm:") + (CL:LAMBDA (&OPTIONAL STREAM) (* ; "Edited 14-Apr-87 16:49 by bvm:") (* ;; "Returns T if a character is available on the given STREAM ") @@ -162,7 +159,7 @@ (CL:READ-CHAR-NO-HANG (CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T) - EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Apr-87 16:40 by bvm:") + EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Apr-87 16:40 by bvm:") (* ;; "Returns the next character from the STREAM if one is available, or NIL. However, if STREAM is at eof, do eof handling.") @@ -170,13 +167,13 @@ ((READP STREAM T) (* ; "there is input, get it") (CL:READ-CHAR STREAM EOF-ERRORP EOF-VALUE RECURSIVE-P)) ((NOT (EOFP STREAM)) (* ; - "there could be more input, so don't wait, return NIL") + "there could be more input, so don't wait, return NIL") NIL) (EOF-ERRORP (\EOF.ACTION STREAM)) (T EOF-VALUE)))) (CL:CLEAR-INPUT - [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm%: "13-Oct-86 15:46") + [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm%: "13-Oct-86 15:46") (* ;; "Clears any buffered input associated with the Stream.") @@ -200,7 +197,7 @@ (CL:READ-BYTE [CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T) - EOF-VALUE) (* bvm%: "13-Oct-86 15:49") + EOF-VALUE) (* bvm%: "13-Oct-86 15:49") (* ;; "Returns the next byte of the BINARY-INPUT-STREAM") @@ -211,7 +208,7 @@ (\BIN STREAM))]) (CL:WRITE-BYTE - (CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM) (* bvm%: "13-Oct-86 15:49") + (CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM) (* bvm%: "13-Oct-86 15:49") (* ;; "Outputs the INTEGER to the binary BINARY-OUTPUT-STREAM") @@ -236,47 +233,30 @@ (GLOBALVARS CMLRDTBL READ-LINE-RDTBL) ) - - -(* ;; -"Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup" -) - -(DECLARE%: EVAL@COMPILE - -(DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE REPACKAGEFORM REFORMAT REREADTABLEFORM)) -) - -(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER POINTER POINTER) - '((READER-ENVIRONMENT 0 POINTER) - (READER-ENVIRONMENT 2 POINTER) - (READER-ENVIRONMENT 4 POINTER) - (READER-ENVIRONMENT 6 POINTER) - (READER-ENVIRONMENT 8 POINTER) - (READER-ENVIRONMENT 10 POINTER)) - '12) - -(DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY) +(DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY) (* ; "Edited 25-Feb-2026 09:23 by rmk") `((CL:LAMBDA (E) + (CL:WHEN (\GETSTREAM E 'INPUT T) + (SETQ E (READ-READER-ENVIRONMENT STREAM))) + (\DTEST E 'READER-ENVIRONMENT) (LET ((*PACKAGE* (ffetch (READER-ENVIRONMENT REPACKAGE) of E)) (*READTABLE* (ffetch (READER-ENVIRONMENT REREADTABLE) of E)) (*READ-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E)) (*PRINT-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E))) ,@BODY)) - (\DTEST ,ENV 'READER-ENVIRONMENT))) - -(ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*) + ,ENV)) (PUTPROPS WITH-READER-ENVIRONMENT INFO EVAL) + +(ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*) ) -(RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _ (CL:FIND-PACKAGE "USER") - REREADTABLE _ CMLRDTBL REBASE _ 10 REFORMAT _ :MCCS)) +(RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE ↠(CL:FIND-PACKAGE "USER") + REREADTABLE ↠CMLRDTBL REBASE ↠10 REFORMAT ↠:MCCS)) -(PUTPROPS CMLREAD FILETYPE CL:COMPILE-FILE) +(PUTPROPS CMLREAD FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) @@ -287,9 +267,9 @@ CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2380 3365 (CL:COPY-READTABLE 2390 . 3363)) (3366 10574 (CL:READ-LINE 3376 . 4248) ( -CL:READ-CHAR 4250 . 4800) (CL:UNREAD-CHAR 4802 . 5263) (CL:PEEK-CHAR 5265 . 7559) (CL:LISTEN 7561 . -7826) (CL:READ-CHAR-NO-HANG 7828 . 8600) (CL:CLEAR-INPUT 8602 . 8839) (CL:READ-FROM-STRING 8841 . 9861 -) (CL:READ-BYTE 9863 . 10316) (CL:WRITE-BYTE 10318 . 10572)) (11568 12041 (WITH-READER-ENVIRONMENT -11568 . 12041))))) + (FILEMAP (NIL (2210 3182 (CL:COPY-READTABLE 2220 . 3180)) (3183 10389 (CL:READ-LINE 3193 . 4049) ( +CL:READ-CHAR 4051 . 4605) (CL:UNREAD-CHAR 4607 . 5068) (CL:PEEK-CHAR 5070 . 7364) (CL:LISTEN 7366 . +7635) (CL:READ-CHAR-NO-HANG 7637 . 8415) (CL:CLEAR-INPUT 8417 . 8654) (CL:READ-FROM-STRING 8656 . 9676 +) (CL:READ-BYTE 9678 . 10131) (CL:WRITE-BYTE 10133 . 10387)) (10728 11381 (WITH-READER-ENVIRONMENT +10728 . 11381))))) STOP diff --git a/sources/CMLREAD.LCOM b/sources/CMLREAD.LCOM index d2e4be96..d0d98f4a 100644 Binary files a/sources/CMLREAD.LCOM and b/sources/CMLREAD.LCOM differ diff --git a/sources/COMPILE b/sources/COMPILE index 7b2a941c..28cdf840 100644 --- a/sources/COMPILE +++ b/sources/COMPILE @@ -1,12 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) -(FILECREATED "24-Apr-2025 22:04:20" {WMEDLEY}COMPILE.;6 76628 +(FILECREATED "26-Feb-2026 10:41:28" {WMEDLEY}COMPILE.;9 77027 :EDIT-BY rmk - :CHANGES-TO (FNS BCOMPL.BODY BRECOMPILE) + :CHANGES-TO (FNS BRECOMPILE) - :PREVIOUS-DATE "24-Sep-2023 13:59:34" {WMEDLEY}COMPILE.;5) + :PREVIOUS-DATE "26-Feb-2026 00:46:08" {WMEDLEY}COMPILE.;8) (PRETTYCOMPRINT COMPILECOMS) @@ -104,7 +104,8 @@ CFILE NOBLOCKSFLG OPTIONSSET)))]) (BCOMPL.BODY - [LAMBDA (STREAMS CFILE NOBLOCKSFLG OPTIONSSET) (* ; "Edited 24-Apr-2025 22:03 by rmk") + [LAMBDA (STREAMS CFILE NOBLOCKSFLG OPTIONSSET) (* ; "Edited 26-Feb-2026 00:43 by rmk") + (* ; "Edited 24-Apr-2025 22:03 by rmk") (* ; "Edited 5-Jul-2021 13:46 by rmk:") (* ;;; "STREAMS is a list of streams. Compile everything on them, dumping to CFILE (default first stream.dcom). NOBLOCKSFLG means TCOMPL instead of BCOMPL. OPTIONSSET is true if the Listing? question has already been asked.") @@ -146,7 +147,7 @@ (RESETSAVE NIL (LIST 'CLOSEF STREAM)) (RESETSAVE (INPUT STREAM)) (* ;  "Needs to be primary input for some of the filepkg expressions to work") - (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* + (WITH-READER-ENVIRONMENT *DEFINE-FILE-INFO-ENV* (until (OR (NULL (SETQ TEM (READ STREAM))) (EQ TEM 'STOP)) do (CL:WHEN (EQ (CAR (LISTP TEM)) @@ -491,7 +492,9 @@ (SETQ BLOCKS (NCONC1 BLOCKS X)))) (BRECOMPILE - [LAMBDA (FILES CFILE FNS NOBLOCKSFLG) (* ; "Edited 24-Apr-2025 22:04 by rmk") + [LAMBDA (FILES CFILE FNS NOBLOCKSFLG) (* ; "Edited 26-Feb-2026 10:35 by rmk") + (* ; "Edited 24-Feb-2026 10:00 by rmk") + (* ; "Edited 24-Apr-2025 22:04 by rmk") (* ; "Edited 5-Jul-2021 09:28 by rmk:") (* ;;; "FNS is a list of functions to be recompiled. The object is to make a file that looks exactly like that produced by BCOMPL except to greatly reduce the work by copying from CFILE the compiled definitions those functions not being recompiled.") @@ -632,6 +635,7 @@ (DECLARE (CL:SPECIAL FILECREATEDLOC)) (* ; " used by LOADFNSCAN") (WITH-READER-ENVIRONMENT ENV + (\EXTERNALFORMAT STREAM ENV) (create COMPFILEDESCR COMPFILESTREAM _ STREAM COMPFILEENV _ ENV @@ -653,8 +657,7 @@ (* ;  "Start writing the compiled file. Use environment of one of the source files--usually the only one") (if LCFIL - then (\EXTERNALFORMAT LCFIL (OR (LISTGET DESTINATIONENV :FORMAT) - :MCCS)) + then (\EXTERNALFORMAT LCFIL (OR DESTINATIONENV :MCCS)) (PRINT-COMPILE-HEADER FILES [CONS (if NOBLOCKSFLG @@ -851,27 +854,31 @@ (T (GO LP]) (BRECOMPILE3 - (LAMBDA (FN FILEMAPLST COREOK) (* bvm%: "29-Aug-86 22:07") - - (* * "returns definition of FN, either from in core, or from the file.") + [LAMBDA (FN FILEMAPLST COREOK) (* ; "Edited 24-Feb-2026 09:59 by rmk") + (* bvm%: "29-Aug-86 22:07") + +(* ;;; "returns definition of FN, either from in core, or from the file.") (LET (DEF STREAM) (COND - ((AND COREOK (EXPRP (SETQ DEF (VIRGINFN FN T)))) (* "Value is of the form (FN DEF FLG) where FLG=T means the definition was obtained from in core, so that it is ok to do spelling correction.") + ([AND COREOK (EXPRP (SETQ DEF (VIRGINFN FN T] + + (* ;; "Value is of the form (FN DEF FLG) where FLG=T means the definition was obtained from in core, so that it is ok to do spelling correction.") + (LIST FN DEF T)) (T (for FILEDESCR in FILEMAPLST - when (PROGN (SETQ STREAM (fetch COMPFILESTREAM of FILEDESCR)) + when [PROGN (SETQ STREAM (fetch COMPFILESTREAM of FILEDESCR)) (for Y in (CDR (fetch COMPFILEMAP of FILEDESCR)) - thereis (SETQ DEF (FASSOC FN (CDDR Y))))) + thereis (SETQ DEF (FASSOC FN (CDDR Y] do (SETFILEPTR STREAM (CADR DEF)) (SETQ DEF (WITH-READER-ENVIRONMENT (fetch COMPFILEENV of FILEDESCR) - (READ STREAM))) (* - "TEM is an arg to DEFINEQ, of the form (fn def)") + (READ STREAM))) (* ; + "TEM is an arg to DEFINEQ, of the form (fn def)") (COND ((NEQ FN (CAR DEF)) (ERROR '"filemap does not agree with contents of" (FULLNAME STREAM) T))) - (RETURN DEF))))))) + (RETURN DEF]) (BLOCKCOMPILE [LAMBDA (BLKNAME BLKFNS ENTRIES FLG) (* ; "Edited 6-Dec-86 03:59 by lmm") @@ -1518,14 +1525,14 @@ (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3379 73129 (BCOMPL 3389 . 5039) (BCOMPL.BODY 5041 . 11639) (PRINT-COMPILE-HEADER 11641 - . 12704) (RESETOPENFILES 12706 . 13059) (BCOMPL1A 13061 . 19074) (BCOMPL2 19076 . 25891) (BCOMPL3 -25893 . 27242) (BLOCK%: 27244 . 27876) (BRECOMPILE 27878 . 42562) (BRECOMPILE1 42564 . 48416) ( -BRECOMPILE2 48418 . 49220) (BRECOMPILE3 49222 . 50598) (BLOCKCOMPILE 50600 . 52460) (BLOCKCOMPILE1 -52462 . 57547) (COMPSET 57549 . 60246) (COMPSETREAD 60248 . 61559) (COMPSETY 61561 . 61685) (COMPSETF -61687 . 61853) (RCOMP3 61855 . 63562) (TCOMPL 63564 . 63863) (RECOMPILE 63865 . 63948) (RECOMP? 63950 - . 64410) (COMPILE 64412 . 66401) (COMPILE1 66403 . 66991) (COMPILE1A 66993 . 68640) ( -SHOULD-BE-DWIMIFIED? 68642 . 69331) (COMPEM 69333 . 70057) (GETCFILE 70059 . 71790) (SPECVARS 71792 . -72347) (LOCALVARS 72349 . 72923) (GLOBALVARS 72925 . 73127)) (75479 76428 (COMPILEMODE 75489 . 76426)) + (FILEMAP (NIL (3367 73528 (BCOMPL 3377 . 5027) (BCOMPL.BODY 5029 . 11726) (PRINT-COMPILE-HEADER 11728 + . 12791) (RESETOPENFILES 12793 . 13146) (BCOMPL1A 13148 . 19161) (BCOMPL2 19163 . 25978) (BCOMPL3 +25980 . 27329) (BLOCK%: 27331 . 27963) (BRECOMPILE 27965 . 42866) (BRECOMPILE1 42868 . 48720) ( +BRECOMPILE2 48722 . 49524) (BRECOMPILE3 49526 . 50997) (BLOCKCOMPILE 50999 . 52859) (BLOCKCOMPILE1 +52861 . 57946) (COMPSET 57948 . 60645) (COMPSETREAD 60647 . 61958) (COMPSETY 61960 . 62084) (COMPSETF +62086 . 62252) (RCOMP3 62254 . 63961) (TCOMPL 63963 . 64262) (RECOMPILE 64264 . 64347) (RECOMP? 64349 + . 64809) (COMPILE 64811 . 66800) (COMPILE1 66802 . 67390) (COMPILE1A 67392 . 69039) ( +SHOULD-BE-DWIMIFIED? 69041 . 69730) (COMPEM 69732 . 70456) (GETCFILE 70458 . 72189) (SPECVARS 72191 . +72746) (LOCALVARS 72748 . 73322) (GLOBALVARS 73324 . 73526)) (75878 76827 (COMPILEMODE 75888 . 76825)) ))) STOP diff --git a/sources/COMPILE.LCOM b/sources/COMPILE.LCOM index ecab8389..aa0f4704 100644 Binary files a/sources/COMPILE.LCOM and b/sources/COMPILE.LCOM differ diff --git a/sources/COREIO b/sources/COREIO index 72ff5f56..be878489 100644 --- a/sources/COREIO +++ b/sources/COREIO @@ -1,12 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10) -(FILECREATED "11-Sep-2025 16:49:07" {WMEDLEY}COREIO.;18 56903 +(FILECREATED "28-Feb-2026 12:09:38" {WMEDLEY}COREIO.;20 57201 :EDIT-BY rmk :CHANGES-TO (FNS \CORE.DIRECTORYNAMEP) - :PREVIOUS-DATE " 5-Jun-2022 00:14:07" {WMEDLEY}COREIO.;17) + :PREVIOUS-DATE "11-Sep-2025 16:49:07" {WMEDLEY}COREIO.;18) (PRETTYCOMPRINT COREIOCOMS) @@ -89,6 +89,8 @@ (\CORE.DIRECTORYNAMEP [LAMBDA (DIRNAME DEV) + (* ;; "Edited 28-Feb-2026 12:08 by rmk") + (* ;; "Edited 11-Sep-2025 16:48 by rmk") (* ;; "Edited 18-Jan-2022 11:17 by rmk") @@ -106,18 +108,21 @@ (* ;; "Returns NIL for a DIRNAME of just {CORE}, or {CORE}xxx. If the latter, then we want it to be a directory and not a file (assuming that xxx and xxx> can't both exist.") - [LET [(DIR (FILENAMEFIELD DIRNAME 'DIRECTORY] - (CL:WHEN DIR - (SETQ DIR (CONCAT DIR ">")) + (LET [(DIR (FILENAMEFIELD DIRNAME 'DIRECTORY] + (if DIR + then (SETQ DIR (CONCAT DIR ">")) - (* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)") + (* ;; "DIRPOS because caller may not have stripped off the device. This will match the first < or / (or >)") - (FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY)) - FIRST (CL:UNLESS (EQ DIRPOS 1) - (SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS))) - IN (CDR (FETCH COREDIRECTORY OF DEV)) - WHEN (STRPOS DIRNAME (CAR ENTRY) - 1 NIL T NIL FILEDIRCASEARRAY) DO (RETURN T)))])]) + (FOR ENTRY (DIRPOS _ (STRPOS "<" DIRNAME 1 NIL NIL NIL FILEDIRCASEARRAY)) + FIRST (CL:UNLESS (EQ DIRPOS 1) + (SETQ DIRNAME (SUBSTRING DIRNAME DIRPOS))) + IN (CDR (FETCH COREDIRECTORY OF DEV)) + WHEN (STRPOS DIRNAME (CAR ENTRY) + 1 NIL T NIL FILEDIRCASEARRAY) DO (RETURN T)) + else (* ; + "Top level: does the device exist at al. The cd {CORE}case") + T)))]) (\CORE.FINDPAGE [LAMBDA (STREAM PN) (* bvm%: "20-Apr-85 13:32") @@ -997,16 +1002,16 @@ ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1572 46115 (\CORE.CLOSEFILE 1582 . 2355) (\CORE.DELETEFILE 2357 . 4343) ( -\CORE.DIRECTORYNAMEP 4345 . 5838) (\CORE.FINDPAGE 5840 . 9069) (\CORE.GENERATEFILES 9071 . 11658) ( -\CORE.NEXTFILEFN 11660 . 12159) (\CORE.FILEINFOFN 12161 . 12390) (\CORE.GETFILEHANDLE 12392 . 14546) ( -\CORE.GETFILEINFO 14548 . 15511) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15513 . 17050) (\CORE.GETFILENAME -17052 . 19341) (\CORE.GETINFOBLOCK 19343 . 21966) (\CORE.NAMESCAN 21968 . 23515) (\CORE.NAMESEGMENT -23517 . 23954) (\CORE.OPENFILE 23956 . 27348) (\COREFILE.SETPARAMETERS 27350 . 29531) ( -\CORE.PACKFILENAME 29533 . 29928) (\CORE.RELEASEPAGES 29930 . 30531) (\CORE.SETFILEPTR 30533 . 31632) -(\CORE.UPDATEOF 31634 . 33263) (\CORE.BACKFILEPTR 33265 . 35473) (\CORE.SETEOFPTR 35475 . 37344) ( -\CORE.SETACCESSTIME 37346 . 37971) (\CORE.SETFILEINFO 37973 . 40275) (\CORE.GETNEXTBUFFER 40277 . -44233) (\CORE.UNPACKFILENAME 44235 . 46113)) (46116 49749 (COREDEVICE 46126 . 46297) ( -\CREATECOREDEVICE 46299 . 49747)) (49750 52164 (\NODIRCOREFDEV 49760 . 50357) (\NODIRCORE.OPENFILE -50359 . 52162))))) + (FILEMAP (NIL (1572 46413 (\CORE.CLOSEFILE 1582 . 2355) (\CORE.DELETEFILE 2357 . 4343) ( +\CORE.DIRECTORYNAMEP 4345 . 6136) (\CORE.FINDPAGE 6138 . 9367) (\CORE.GENERATEFILES 9369 . 11956) ( +\CORE.NEXTFILEFN 11958 . 12457) (\CORE.FILEINFOFN 12459 . 12688) (\CORE.GETFILEHANDLE 12690 . 14844) ( +\CORE.GETFILEINFO 14846 . 15809) (\CORE.GETFILEINFO.FROM.INFOBLOCK 15811 . 17348) (\CORE.GETFILENAME +17350 . 19639) (\CORE.GETINFOBLOCK 19641 . 22264) (\CORE.NAMESCAN 22266 . 23813) (\CORE.NAMESEGMENT +23815 . 24252) (\CORE.OPENFILE 24254 . 27646) (\COREFILE.SETPARAMETERS 27648 . 29829) ( +\CORE.PACKFILENAME 29831 . 30226) (\CORE.RELEASEPAGES 30228 . 30829) (\CORE.SETFILEPTR 30831 . 31930) +(\CORE.UPDATEOF 31932 . 33561) (\CORE.BACKFILEPTR 33563 . 35771) (\CORE.SETEOFPTR 35773 . 37642) ( +\CORE.SETACCESSTIME 37644 . 38269) (\CORE.SETFILEINFO 38271 . 40573) (\CORE.GETNEXTBUFFER 40575 . +44531) (\CORE.UNPACKFILENAME 44533 . 46411)) (46414 50047 (COREDEVICE 46424 . 46595) ( +\CREATECOREDEVICE 46597 . 50045)) (50048 52462 (\NODIRCOREFDEV 50058 . 50655) (\NODIRCORE.OPENFILE +50657 . 52460))))) STOP diff --git a/sources/COREIO.LCOM b/sources/COREIO.LCOM index f011a7be..5c3f58cc 100644 Binary files a/sources/COREIO.LCOM and b/sources/COREIO.LCOM differ diff --git a/sources/DWIMIFY b/sources/DWIMIFY index 69cf1192..e3fb9223 100644 --- a/sources/DWIMIFY +++ b/sources/DWIMIFY @@ -1,21 +1,13 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) -(FILECREATED "14-Sep-2022 10:25:44"  -{DSK}kaplan>local>medley3.5>working-medley>sources>DWIMIFY.;2 310341 +(FILECREATED "21-Feb-2026 16:14:43" {WMEDLEY}DWIMIFY.;3 309375 - :CHANGES-TO (FNS CLISPFOR0) + :EDIT-BY rmk - :PREVIOUS-DATE "16-May-90 16:21:27" -{DSK}kaplan>local>medley3.5>working-medley>sources>DWIMIFY.;1) + :CHANGES-TO (VARS DWIMIFYCOMS) + :PREVIOUS-DATE "14-Sep-2022 10:25:44" {WMEDLEY}DWIMIFY.;2) -(* ; " -Copyright (c) 1978, 1984-1986, 1990 by Venue & Xerox Corporation. -The following program was created in 1978 but has not been published -within the meaning of the copyright law, is furnished under license, -and may not be used, copied and/or disclosed except in accordance -with the terms of said license. -") (PRETTYCOMPRINT DWIMIFYCOMS) @@ -35,33 +27,36 @@ with the terms of said license. CLISPFORVARS1 CLISPFOR4 CLISPFORF/L CLISPDSUBST GETDUMMYVAR CLISPFORINITVAR) (COMS (FNS \DURATIONTRAN \CLISPKEYWORDPROCESS)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS DWIMUNDOCATCH)) - (BLOCKS (FORBLOCK (ENTRIES CLISPFOR) - CLISPFORVARS CLISPFOR0 CLISPFOR2 CLISPFORINITVAR CLISPDSUBST - \CLISPKEYWORDPROCESS CLISPFORF/L CLISPFOR4 CLISPFORVARS1 CLISPFOR3 CLISPFOR1 - CLISPFOR0A CLISPFOR \DURATIONTRAN - (SPECVARS UNDOSIDE LISPXHIST BODY I.S.TYPE1 I.S.TYPE TERMINATEFLG FIRSTI.V. - I.V. PROGVARS MAKEPROGFLG IVINITFLG INITVARS UNDOLST DWIMIFYING VARS - DWIMIFYCHANGE DUMMYVARS I.S.OPRSLST CLISPCONTEXT UNDOSIDE0 EXP)) - (DWIMIFYBLOCK CLBINARYMINUS? CLISPANGLEBRACKETS CLISPATOM CLISPATOM0 CLISPATOM1 - CLISPATOM1A CLISPATOM1B CLISPATOM2 CLISPATOM2A CLISPATOM2C CLISPATOM2D - CLISPATOMARE1 CLISPATOMARE2 CLISPATOMIS1 CLISPATOMIS2 CLISPBROADSCOPE - CLISPBROADSCOPE1 CLISPCAR/CDR CLISPCAR/CDR1 CLISPCAR/CDR2 CLISPIF CLISPIF0 - CLISPIF1 CLISPIF2 CLISPIF3 CLISPLOOKUP CLISPRESPELL CLRPLNODE CLUNARYMINUS? - DWIMIFY DWIMIFY0 DWIMIFY0? DWIMIFY1 DWIMIFY1? DWIMIFY1A DWIMIFY2 DWIMIFY2? - DWIMIFY2A DWIMIFYFNS DWMFY0 DWMFY1 DWMFY2 FIX89 FIX89A FIX89TYPEIN FIXAPPLY - FIXATOM FIXATOM1 FIXCONTINUE FIXCONTINUE1 FIXLAMBDA GETDUMMYVAR GETVARS - GETVARS1 RETDWIM RETDWIM1 SHRIEKER STOPSCAN? WTFIX WTFIX0 WTFIX1 - (ENTRIES WTFIX WTFIX1 DWIMIFYFNS DWIMIFY DWIMIFY0 DWIMIFY0? DWIMIFY1A - GETDUMMYVAR DWIMIFY2 DWIMIFY2? DWIMIFY1? DWIMIFY1 DWIMIFY2A CLISPLOOKUP) - (SPECVARS 89CHANGE 89FLG BRACKET BRACKETCNT ATTEMPTFLG BACKUPFLG BODY BREAKFLG - BROADSCOPE CLISPCHANGE CLISPCHANGES CLISPCONTEXT CLISPERTYPE CLTYP - CURRTAIL DWIMIFYCHANGE DWIMIFY0CHANGE DWIMIFYFLG DWIMIFYING ENDTAIL EXP - EXPR FAULTAPPLYFLG FAULTARGS FAULTFN FAULTPOS FAULTX FAULTXX FIRSTI.V. - FIXCLK FORMSFLG I.S.TYPE I.S.TYPE1 HISTENTRY I.S. I.V. INITVARS - IVINITFLG LISPFN CHARLST MAKEPROGFLG NCONC1LKUP NCONCLKUP NEGFLG NEWTAIL - NEXTAIL SUBPARENT NOFIX89 NOSAVEFLG ONEFLG ONLYSPELLFLG PARENT SIDES - TAIL TENTATIVE TERMINATEFLG TYP TYPE-IN? UNDOLST UNDOSIDE UNDOSIDE0 VAR1 - VAR2 VARS WORKFLAG UNARYFLG DEST FOR I.S.OPRSLST PROGVARS))) + (* BLOCKS + (FORBLOCK (ENTRIES CLISPFOR) + CLISPFORVARS CLISPFOR0 CLISPFOR2 CLISPFORINITVAR CLISPDSUBST \CLISPKEYWORDPROCESS + CLISPFORF/L CLISPFOR4 CLISPFORVARS1 CLISPFOR3 CLISPFOR1 CLISPFOR0A CLISPFOR + \DURATIONTRAN + (SPECVARS UNDOSIDE LISPXHIST BODY I.S.TYPE1 I.S.TYPE TERMINATEFLG FIRSTI.V. I.V. + PROGVARS MAKEPROGFLG IVINITFLG INITVARS UNDOLST DWIMIFYING VARS + DWIMIFYCHANGE DUMMYVARS I.S.OPRSLST CLISPCONTEXT UNDOSIDE0 EXP))) + (BLOCKS (DWIMIFYBLOCK CLBINARYMINUS? CLISPANGLEBRACKETS CLISPATOM CLISPATOM0 CLISPATOM1 + CLISPATOM1A CLISPATOM1B CLISPATOM2 CLISPATOM2A CLISPATOM2C CLISPATOM2D + CLISPATOMARE1 CLISPATOMARE2 CLISPATOMIS1 CLISPATOMIS2 CLISPBROADSCOPE + CLISPBROADSCOPE1 CLISPCAR/CDR CLISPCAR/CDR1 CLISPCAR/CDR2 CLISPIF CLISPIF0 + CLISPIF1 CLISPIF2 CLISPIF3 CLISPLOOKUP CLISPRESPELL CLRPLNODE CLUNARYMINUS? + DWIMIFY DWIMIFY0 DWIMIFY0? DWIMIFY1 DWIMIFY1? DWIMIFY1A DWIMIFY2 DWIMIFY2? + DWIMIFY2A DWIMIFYFNS DWMFY0 DWMFY1 DWMFY2 FIX89 FIX89A FIX89TYPEIN FIXAPPLY + FIXATOM FIXATOM1 FIXCONTINUE FIXCONTINUE1 FIXLAMBDA GETDUMMYVAR GETVARS + GETVARS1 RETDWIM RETDWIM1 SHRIEKER STOPSCAN? WTFIX WTFIX0 WTFIX1 + (ENTRIES WTFIX WTFIX1 DWIMIFYFNS DWIMIFY DWIMIFY0 DWIMIFY0? DWIMIFY1A + GETDUMMYVAR DWIMIFY2 DWIMIFY2? DWIMIFY1? DWIMIFY1 DWIMIFY2A CLISPLOOKUP + ) + (SPECVARS 89CHANGE 89FLG BRACKET BRACKETCNT ATTEMPTFLG BACKUPFLG BODY BREAKFLG + BROADSCOPE CLISPCHANGE CLISPCHANGES CLISPCONTEXT CLISPERTYPE CLTYP + CURRTAIL DWIMIFYCHANGE DWIMIFY0CHANGE DWIMIFYFLG DWIMIFYING ENDTAIL EXP + EXPR FAULTAPPLYFLG FAULTARGS FAULTFN FAULTPOS FAULTX FAULTXX FIRSTI.V. + FIXCLK FORMSFLG I.S.TYPE I.S.TYPE1 HISTENTRY I.S. I.V. INITVARS + IVINITFLG LISPFN CHARLST MAKEPROGFLG NCONC1LKUP NCONCLKUP NEGFLG + NEWTAIL NEXTAIL SUBPARENT NOFIX89 NOSAVEFLG ONEFLG ONLYSPELLFLG PARENT + SIDES TAIL TENTATIVE TERMINATEFLG TYP TYPE-IN? UNDOLST UNDOSIDE + UNDOSIDE0 VAR1 VAR2 VARS WORKFLAG UNARYFLG DEST FOR I.S.OPRSLST + PROGVARS))) (GLOBALVARS DWIMINMACROSFLG CHECKCARATOMFLG TREATASCLISPFLG CLISPHELPFLG CLISPIFTRANFLG CLISPRETRANFLG DWIMCHECKPROGLABELSFLG DWIMCHECK#ARGSFLG SHALLOWFLG PRETTYTRANFLG CLEARSTKLST LCASEFLG LAMBDASPLST DURATIONCLISPWORDS CLISPTRANFLG CLISPIFWORDSPLST @@ -79,7 +74,7 @@ with the terms of said license. (DEFINEQ (DWIMIFYFNS - [NLAMBDA FNS (* lmm "20-May-84 19:57") + [NLAMBDA FNS (* lmm "20-May-84 19:57") (PROG ((CLK (CLOCK 0)) TEM) (SETQ NOFIXFNSLST0 NOFIXFNSLST) @@ -91,8 +86,8 @@ with the terms of said license. (STKEVAL 'DWIMIFYFNS (CAR FNS) NIL 'INTERNAL)) - (T (* ; - "If (CAR FNS) is name of a file, do dwimifyfns on its functions.") + (T (* ; + "If (CAR FNS) is name of a file, do dwimifyfns on its functions.") (OR (LISTP (EVALV (CAR FNS) 'DWIMIFYFNS)) (AND (GETPROP (OR (AND DWIMFLG (MISSPELLED? (CAR FNS) @@ -107,13 +102,16 @@ with the terms of said license. (RETURN TEM]) (DWIMIFY - [LAMBDA (X QUIETFLG L) (* lmm "20-May-84 19:57") + [LAMBDA (X QUIETFLG L) (* lmm "20-May-84 19:57") (PROG (VAL) (COND ((NULL DWIMFLG) (LISPXPRIN1 "DWIM is turned off! " T) - (RETURN NIL))) (* ;; "If X is an atom and L is NIL, X is treated as the name of a function, and its entire definition is DWIMIFIED. Otherwise, X is a piece of a function, and L the edit puh down list that leads to X (i.e. L is the push-dwown list after performing a !0) L is used to compute the bound variables, as well as to determine whether X is an element or tail.") + (RETURN NIL))) + + (* ;; "If X is an atom and L is NIL, X is treated as the name of a function, and its entire definition is DWIMIFIED. Otherwise, X is a piece of a function, and L the edit puh down list that leads to X (i.e. L is the push-dwown list after performing a !0) L is used to compute the bound variables, as well as to determine whether X is an element or tail.") + (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) (SETQ VAL (DWIMIFY0 X L)) @@ -128,23 +126,25 @@ with the terms of said license. (RETURN VAL]) (DWIMIFY0 - [LAMBDA (X Y VARS EXPR) (* lmm "27-FEB-83 10:55") - (* ;; "Some general comments: --- DWIMIFYFLG is bound in DWIMIFY0, WTFIX, and WTFIX0. It is set to T whenever WTFIX is called and given EXPR, TAIL, PARENT, etc. as arguments, i.e. from DWIMIFY1 or DWIMIFY2. Note that this may occur due to an explicit call to DWIMIFY0, or due to evaluating certain CLISP expressions, e.g. IF statements, which call DWIMIFY1 or DWIMIFY2. These two cases are distinguished by the value of DWIMIFYING. --- DWIMIFYING is bound in DWIMIFY0 (to T), and whenever DWIMIFY1 or DWIMIFY2 are called from contexts where DWIMIFYING may not be bound, e.g. from CLISPIF. In these latter cases, DWIMIFYING is bound to (AND DWIMIFYFLG DWIMIFYING). Thus DWIMIFYING is always bound when DWIMIFYFLG is bound, and is T when under a call to DWIMIFY0, otherwise NIL. Note that checking DWIMIFYING without also checking DWIMIFYFLG may cause a U.B.A. DWIMIFYING error. Similary, other state variables that are bound in DWIMIFY0 but not rebound by DWIMIFY1 or DWIMIFY2 such as CLISPCONTEXT, DWIMIFYCHANGE, etc., are assumed to be bound when DWIMIFYFLG is T, so that any call to DWIMIFY1 or DWIMIFY2 must also guarantee that these variables are bound. If the caller is not sure, it should use DWIMIFY1? and DWIMIFY2? since these do the appropriate checks. --- NOFIXFNSLST0 and NOFIXVARSLST0 are global varaales. They are initializaed to NOFIXFNSLST and NOFIXVARLST by DWIMIFY and DWIMIFYFNS, as well as CLISPIF, CLISPFOR, etc. when they enter the DWIMIFY functions, i.e. DWIMIFY1 and DWIMIFY2 for the first time. NOFIXFNSLST and NOFIXVARLST are the variable that the user can add things to. --- VARS is bound in WTFIX and in DWIMIFY0. DWIMIFY1 and DWIMIFY2 supply VARS in their call to WTFIX. Otherwise WTFIX comptes them. --- ATTEMPTFLG is bound in DWIMIFY1 and DWIMIFY2. It is used to inform DWIMIFY1 or DWIMIFY2, in the event that WTFIX was unable to make a correction, NOT to add the atom to NOFIXLST. For example, this occurs when a correction was offered to the user but rejected, e.g. U.D.F. T, and user declines the fix, T is not added to NOFIXLST.") + [LAMBDA (X Y VARS EXPR) (* lmm "27-FEB-83 10:55") + + (* ;; "Some general comments: --- DWIMIFYFLG is bound in DWIMIFY0, WTFIX, and WTFIX0. It is set to T whenever WTFIX is called and given EXPR, TAIL, PARENT, etc. as arguments, i.e. from DWIMIFY1 or DWIMIFY2. Note that this may occur due to an explicit call to DWIMIFY0, or due to evaluating certain CLISP expressions, e.g. IF statements, which call DWIMIFY1 or DWIMIFY2. These two cases are distinguished by the value of DWIMIFYING. --- DWIMIFYING is bound in DWIMIFY0 (to T), and whenever DWIMIFY1 or DWIMIFY2 are called from contexts where DWIMIFYING may not be bound, e.g. from CLISPIF. In these latter cases, DWIMIFYING is bound to (AND DWIMIFYFLG DWIMIFYING). Thus DWIMIFYING is always bound when DWIMIFYFLG is bound, and is T when under a call to DWIMIFY0, otherwise NIL. Note that checking DWIMIFYING without also checking DWIMIFYFLG may cause a U.B.A. DWIMIFYING error. Similary, other state variables that are bound in DWIMIFY0 but not rebound by DWIMIFY1 or DWIMIFY2 such as CLISPCONTEXT, DWIMIFYCHANGE, etc., are assumed to be bound when DWIMIFYFLG is T, so that any call to DWIMIFY1 or DWIMIFY2 must also guarantee that these variables are bound. If the caller is not sure, it should use DWIMIFY1? and DWIMIFY2? since these do the appropriate checks. --- NOFIXFNSLST0 and NOFIXVARSLST0 are global varaales. They are initializaed to NOFIXFNSLST and NOFIXVARLST by DWIMIFY and DWIMIFYFNS, as well as CLISPIF, CLISPFOR, etc. when they enter the DWIMIFY functions, i.e. DWIMIFY1 and DWIMIFY2 for the first time. NOFIXFNSLST and NOFIXVARLST are the variable that the user can add things to. --- VARS is bound in WTFIX and in DWIMIFY0. DWIMIFY1 and DWIMIFY2 supply VARS in their call to WTFIX. Otherwise WTFIX comptes them. --- ATTEMPTFLG is bound in DWIMIFY1 and DWIMIFY2. It is used to inform DWIMIFY1 or DWIMIFY2, in the event that WTFIX was unable to make a correction, NOT to add the atom to NOFIXLST. For example, this occurs when a correction was offered to the user but rejected, e.g. U.D.F. T, and user declines the fix, T is not added to NOFIXLST.") + (PROG (FN FAULTFN DWIMIFY0CHANGE DWIMIFYCHANGE TEM CLISPCONTEXT ONEFLG (DWIMIFYING T) (DWIMIFYFLG T) [SIDES (CDR (LISTGET1 LISPXHIST 'SIDE] TYPE-IN? (FIXSPELLDEFAULT 'n)) (RETURN (COND - [(LISTP Y) (* ; "from DW command") + [(LISTP Y) (* ; "from DW command") [COND ([LISTP (SETQ FAULTFN (EVALV 'ATM] - (SETQ FAULTFN (CAR FAULTFN] (* ; "ATM is bound in EDITE.") + (SETQ FAULTFN (CAR FAULTFN] (* ; "ATM is bound in EDITE.") (SETQ VARS (VARSBOUNDINEDITCHAIN Y)) (SETQ EXPR (OR (CAR (LAST Y)) X)) - (LISPXPUT 'RESPELLS NIL NIL LISPXHIST) (* ; - "Essentially, a new call to DW is treated as a new event.") + (LISPXPUT 'RESPELLS NIL NIL LISPXHIST) (* ; + "Essentially, a new call to DW is treated as a new event.") (COND ((TAILP X (CAR Y)) (DWIMIFY2 X (CAR Y))) @@ -169,26 +169,32 @@ with the terms of said license. X) X) (T (DWIMIFY1 X] - (Y (* ; - "called from compileuserfn or compile1a. X is the expression to be dwimified.") + (Y (* ; + "called from compileuserfn or compile1a. X is the expression to be dwimified.") (SETQ FAULTFN Y) (AND (NULL EXPR) - (SETQ EXPR X)) (* ;; "EXPR is supplied on calls from compileuserfn. it is the top level def. on calls from compile1a, x and expr are the same") + (SETQ EXPR X)) + + (* ;; "EXPR is supplied on calls from compileuserfn. it is the top level def. on calls from compile1a, x and expr are the same") + (SETQ TEM (DWIMIFY1 X)) (AND DWIMIFY0CHANGE (DWIMARKASCHANGED FAULTFN SIDES)) TEM) - ((LISTP X) (* ; - "e.g. user types in a direct call to dwimify an xpression") + ((LISTP X) (* ; + "e.g. user types in a direct call to dwimify an xpression") (SETQQ FAULTFN TYPE-IN) (SETQ EXPR X) (DWIMIFY1 X)) - (T (* ; "DWIMIFY (functon-name)") - (SETQ TEM (EXPRCHECK X)) (* ; - "If EXPRCHECK performs spelling correction, it will rset FN.") + (T (* ; "DWIMIFY (functon-name)") + (SETQ TEM (EXPRCHECK X)) (* ; + "If EXPRCHECK performs spelling correction, it will rset FN.") (SETQ FAULTFN (SETQ FN (CAR TEM))) (DWIMIFY1 (SETQ EXPR (CDR TEM))) [COND - (DWIMIFY0CHANGE (* ;; "DWIMIFY0CHANGE is only bound in DWIMIFY0. it is only reset (in RETDWIM) when DWIMIFYFLG and DWIMIFYING are both T. It is true if there was ANY change in the entire expression. DWIMIFYCHANGE on the other hand is bound wheever DWIMIFYFLG is T, and it is true if there was any change in the prticular level expression being worked on.") + (DWIMIFY0CHANGE + + (* ;; "DWIMIFY0CHANGE is only bound in DWIMIFY0. it is only reset (in RETDWIM) when DWIMIFYFLG and DWIMIFYING are both T. It is true if there was ANY change in the entire expression. DWIMIFYCHANGE on the other hand is bound wheever DWIMIFYFLG is T, and it is true if there was any change in the prticular level expression being worked on.") + (DWIMARKASCHANGED FN SIDES) (COND ([OR (NOT (FGETD FN)) @@ -199,23 +205,31 @@ with the terms of said license. (DWIMIFY0? [LAMBDA (TAIL PARENT SUBPARENT FORMSFLG ONEFLG FAULTFN CLISPCONTEXT) - (* lmm "27-MAY-82 09:54") - (* ;; "DWIMIFY0? is an external entry to DWIMIFYBLOCK It is used to dwimify an expression where the contxt may or may not be under aother call to dwimify. it is used by RECORD, MATCH etc. as well s by CLISP4 in CLISPIFY.") - (* ;; "The value of DWIMIFY0? is NOT the expression (dwiified) but T or NIL depending on whether or not there was any change, i.e. the value of dwiifychange.") + (* lmm "27-MAY-82 09:54") + + (* ;; "DWIMIFY0? is an external entry to DWIMIFYBLOCK It is used to dwimify an expression where the contxt may or may not be under aother call to dwimify. it is used by RECORD, MATCH etc. as well s by CLISP4 in CLISPIFY.") + + (* ;; "The value of DWIMIFY0? is NOT the expression (dwiified) but T or NIL depending on whether or not there was any change, i.e. the value of dwiifychange.") + (PROG NIL (SELECTQ DWIMIFYFLG - (NIL (* ;; "Under a call to WTFIX, but not under a call to DWIMIFY, e.g. from evaluating a CREATE expression in a user program.") + (NIL + (* ;; "Under a call to WTFIX, but not under a call to DWIMIFY, e.g. from evaluating a CREATE expression in a user program.") + (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST)) - ((CLISPIFY VARSBOUND) (* ;; "e.g. call from clispify or record package. WAnt it to look like we are inside of a call to dwimify. calling function has already set up VARS and EXPR.") + ((CLISPIFY VARSBOUND) + + (* ;; "e.g. call from clispify or record package. WAnt it to look like we are inside of a call to dwimify. calling function has already set up VARS and EXPR.") + (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) [RETURN (PROG ((DWIMIFY0CHANGE T) - (DWIMIFYING T)) (* ; - "This is going to be treated as though were a caal to dwimify.") + (DWIMIFYING T)) (* ; + "This is going to be treated as though were a caal to dwimify.") (RETURN (DWMFY0]) - (EVAL (* ; - "random call to dwimify0? EVAL IS THE TOP LEVEL VALUE OF DWIMIFYFLG") + (EVAL (* ; + "random call to dwimify0? EVAL IS THE TOP LEVEL VALUE OF DWIMIFYFLG") (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) [RETURN (PROG (DWIMIFYFLG FAULTPOS EXPR VARS) @@ -243,7 +257,9 @@ with the terms of said license. [LAMBDA (FORM CLISPCONTEXT FORMSFLG) (COND (DWIMIFYFLG (DWMFY1 FORM)) - (T (* ;; "See comment in dwimify0. DWIMIFY1? is used where caller is not sure whether state variables have been set up.") + (T + (* ;; "See comment in dwimify0. DWIMIFY1? is used where caller is not sure whether state variables have been set up.") + (PROG ((DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) (DWIMIFYFLG T) DWIMIFYCHANGE) @@ -252,7 +268,7 @@ with the terms of said license. (RETURN (DWMFY1 FORM]) (DWMFY1 - [LAMBDA (FORM) (* lmm " 3-Jan-86 21:29") + [LAMBDA (FORM) (* lmm " 3-Jan-86 21:29") (PROG ((X FORM) CARFORM TEM CLISPCHANGE 89CHANGE ATTEMPTFLG CARISOKFLG) [COND @@ -273,7 +289,10 @@ with the terms of said license. CLISPRETRANFLG (RETURN X)) (NOT (COND - [(LISTP CARFORM) (* ;; "Checks whether CAR is a function object with a remote translation. Also converts to hash array from CLISP if hash array exists. CARISOKFLG is set so dont have to recheck at LP1.") + [(LISTP CARFORM) + + (* ;; "Checks whether CAR is a function object with a remote translation. Also converts to hash array from CLISP if hash array exists. CARISOKFLG is set so dont have to recheck at LP1.") + (OR (EQ (SETQ TEM (OR (CDR (FASSOC (CAAR X) DWIMEQUIVLST)) (CAAR X))) @@ -282,37 +301,46 @@ with the terms of said license. (SETQ CARISOKFLG (AND (CHECKTRAN CARFORM) (NULL CLISPRETRANFLG] ((LITATOM CARFORM) - (CLISP-SIMPLE-FUNCTION-P CARFORM](* ; - "The AND is true if CAR of form is not recognized.") + (CLISP-SIMPLE-FUNCTION-P CARFORM](* ; + "The AND is true if CAR of form is not recognized.") (COND [(PROG (NEXTAIL) - (RETURN (WTFIX0 X X X X))) (* ; "Successful correction.") + (RETURN (WTFIX0 X X X X))) (* ; "Successful correction.") (COND ((CHECKTRAN X) (RETURN X)) [CLISPCHANGE (COND ((NEQ CLISPCHANGE 'PARTIAL) - (* ;; "The tail must be DWIMIFIED if the transformation did not affect the entire form, e.g. (FOO<...> ...)") + + (* ;; "The tail must be DWIMIFIED if the transformation did not affect the entire form, e.g. (FOO<...> ...)") + (RETURN FORM)) ((LISTP CARFORM) (GO DWIMIFYTAIL)) (T (SETQ CLISPCHANGE NIL) - (GO TOP) (* ; - "Recheck CAR of FORM, as it may still be misspelled.") + (GO TOP) (* ; + "Recheck CAR of FORM, as it may still be misspelled.") ] (89CHANGE (SETQ 89CHANGE NIL) - (GO TOP) (* ; - "Recheck CAR of FORM, as it still may be misspelled, e.g. (conss8car X)") + (GO TOP) (* ; + "Recheck CAR of FORM, as it still may be misspelled, e.g. (conss8car X)") ] ((AND CLISPCHANGE (NEQ CLISPCHANGE 'PARTIAL)) - (* ;; "This means a CLISPCHANGE failed and not to bother with dwimifying rest of form, e.g. a bad IF or FOR statement.") + + (* ;; "This means a CLISPCHANGE failed and not to bother with dwimifying rest of form, e.g. a bad IF or FOR statement.") + (RETURN FORM)) ((AND (NULL ATTEMPTFLG) - (LITATOM CARFORM)) (* ;; "ATTEMPTFLG is used to distinguish between the case where DWIM does not recognize the problem at all, and that where it did but was unable to make the correction, e.g. a malformed IF, or else the user vetoed the correction.") + (LITATOM CARFORM)) + + (* ;; "ATTEMPTFLG is used to distinguish between the case where DWIM does not recognize the problem at all, and that where it did but was unable to make the correction, e.g. a malformed IF, or else the user vetoed the correction.") + (SETQ NOFIXFNSLST0 (CONS CARFORM NOFIXFNSLST0] - (* ;; "The call to WTFIX is made before specific checks on CAR of FORM, since CAR of the FORM may be misspelled.") + + (* ;; "The call to WTFIX is made before specific checks on CAR of FORM, since CAR of the FORM may be misspelled.") + (COND - ((LISTP CARFORM) (* ; "Skip selectq") + ((LISTP CARFORM) (* ; "Skip selectq") (GO DWIMIFYTAIL))) [SELECTQ CARFORM (* ; "NIL") @@ -320,8 +348,8 @@ with the terms of said license. (FUNCTION (LAMBDA (X) (SELECTQ (CAR X) ((USEDFREE GLOBALVARS) - (* ; - "SPECVARS AND LOCALVARS WOULD PRESUMABLY BE BOUND SOMEWHERE SO NO NEED TO ADD THEM") + (* ; + "SPECVARS AND LOCALVARS WOULD PRESUMABLY BE BOUND SOMEWHERE SO NO NEED TO ADD THEM") (SETQ NOFIXVARSLST0 (UNION (LISTP (CDR X)) NOFIXVARSLST0))) NIL]) @@ -358,8 +386,8 @@ with the terms of said license. (DWIMIFY2 X X NIL T]) (FUNCTION [DWIMIFY1 (COND ((LISTP (CADR X))) - ((NULL (CDDR X)) (* ; - "Doesnt DWIMIFY for (FUCNTION FOO (X Y)) i.e. FUNARY with atomic argument.") + ((NULL (CDDR X)) (* ; + "Doesnt DWIMIFY for (FUCNTION FOO (X Y)) i.e. FUNARY with atomic argument.") (CDR X]) (RESETVAR (DWIMIFY2 (CDDR X) FORM T)) @@ -372,7 +400,7 @@ with the terms of said license. (LIST (CADR X] VARS))) (COND - ((EQMEMB 'BINDS (GETPROP CARFORM 'INFO)) (* ; "PROG EQUIVALENTS") + ((EQMEMB 'BINDS (GETPROP CARFORM 'INFO)) (* ; "PROG EQUIVALENTS") ([LAMBDA (VARS) (DWIMIFY2 (CDDR X) FORM T] @@ -389,8 +417,8 @@ with the terms of said license. (FMEMB X (CADR FORM] (CAR X] VARS))) - ((CLISPNOEVAL CARFORM) (* ; - "Don't DWIMIFY the tails of nlambdas.") + ((CLISPNOEVAL CARFORM) (* ; + "Don't DWIMIFY the tails of nlambdas.") ) (T (GO DWIMIFYTAIL] (RETURN FORM) @@ -399,13 +427,16 @@ with the terms of said license. FORM) (SETQ CARFORM (OR (CDR (FASSOC (CAR X) DWIMEQUIVLST)) - (CAR X))) (* ; - "CARFORM may have changed if DWIMIFY2 changed X") + (CAR X))) (* ; + "CARFORM may have changed if DWIMIFY2 changed X") (COND [(LISTP CARFORM) (AND (NULL CARISOKFLG) (NULL CLISPCHANGE) - (DWIMIFY1 CARFORM)) (* ;; "Note that if CAR is a list, it itself has not yet been dwimified, e.g. may be a misspelled LAMBDA. However If CLISPCHANGE is not NIL, this expression was produced by the call to WTFIX and hence is already dwimified.") + (DWIMIFY1 CARFORM)) + + (* ;; "Note that if CAR is a list, it itself has not yet been dwimified, e.g. may be a misspelled LAMBDA. However If CLISPCHANGE is not NIL, this expression was produced by the call to WTFIX and hence is already dwimified.") + (COND ((AND (NULL FORMSFLG) (NEQ (SETQ TEM (OR (CDR (FASSOC (CAAR X) @@ -429,11 +460,11 @@ with the terms of said license. (RETURN FORM]) (DWIMIFY1A - [LAMBDA (PARENT TAIL FN) (* wt%: "10-DEC-80 23:36") + [LAMBDA (PARENT TAIL FN) (* wt%: "10-DEC-80 23:36") (COND ((AND (NULL DWIMESSGAG) (OR FN (AND DWIMIFYFLG DWIMIFYING)) - (NEQ CLISPCONTEXT 'IFWORD)) (* ; "clispif handles this itself.") + (NEQ CLISPCONTEXT 'IFWORD)) (* ; "clispif handles this itself.") (AND (FIXPRINTIN (OR FN FAULTFN)) (LISPXSPACES 1 T)) (COND @@ -461,7 +492,9 @@ with the terms of said license. [LAMBDA (TAIL PARENT SUBPARENT FORMSFLG ONEFLG ONLYSPELLFLG CLISPCONTEXT) (COND (DWIMIFYFLG (DWMFY2)) - (T (* ;; "See comment in dwimify0. DWIMIFY2? is used where caller is not sure whether state variables have been set up.") + (T + (* ;; "See comment in dwimify0. DWIMIFY2? is used where caller is not sure whether state variables have been set up.") + (PROG ((DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) (DWIMIFYFLG T) DWIMIFYCHANGE) @@ -478,7 +511,7 @@ with the terms of said license. (AND (OR (EQ SUBPARENT T) (EQ PARENT TAIL)) (SETQ SUBPARENT TAIL)) - + (* ;; "Means dont ever back up beyond this point, e.g. in prog variables, if you write (PROG ((X FOO Y LT 3) .. dont want LT to gobble the x.))") (SETQ CARPARENT (OR (CDR (FASSOC (CAR PARENT) @@ -514,25 +547,24 @@ with the terms of said license.  "none of the following corrections wanted") ) ((CLISPNOTVARP X) - - (* ;; "(CAR TAIL) is not recognized as a variable. Note that when DWIMIFYING, WTFIX will be called on a variable which is used freely, but does not have a top level binding, i.e. DWIMIFYING hile the variable is bound is not sufficient, because we do not do a STKSCAN for its value, as this would be expensive. (STKSCAN is done when DWIMIFY2 is called out of an evaluation.)") + + (* ;; "(CAR TAIL) is not recognized as a variable. Note that when DWIMIFYING, WTFIX will be called on a variable which is used freely, but does not have a top level binding, i.e. DWIMIFYING hile the variable is bound is not sufficient, because we do not do a STKSCAN for its value, as this would be expensive. (STKSCAN is done when DWIMIFY2 is called out of an evaluation.)") (COND [(AND FORMSFLG (EQ TAIL PARENT) (DWIMIFY2A TAIL 'QUIET)) - - (* ;; "DWIMIFY2A calls CLISPFUNCTION? to see if (CAR TAIL) is the name of a function. If FORMSFLG is true and (CAR TAIL) is name of function, then TAIL may be one form with parenteeses removed.") + + (* ;; "DWIMIFY2A calls CLISPFUNCTION? to see if (CAR TAIL) is the name of a function. If FORMSFLG is true and (CAR TAIL) is name of function, then TAIL may be one form with parenteeses removed.") (COND ((OR (NEQ X (CAR TAIL)) (NEQ FORMSFLG 'FORWORD)) - - (* ;; "Either the user has approved the combined spelling correction and insertion of paentheses, or else we are not under an I>S> without an oerator. (E.g. FOR X IN Y WHILE ATOM PRINT X, In this cae dont want to insert parentheses.) Note that if FOO is also the name of a variable as well as a function, no harm will be done in cases like IF A THEN FOO _ X. Only possible problem is for case like IF A THEN FOO _ X Y, where FFO is both a functionand a variable. In this case, parens would be inserted, and then an error generated. HOwever, this is extremely unlikely, since in most cases it would be written as IF A THEN FOO_X Y (not to mention the added improbability of FOO being both the name of a function and a variable.)") + + (* ;; "Either the user has approved the combined spelling correction and insertion of paentheses, or else we are not under an I>S> without an oerator. (E.g. FOR X IN Y WHILE ATOM PRINT X, In this cae dont want to insert parentheses.) Note that if FOO is also the name of a variable as well as a function, no harm will be done in cases like IF A THEN FOO ↠X. Only possible problem is for case like IF A THEN FOO ↠X Y, where FFO is both a functionand a variable. In this case, parens would be inserted, and then an error generated. HOwever, this is extremely unlikely, since in most cases it would be written as IF A THEN FOOâ†X Y (not to mention the added improbability of FOO being both the name of a function and a variable.)") (GO ASK)) (T - - (* ;; "(CAR TAIL) is the name of a function, but user hasnt been consulted, and we are under a FOR with no operator, so wait.") + (* ;; "(CAR TAIL) is the name of a function, but user hasnt been consulted, and we are under a FOR with no operator, so wait.") (SETQ FNFLG T) (* ;  "Now drop through to next COND and call to WTFIX (because (CAR TAIL) may be a miispelled variable.)") @@ -545,8 +577,8 @@ with the terms of said license. (DWIMIFY2A TAIL 'QUIET) (OR (NEQ X (CAR TAIL)) (LISTP CARPARENT))) - - (* ;; "Corresponds to the case where the user left a DO out of a for statement. Already know that the first thing in TAIL is not the name of a function. However, only take action if the usr approves combined correction, (or (CAR PARENT) is a list.) since it is still possible that X is the (misspelled) name of a variable.") + + (* ;; "Corresponds to the case where the user left a DO out of a for statement. Already know that the first thing in TAIL is not the name of a function. However, only take action if the usr approves combined correction, (or (CAR PARENT) is a list.) since it is still possible that X is the (misspelled) name of a variable.") (SETQQ FORMSFLG FOR1) (GO INSERT)) @@ -556,8 +588,8 @@ with the terms of said license. (CDDR TAIL)) (AND (EQ TAIL PARENT) (SETQ NOTOKFLG T)) - - (* ;; "E.g. (LIST X FOR X IN A --) The CDDR check is because very seldom you have an iterative statement only two elements long, but lots of places where iterative words can appear in another context, e.g. OF, TO, etc. See comment below on NOTOKFLG. Note that if FORMSFLG is true and (EQ TAIL PARENT), then CLISPFUNCTION? (via DWIMIFY2A) above would have returned T.") + + (* ;; "E.g. (LIST X FOR X IN A --) The CDDR check is because very seldom you have an iterative statement only two elements long, but lots of places where iterative words can appear in another context, e.g. OF, TO, etc. See comment below on NOTOKFLG. Note that if FORMSFLG is true and (EQ TAIL PARENT), then CLISPFUNCTION? (via DWIMIFY2A) above would have returned T.") (DWIMIFY1A PARENT TAIL) (* ;  "Stop dwimifying, strong evidence that expression is screwed up.") @@ -566,8 +598,8 @@ with the terms of said license. ((AND [NULL (AND ONLYSPELLFLG (OR (EQ NOSPELLFLG T) (AND NOSPELLFLG (NULL TYPE-IN?] (WTFIX0 X TAIL PARENT SUBPARENT ONLYSPELLFLG)) - - (* ;; "If both ONLYSPELLFLG and NOSPELLFLG are true, no point in calling WTFIX. ONLYSPELLFLG is true on calls fro CLISPATOM2A.") + + (* ;; "If both ONLYSPELLFLG and NOSPELLFLG are true, no point in calling WTFIX. ONLYSPELLFLG is true on calls fro CLISPATOM2A.") (COND (89CHANGE (SETQ NOTOKFLG NIL) @@ -581,13 +613,13 @@ with the terms of said license.  "NOTOKFLG=T means first expression in TAIL was not recognized as a variable.") [COND ((AND FORMSFLG (EQ TAIL PARENT)) - - (* ;; "After DWIMIFYING the whole tail, if CAR is still an atom, we may want to insert parentheses, e.g. (FOO _ X Y) is ok, but (FOO X Y) may need to be converted to ((FOO X Y))") + + (* ;; "After DWIMIFYING the whole tail, if CAR is still an atom, we may want to insert parentheses, e.g. (FOO ↠X Y) is ok, but (FOO X Y) may need to be converted to ((FOO X Y))") ) [(FGETD X) - - (* ;; "Don't add a function name to NOFIXVARSLST0 since this is tantamount to sanctiooning it as a variale.") + + (* ;; "Don't add a function name to NOFIXVARSLST0 since this is tantamount to sanctiooning it as a variale.") (COND ((AND (EQ FORMSFLG 'FORWORD) @@ -629,8 +661,8 @@ with the terms of said license. (OR (NULL NOTOKFLG) (NULL FNFLG)) (LISTP (CADR TAIL0] - - (* ;; "Corresponds to the cse where the user left out a DO. Want to check this before below as in this case dont want to stick in paens around entire form.") + + (* ;; "Corresponds to the cse where the user left out a DO. Want to check this before below as in this case dont want to stick in paens around entire form.") (GO OUT1)) ((EQ FORMSFLG T) (* ; @@ -639,15 +671,15 @@ with the terms of said license. [(CDR TAIL0) (* ; "FORMSFLG is FOR or IF") (COND ((OR NOTOKFLG (DWIMIFY2A TAIL0 'QUIET)) - - (* ;; "(CAR TAIL) is not the name of a variable, or else IS the name of a function. The reason for the call to CLISPFUNCTION? (via DWIMIFY2A) instead of checking FNFLG is that in the case that (CAR TAIL) was the name of a variable as indicated by NOTOKFLG=NIL, CLISPFUNCTION? would not have been called earlier.") + + (* ;; "(CAR TAIL) is not the name of a variable, or else IS the name of a function. The reason for the call to CLISPFUNCTION? (via DWIMIFY2A) instead of checking FNFLG is that in the case that (CAR TAIL) was the name of a variable as indicated by NOTOKFLG=NIL, CLISPFUNCTION? would not have been called earlier.") (/RPLNODE TAIL0 (CONS (CAR TAIL0) (CDR TAIL0))) (GO OUT1] ((AND NOTOKFLG FNFLG) - - (* ;; "(CAR TAIL) is not the name of a variable and is the name of a function, but nothing follows it. E.g. IF -- THEN RETURN ELSE --") + + (* ;; "(CAR TAIL) is not the name of a variable and is the name of a function, but nothing follows it. E.g. IF -- THEN RETURN ELSE --") (/RPLNODE TAIL0 (CONS (CAR TAIL0) (CDR TAIL0))) @@ -657,8 +689,8 @@ with the terms of said license. ((NULL ONEFLG) TAIL0) (NOTOKFLG - - (* ;; "In this way, the function thatcaled DWIMIFY2 can find out whether or not the atom in question is OK. NOte that if it appears on NOFIXLST, it is OK, i.e. havng been seen before, we treat it the same as a variable or what not.") + + (* ;; "In this way, the function thatcaled DWIMIFY2 can find out whether or not the atom in question is OK. NOte that if it appears on NOFIXLST, it is OK, i.e. havng been seen before, we treat it the same as a variable or what not.") NIL) ((NULL NEXTAIL) @@ -683,14 +715,14 @@ with the terms of said license. (GO DROPTHRU]) (DWIMIFY2A - [LAMBDA ($TAIL $TYP) (* wt%: 25-FEB-76 1 54) + [LAMBDA ($TAIL $TYP) (* wt%: 25-FEB-76 1 54) (CLISPFUNCTION? $TAIL $TYP [FUNCTION (LAMBDA (X Y) (SUBSTRING (RETDWIM2 Y) 2 -1] [FUNCTION (LAMBDA (X Y) (CONCAT [MKSTRING (RETDWIM2 (COND [(LISTP X) - (* ; "Run-on.") + (* ; "Run-on.") (CONS (CAR X) (CONS (CDR X) (CDR Y] @@ -699,19 +731,25 @@ with the terms of said license. $TAIL]) (CLISPANGLEBRACKETS - [LAMBDA (LST) (* wt%: "26-JUN-78 01:20") + [LAMBDA (LST) (* wt%: "26-JUN-78 01:20") (PROG [WORKFLAG (NCONCLKUP (CLISPLOOKUP 'NCONC)) (NCONC1LKUP (CLISPLOOKUP 'NCONC1] (RETURN (SHRIEKER LST]) (SHRIEKER - [LAMBDA (LOOKAT) (* ;; "Shrieker is designed to 'understand' expressions of the form (! A B !! C !! D E F), where A, B, C,... represent lists, ! indicates that the list following it is to be (non-destructively) expanded (e.g. A's elements are to be brought to the top level of the list which contains A), and !! indicates that the list following it is to be destructively expanded. Thus, if A= (H I J), B= (K L M), C= (N O P), the result of evaluating (! A !! B C) should be a list (H I J K L M C). SHRIEKER does not actually evaluate the list given to it, but rather returns a form which will have the correct evaluation. Thus, if SHRIEKER is given the (shriekified) list (! A !! B C), it will return the form (APPEND A (NCONC1 B C)). Should A,B,C have the values given above, then evaluation of this form will leave A unchanged, but B will have been destructively altered, and will now evaluate to the list (K L M (N O P)).") + [LAMBDA (LOOKAT) + + (* ;; "Shrieker is designed to 'understand' expressions of the form (! A B !! C !! D E F), where A, B, C,... represent lists, ! indicates that the list following it is to be (non-destructively) expanded (e.g. A's elements are to be brought to the top level of the list which contains A), and !! indicates that the list following it is to be destructively expanded. Thus, if A= (H I J), B= (K L M), C= (N O P), the result of evaluating (! A !! B C) should be a list (H I J K L M C). SHRIEKER does not actually evaluate the list given to it, but rather returns a form which will have the correct evaluation. Thus, if SHRIEKER is given the (shriekified) list (! A !! B C), it will return the form (APPEND A (NCONC1 B C)). Should A,B,C have the values given above, then evaluation of this form will leave A unchanged, but B will have been destructively altered, and will now evaluate to the list (K L M (N O P)).") + (PROG (CARTEST RESULTP) (COND ((OR (ATOM LOOKAT) (NLISTP LOOKAT)) (SETQ WORKFLAG NIL) - (RETURN LOOKAT))) (* ;; "As is evident from a look at the code, SHRIEKER is a fairly straightforward recursive prog; analysis of the argument, LOOKAT, is doen in effect from the tail of LOOKat to its head. I>e. given LOOKAT SHRIEKER separates it into two parts (roughly car and cdr), where one part (CARTEST) is the first element of LOOKAT that is not ! or !! , and the other part is the tail of LOOKAT below CARTEST-- LOOKAT is reset to evaluate to this tail and SHRIEKER is called recursively on the new LOOKAT, eventually returning a list structure, to which we setq RESULTP, that is the LISP equivalent of LOOKAT (which, with its !'s and !!'s is an expression in CLISP). The calling incarnation of SHRIEKER uses RESULTP and its knowledge of the shriek-sysmbol (! or ! ! or !!) immediately before CARTEST, to determine how CARTEST and RESULTP should be used to form the list structure that will be returned, possibly to higher level incarnations of SHRIEKER. into then possibly incarnations SHRIEKER.") + (RETURN LOOKAT))) + + (* ;; "As is evident from a look at the code, SHRIEKER is a fairly straightforward recursive prog; analysis of the argument, LOOKAT, is doen in effect from the tail of LOOKat to its head. I>e. given LOOKAT SHRIEKER separates it into two parts (roughly car and cdr), where one part (CARTEST) is the first element of LOOKAT that is not ! or !! , and the other part is the tail of LOOKAT below CARTEST-- LOOKAT is reset to evaluate to this tail and SHRIEKER is called recursively on the new LOOKAT, eventually returning a list structure, to which we setq RESULTP, that is the LISP equivalent of LOOKAT (which, with its !'s and !!'s is an expression in CLISP). The calling incarnation of SHRIEKER uses RESULTP and its knowledge of the shriek-sysmbol (! or ! ! or !!) immediately before CARTEST, to determine how CARTEST and RESULTP should be used to form the list structure that will be returned, possibly to higher level incarnations of SHRIEKER. into then possibly incarnations SHRIEKER.") + (SETQ CARTEST (CAR LOOKAT)) (SETQ LOOKAT (CDR LOOKAT)) [RETURN (COND @@ -723,12 +761,18 @@ with the terms of said license. (SETQ LOOKAT (CDR LOOKAT)) (COND ((EQ CARTEST '!) - (GO A1))) (* ;; "This conditional insures that SHRIEKER will understnad that the sequence ! ! means the atom !!. Control will be sent to the statement after A1, which will make sure that CARTEST is NCONCed onto RESULTP (if car of RESULTP is APPEND, CONS, NCONC1, or LIST) or will stuff CARTEST into second place in RESULTP, which is presumalby an NCONC expression-- all provided that WORKFLAG is NIL...") + (GO A1))) + + (* ;; "This conditional insures that SHRIEKER will understnad that the sequence ! ! means the atom !!. Control will be sent to the statement after A1, which will make sure that CARTEST is NCONCed onto RESULTP (if car of RESULTP is APPEND, CONS, NCONC1, or LIST) or will stuff CARTEST into second place in RESULTP, which is presumalby an NCONC expression-- all provided that WORKFLAG is NIL...") + (SETQ RESULTP (SHRIEKER LOOKAT)) - (* ; - "Here's our recursive call to SHRIEKER..") + (* ; + "Here's our recursive call to SHRIEKER..") (COND - ((NULL RESULTP) (* ;; "WORKFLAG is a flag that is passed between incarnations of SHRIEKER and is the means by which SHRIEKER is able to distinguish between user-created code and SHRIEKER-created code. If WORKFLAG eq's T then SHRIEKER knows that what has been returned as RESULTP is user-created code and should not be altered.") + ((NULL RESULTP) + + (* ;; "WORKFLAG is a flag that is passed between incarnations of SHRIEKER and is the means by which SHRIEKER is able to distinguish between user-created code and SHRIEKER-created code. If WORKFLAG eq's T then SHRIEKER knows that what has been returned as RESULTP is user-created code and should not be altered.") + (SETQQ WORKFLAG !IT) (LIST 'APPEND CARTEST)) ((ATOM RESULTP) @@ -737,7 +781,10 @@ with the terms of said license. ((NULL WORKFLAG) (SETQQ WORKFLAG APPENDING) (LIST 'APPEND CARTEST RESULTP)) - (T (* ;; "If the COND falls througn to this point then we may assume that RESULTP is SHRIEKER-created and do a SELECTQ on car of RESULTP (which should be either APPEND, NCONC, NCONC1, CONS, or LIST) to determine whether we should stuff CARTEST into RESULTP or not.") + (T + + (* ;; "If the COND falls througn to this point then we may assume that RESULTP is SHRIEKER-created and do a SELECTQ on car of RESULTP (which should be either APPEND, NCONC, NCONC1, CONS, or LIST) to determine whether we should stuff CARTEST into RESULTP or not.") + (SELECTQ WORKFLAG (APPENDING (ATTACH CARTEST (CDR RESULTP)) RESULTP) @@ -750,7 +797,10 @@ with the terms of said license. (!!IT (SETQQ WORKFLAG APPENDING) (LIST 'APPEND CARTEST (CADR RESULTP))) (LIST 'APPEND CARTEST RESULTP] - [LOOKAT (* ;; "If we arrive here then we know that SHRIEKER's arguemnt-- hte intial value of LOOKAT--is a list, the first element of which is not ! or !!. Accordingly, we attempt to CONS or LIST together CARTEST and RESULTP, depending on the nature of RESULTP and the value of WORKFLAG left by the recursive call to SHRIEKER in the statement below.") + [LOOKAT + + (* ;; "If we arrive here then we know that SHRIEKER's arguemnt-- hte intial value of LOOKAT--is a list, the first element of which is not ! or !!. Accordingly, we attempt to CONS or LIST together CARTEST and RESULTP, depending on the nature of RESULTP and the value of WORKFLAG left by the recursive call to SHRIEKER in the statement below.") + (SETQ RESULTP (SHRIEKER LOOKAT)) (COND ((NULL WORKFLAG) @@ -766,7 +816,9 @@ with the terms of said license. (SETQQ WORKFLAG CONSING) (LIST 'CONS CARTEST (CADR RESULTP))) (LIST 'CONS CARTEST RESULTP] - (T (* ;; "If we reach this point then we know that SHRIEKER was called on a singleton, i.e. the intial vlaue of LOOKAT was a list of one element, so we create the appropriate list structure around that element and setq WORKFLAG to NIL, enabling a possible parent SHRIEKER to modify our code.") + (T + (* ;; "If we reach this point then we know that SHRIEKER was called on a singleton, i.e. the intial vlaue of LOOKAT was a list of one element, so we create the appropriate list structure around that element and setq WORKFLAG to NIL, enabling a possible parent SHRIEKER to modify our code.") + (SETQQ WORKFLAG LISTING) (LIST 'LIST CARTEST] A1 (RETURN (COND @@ -806,8 +858,10 @@ with the terms of said license. (LIST NCONCLKUP CARTEST RESULTP]) (CLISPRESPELL - [LAMBDA (TL WORDS FLG) (* lmm " 4-SEP-83 23:31") - (* ;; "CLISPRESPELL essentially asks is it possible to inerpret (CAR TAIL) as one of WORDS. It first checks to make sure (CAR TAIL) isnt already something else-- e.g. a function, variable, member of NOFIXFNSLST (which is the same as being a function) etc.") + [LAMBDA (TL WORDS FLG) (* lmm " 4-SEP-83 23:31") + + (* ;; "CLISPRESPELL essentially asks is it possible to inerpret (CAR TAIL) as one of WORDS. It first checks to make sure (CAR TAIL) isnt already something else-- e.g. a function, variable, member of NOFIXFNSLST (which is the same as being a function) etc.") + (AND (NEQ NOSPELLFLG T) (OR (NOT NOSPELLFLG) TYPE-IN?) @@ -819,7 +873,7 @@ with the terms of said license. NIL WORDS FLG]) (EXPRCHECK - [LAMBDA (X) (* wt%: "14-FEB-78 00:06") + [LAMBDA (X) (* wt%: "14-FEB-78 00:06") (PROG (D) (COND ((NOT (LITATOM X)) @@ -839,30 +893,32 @@ with the terms of said license. (DEFINEQ (CLISPATOM0 - [LAMBDA (CHARLST TAIL PARENT) (* bvm%: "21-Nov-86 18:05") + [LAMBDA (CHARLST TAIL PARENT) (* bvm%: "21-Nov-86 18:05") (AND (NULL SUBPARENT) (SETQ SUBPARENT PARENT)) (PROG ((CURRTAIL TAIL) (NOFIXVARSLST1 NOFIXVARSLST0) 89FLG TEM) TOP (SELECTQ (DWIMUNDOCATCH 'CLISPATOM1 (SETQ TEM (CLISPATOM1 TAIL))) - (:RESPELL (* ; - "A misspelling was detected. Need to fix it now.") + (:RESPELL (* ; + "A misspelling was detected. Need to fix it now.") (SETQ NOFIXVARSLST0 NOFIXVARSLST1) (AND DWIMIFYFLG (SETQ CLISPCHANGE NIL)) (COND ((PROG1 (CLISPELL TAIL) - (SETQ CHARLST (DUNPACK (CAR TAIL) - WTFIXCHCONLST))) - (* ;; "MIsspelling found. Note that even if the word wasnt found, LST is reset since some tentative changes were tried, it was probably clobbered.") + (SETQ CHARLST (DUNPACK (CAR TAIL) + WTFIXCHCONLST))) + + (* ;; "MIsspelling found. Note that even if the word wasnt found, LST is reset since some tentative changes were tried, it was probably clobbered.") + (SETQ CURRTAIL TAIL) (GO TOP)))) - (NIL (* ; "error") + (NIL (* ; "error") (SETQ NOFIXVARSLST0 NOFIXVARSLST1)) (RETURN TEM)) (RETURN (COND - (89FLG (* ; - "E.G. N*8FOO -- fix the 8-9 error first.") + (89FLG (* ; + "E.G. N*8FOO -- fix the 8-9 error first.") [PROG ((FAULTX (CAR CURRTAIL))) (SETQ TEM (FIX89 FAULTX (CAR 89FLG) (LENGTH 89FLG] @@ -873,9 +929,12 @@ with the terms of said license. TAIL PARENT]) (CLISPATOM1 - [LAMBDA (TAIL) (* lmm "29-Jul-86 00:25") - (* ;;; "This function and its subfunctions handle infix operators. LST is an exploded list of characters for CAR of TAIL, which is a tail of PARENT. If LST contains an CLISP operator, or CAR of TAIL is one, CLISPATOM1 scans the rest of tail until it reaches the end of this cluster. For example, if TAIL is (... A* B + C D+E ...), the scan will stop after C. The scan separates out the operators from the operands. Note that because any operand can be a list, and hence separated from its operator, an operator can occur interior to an atom, as in A*B, at the end of an atom, as in (A* (--)), at the front of an atom, as in ((--) *A), or by itself, as in ((--) * (--)). Therefore, we permit the same options when the operand is a atomic, i.e. the user can type A*B, A* B, A *B, or A * B. Note that in the latter two cases, the first argument to the operator is not contained in TAIL, and it is necessary for CLISPATOM1 to back tail up one element using PARENT.") - (* ;; "After the scan has been completed, the form for the first operator is assembled. Since operators are always processed left to right, the first operand to this operator is always the single element preceding it (unless it is a unary operator). The right boundary, and hence the second operand, is determined by the operator, e.g. * is tighter than +, which is tighter than LS, etc. Thus ... A*B+C ... becomes ... (ITIMES A B) + C ... while ... A+B*C ... becomes ... (IPLUS A B * C) In either case, the rest of this cluster is processed from within this call to CLISPATOM1, thereby taking advantage of the fact that we know that the atoms do not contain operators, and therefore don't have to be unpacked and examined character by character.") + [LAMBDA (TAIL) (* lmm "29-Jul-86 00:25") + +(* ;;; "This function and its subfunctions handle infix operators. LST is an exploded list of characters for CAR of TAIL, which is a tail of PARENT. If LST contains an CLISP operator, or CAR of TAIL is one, CLISPATOM1 scans the rest of tail until it reaches the end of this cluster. For example, if TAIL is (... A* B + C D+E ...), the scan will stop after C. The scan separates out the operators from the operands. Note that because any operand can be a list, and hence separated from its operator, an operator can occur interior to an atom, as in A*B, at the end of an atom, as in (A* (--)), at the front of an atom, as in ((--) *A), or by itself, as in ((--) * (--)). Therefore, we permit the same options when the operand is a atomic, i.e. the user can type A*B, A* B, A *B, or A * B. Note that in the latter two cases, the first argument to the operator is not contained in TAIL, and it is necessary for CLISPATOM1 to back tail up one element using PARENT.") + + (* ;; "After the scan has been completed, the form for the first operator is assembled. Since operators are always processed left to right, the first operand to this operator is always the single element preceding it (unless it is a unary operator). The right boundary, and hence the second operand, is determined by the operator, e.g. * is tighter than +, which is tighter than LS, etc. Thus ... A*B+C ... becomes ... (ITIMES A B) + C ... while ... A+B*C ... becomes ... (IPLUS A B * C) In either case, the rest of this cluster is processed from within this call to CLISPATOM1, thereby taking advantage of the fact that we know that the atoms do not contain operators, and therefore don't have to be unpacked and examined character by character.") + (PROG ((L CHARLST) (LST0 CHARLST) CURRTAIL-1 CLTYP CLTYP1 ENDTAIL BROADSCOPE BACKUPFLG OPRFLAG NOTFLG TYP ATMS NOSAVEFLG @@ -887,15 +946,18 @@ with the terms of said license. (GO NEXT2))) TOP (SETQ ATMS NIL) LP (COND - ((NULL L) (* ; "End of an atom.") + ((NULL L) (* ; "End of an atom.") (COND - ((NULL TYP) (* ; - "If we have gone through the first atom without finding an CLISP operator, we are done.") + ((NULL TYP) (* ; + "If we have gone through the first atom without finding an CLISP operator, we are done.") (COND - ((NULL 89FLG) (* ; - "The case where there was an 8 or 9 and an operator has been handled in CL89CHECK.") + ((NULL 89FLG) (* ; + "The case where there was an 8 or 9 and an operator has been handled in CL89CHECK.") ) - (CURRTAIL (* ;; "8 and 9 errors are handled here instead of back in CLISPATOM where there is similar code, because there may be more than one 8 or 9 in the expression, and the first one may be ok, e.g. 8*X*8ADD1 Y") + (CURRTAIL + + (* ;; "8 and 9 errors are handled here instead of back in CLISPATOM where there is similar code, because there may be more than one 8 or 9 in the expression, and the first one may be ok, e.g. 8*X*8ADD1 Y") + (AND [FIX89A (CAR CURRTAIL) (CAR (LISTP 89FLG)) (IMINUS (SETQ TEM (LENGTH 89FLG] @@ -906,13 +968,19 @@ with the terms of said license. (EQ (CAR (LISTP 89FLG)) LPARKEY) (EQ (CAR (SETQ TEM (FLAST CHARLST))) - RPARKEY)) (* ;; "This corresponds to the case where an atom was typed in containing both an 8 and a 9, e.g. FILES?89 or 8EDITF9. Note that if the atom were part of a larger expression, either CAR of form, or appearing in a tail, (as indicated by CURRTAIL being non-NIL), the fix is performed by FIX89, and involves editing the expression. In the case covered here, the fix requires changing the EVAL to an apppropriate APPLY.") + RPARKEY)) + + (* ;; "This corresponds to the case where an atom was typed in containing both an 8 and a 9, e.g. FILES?89 or 8EDITF9. Note that if the atom were part of a larger expression, either CAR of form, or appearing in a tail, (as indicated by CURRTAIL being non-NIL), the fix is performed by FIX89, and involves editing the expression. In the case covered here, the fix requires changing the EVAL to an apppropriate APPLY.") + (FIX89TYPEIN (FMEMB LPARKEY (SETQ TEM (LDIFF CHARLST TEM))) TEM T))) (RETURN NIL)) - (LST0 (SETQ OPRFLAG T) (* ; - "OPRFLAG is T means the element just processed did NOT end in an operator, e.g. A+B, or just A.") - (SETQ TEM (PACK LST0)) (* ;; "Collects characters to the right of the last operator in the atom, or all the characters in the atom, if it contained no operator.") + (LST0 (SETQ OPRFLAG T) (* ; + "OPRFLAG is T means the element just processed did NOT end in an operator, e.g. A+B, or just A.") + (SETQ TEM (PACK LST0)) + + (* ;; "Collects characters to the right of the last operator in the atom, or all the characters in the atom, if it contained no operator.") + (SETQ ATMS (NCONC1 ATMS TEM)) (SETQ NOTFLG NIL))) (SETQ 89FLG NIL) @@ -927,11 +995,16 @@ with the terms of said license. (- [COND ((NULL (AND (EQ L LST0) (CLUNARYMINUS? OPRFLAG))) - (* ;; "Says minus is binary. See comments i CLUNARYMINUS?. By replacing binary minus with +- in CLISPATOM1, all the rest of the CLISP function can treat minus as unary.") + + (* ;; "Says minus is binary. See comments i CLUNARYMINUS?. By replacing binary minus with +- in CLISPATOM1, all the rest of the CLISP function can treat minus as unary.") + (FRPLACA L '+-) (SETQ CLTYP1 (GETPROP '+- 'CLISPTYPE]) (%' (AND (NEQ L LST0) - (GO LP1)) (* ;; "' is ignored interior to atoms, e.g. USER can have a function named ATOM' or a variable named A' which is not necessarily defined or bound at time of DWIMIFYing.") + (GO LP1)) + + (* ;; "' is ignored interior to atoms, e.g. USER can have a function named ATOM' or a variable named A' which is not necessarily defined or bound at time of DWIMIFYing.") + ) (COND [BRACKET (COND @@ -968,38 +1041,50 @@ with the terms of said license. LP1 (COND ((AND OPRFLAG (NULL BROADSCOPE) (ZEROP BRACKETCNT) - (EQ L CHARLST)) (* ;; "If OPRFLAG is T and the first character in LST is not an operator, no need to scan further, e.g. A*B C unless we are processing a broad scope operator, e.g. (A EQ FOO B) or unless ANGCNT is not 0, i.e. we are inside of an <> pair.") - (OR ENDTAIL (SETQ ENDTAIL CURRTAIL)) (* ;; "If ENDTAIL has not been set yet, set it. Note that ENDTAIL may already have been set, e.g. A*B+C D, in which case ENDTAIL would correspnd to the position of the +.") - (GO OUT) (* ;; "If this is the first character in an atom, then we cango to out, e.g. A+B C. HOwever, this may be the first character following a >, as in FOO_C, in which case we have to finish out the atom.") + (EQ L CHARLST)) + + (* ;; "If OPRFLAG is T and the first character in LST is not an operator, no need to scan further, e.g. A*B C unless we are processing a broad scope operator, e.g. (A EQ FOO B) or unless ANGCNT is not 0, i.e. we are inside of an <> pair.") + + (OR ENDTAIL (SETQ ENDTAIL CURRTAIL)) + + (* ;; "If ENDTAIL has not been set yet, set it. Note that ENDTAIL may already have been set, e.g. A*B+C D, in which case ENDTAIL would correspnd to the position of the +.") + + (GO OUT) + + (* ;; "If this is the first character in an atom, then we cango to out, e.g. A+B C. HOwever, this may be the first character following a >, as in FOOâ†C, in which case we have to finish out the atom.") + )) - (SETQ L (CDR L)) (* ; - "Peel off the current character and go on.") + (SETQ L (CDR L)) (* ; + "Peel off the current character and go on.") (GO LP) NEXT - (* ; - "We have just exhausted the lit of characters for an atm.") + (* ; + "We have just exhausted the lit of characters for an atm.") [COND - ((NULL TAIL) (* ; - "We were originally given just an atom, e.g. user types FOO_FIE.") + ((NULL TAIL) (* ; + "We were originally given just an atom, e.g. user types FOOâ†FIE.") (SETQ TAIL ATMS) (OR PARENT (SETQ PARENT TAIL))) ([AND TAIL (OR (CDR ATMS) (NEQ (CAR (LISTP ATMS)) - (CAR CURRTAIL] (* ;; "Splice burst version of atom into CURRTAIL, and set CURRTAIL to point to the as yet unexamined part of it. If the OR is not true, CURRTAIL would not be changd so don't bother e.g. (LIST A + B * C)") + (CAR CURRTAIL] + + (* ;; "Splice burst version of atom into CURRTAIL, and set CURRTAIL to point to the as yet unexamined part of it. If the OR is not true, CURRTAIL would not be changd so don't bother e.g. (LIST A + B * C)") + [/RPLNODE CURRTAIL (CAR (LISTP ATMS)) (NCONC (CDR ATMS) (SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 CURRTAIL] - (* ; - "CURRTAIL-1 is used for backing up, see below.") + (* ; + "CURRTAIL-1 is used for backing up, see below.") ) (T (SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 CURRTAIL] (COND - ((NULL CURRTAIL) (* ; - "We have reached the end of the faulty form.") + ((NULL CURRTAIL) (* ; + "We have reached the end of the faulty form.") (GO OUT))) NEXT1 - (* ; - "Look at the next thing in CURRTAIL.") + (* ; + "Look at the next thing in CURRTAIL.") (COND ([AND OPRFLAG DWIMIFYFLG ONEFLG (NULL BROADSCOPE) (ZEROP BRACKETCNT) @@ -1019,9 +1104,11 @@ with the terms of said license. (AND (NULL BRACKET) OPRFLAG (CLBINARYMINUS? CURRTAIL-1 CURRTAIL] - (CLISPNOTVARP (CAR CURRTAIL))) (* ;; "The OR check is to handle cases like (.. ' F/L) which I think means wquote the whole thing. NOte that this comes up in expressions like since when SHRIEKER calls DWIMIFY2, the ' and F/L have already been split apart.") - (* ; - "dont call clbinaryminus? if last thing ended in an operator. e.g. ((foo) + -2)") + (CLISPNOTVARP (CAR CURRTAIL))) + + (* ;; "The OR check is to handle cases like (.. ' F/L) which I think means wquote the whole thing. NOte that this comes up in expressions like since when SHRIEKER calls DWIMIFY2, the ' and F/L have already been split apart.") + (* ; + "dont call clbinaryminus? if last thing ended in an operator. e.g. ((foo) + -2)") (COND ([AND (SETQ CLTYP1 (GETPROP (CAR CURRTAIL) 'CLISPTYPE)) @@ -1034,7 +1121,10 @@ with the terms of said license. ((AND BRACKET (SETQ TEM (FMEMB (CADR BRACKET) (CDDR L))) (NOT (FMEMB (CAR BRACKET) - L))) (* ;; "< and > are thought of as brackets, rather than operaaors. Therefore this is necessary in order thatthings like <1 2 -1> work, i.e. --- not treated as binary in this case, also , and finally if A*B is the name of a variable Note that this doesnt quite handle all cases: where A*B is the name of a variable, will be broken apart, but then it isnt clear whats intended.") + L))) + + (* ;; "< and > are thought of as brackets, rather than operaaors. Therefore this is necessary in order thatthings like <1 2 -1> work, i.e. --- not treated as binary in this case, also , and finally if A*B is the name of a variable Note that this doesnt quite handle all cases: where A*B is the name of a variable, will be broken apart, but then it isnt clear whats intended.") + (CLRPLNODE CURRTAIL (PACK (LDIFF L TEM)) (CONS (PACK TEM) (CDR CURRTAIL))) @@ -1058,10 +1148,10 @@ with the terms of said license. (T (RETDWIM2 Y] [FUNCTION (LAMBDA (X Y) (MKSTRING (CONS X (RETDWIM2 Y] - (CAR CURRTAIL))) (* ; - "This clause checks for user typing in apply mode, e.g. X_CONS (A B)") - (SETQQ TENTATIVE CERTAINLY) (* ; - "Once you print a message, you dont want to go and try another interpretation.") + (CAR CURRTAIL))) (* ; + "This clause checks for user typing in apply mode, e.g. Xâ†CONS (A B)") + (SETQQ TENTATIVE CERTAINLY) (* ; + "Once you print a message, you dont want to go and try another interpretation.") (/RPLNODE TEM (CONS (CAR TEM) (CAR CURRTAIL)) (CDR CURRTAIL)) @@ -1071,22 +1161,22 @@ with the terms of said license. (GO NEXT1))) (COND ((AND OPRFLAG (NULL BROADSCOPE) - (ZEROP BRACKETCNT)) (* ; "Finished. E.g. A*B (--)") + (ZEROP BRACKETCNT)) (* ; "Finished. E.g. A*B (--)") (OR ENDTAIL (SETQ ENDTAIL CURRTAIL)) (GO OUT)) ([SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 CURRTAIL] - (* ; "E.g. A* (--)") + (* ; "E.g. A* (--)") (SETQ OPRFLAG T) (SETQ NOTFLG NIL) (GO NEXT1)) (T (GO OUT))) NEXT2 - (* ; - "(CAR CURRTAIL) is an operaaor. CLTYP1 is its CLISPTYPe.") + (* ; + "(CAR CURRTAIL) is an operaaor. CLTYP1 is its CLISPTYPe.") [SELECTQ (CAR CURRTAIL) (- [COND - ((NULL (CLUNARYMINUS? OPRFLAG)) (* ; - "The minus is biary. SEe comments at earlier call to CLUNARYMINUS? in CLSPATOM1.") + ((NULL (CLUNARYMINUS? OPRFLAG)) (* ; + "The minus is biary. SEe comments at earlier call to CLUNARYMINUS? in CLSPATOM1.") (/RPLNODE CURRTAIL '+- (CDR CURRTAIL)) (SETQ CLTYP1 (GETPROP '+- 'CLISPTYPE]) ((-> =>) @@ -1114,36 +1204,42 @@ with the terms of said license. PARENT] (COND (ENDTAIL) - [(NULL TYP) (* ; "This is the first operator.") + [(NULL TYP) (* ; "This is the first operator.") (SETQ TYP (CAR CURRTAIL)) (SETQ CLTYP CLTYP1) (SETQ BROADSCOPE (GETPROP TYP 'BROADSCOPE)) (SETQ NOTFLG (EQ (SETQ TEM (GETPROP TYP 'LISPFN)) 'NOT] - (NOTFLG (* ;; "NOTFLG is true when we are processing a NOT opeator, and it immediately precedes the current operator. In this case, the scope of the NOT is the scope of the next opeator, e.g. (X ~GR FOO Y)") + (NOTFLG + + (* ;; "NOTFLG is true when we are processing a NOT opeator, and it immediately precedes the current operator. In this case, the scope of the NOT is the scope of the next opeator, e.g. (X ~GR FOO Y)") + (SETQ CLTYP CLTYP1) (SETQ BROADSCOPE (GETPROP (CAR CURRTAIL) 'BROADSCOPE)) (SETQ NOTFLG (EQ (GETPROP (CAR CURRTAIL) 'LISPFN) - 'NOT)) (* ; - "So that NOTFLG is not turned off when there are two ~'s in a row, e.g. (X ~~GR FOO Y OR Z)") + 'NOT)) (* ; + "So that NOTFLG is not turned off when there are two ~'s in a row, e.g. (X ~~GR FOO Y OR Z)") ) ((STOPSCAN? CLTYP1 CLTYP (CAR CURRTAIL) - OPRFLAG) (* ;; "This operator delimits the scope of the first operator found. Set ENDTAIL to be the first thing not within the scope of the operator. The AND is so that a unary operator will terminate the scope of a binary operator that has a right hand operand, e.g. X+Y -Z, X_Y 'Z, etc.") + OPRFLAG) + + (* ;; "This operator delimits the scope of the first operator found. Set ENDTAIL to be the first thing not within the scope of the operator. The AND is so that a unary operator will terminate the scope of a binary operator that has a right hand operand, e.g. X+Y -Z, Xâ†Y 'Z, etc.") + (SETQ ENDTAIL CURRTAIL))) (SETQ ISFLG (EQ [CAR (LISTP (GETPROP (CAR CURRTAIL) 'CLISPCLASS] 'ISWORD)) NEXT3 [SETQ OPRFLAG (AND BRACKET (EQ (CAR CURRTAIL) - (CADR BRACKET] (* ; - "OPRFLAG is T aater > since no right hand operand is reuired.") + (CADR BRACKET] (* ; + "OPRFLAG is T aater > since no right hand operand is reuired.") (COND ([SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 CURRTAIL] (GO NEXT1))) - OUT (* ; - "We are finished scanning. Now call CLISPATOM2 to assemble the correct form.") + OUT (* ; + "We are finished scanning. Now call CLISPATOM2 to assemble the correct form.") [COND ((NEQ (CAR (LISTP TAIL)) TYP) @@ -1151,10 +1247,13 @@ with the terms of said license. ((GETPROP TYP 'UNARYOP) (GO OUT1)) ((OR (EQ PARENT TAIL) - (EQ SUBPARENT TAIL)) (* ; "E.g. (+ X) or (SETQ Y + X)") + (EQ SUBPARENT TAIL)) (* ; "E.g. (+ X) or (SETQ Y + X)") (DWIMERRORRETURN (LIST 1 TAIL PARENT] (SETQ TAIL (NLEFT (OR SUBPARENT PARENT) - 1 TAIL)) (* ;; "SUBPARENT can be used to mark that point in a list beyond which not to back up, e.g. (LAMBDA (X) FOO X LT Y)") + 1 TAIL)) + + (* ;; "SUBPARENT can be used to mark that point in a list beyond which not to back up, e.g. (LAMBDA (X) FOO X LT Y)") + (SETQ BACKUPFLG T) OUT1 (CLISPATOM2) @@ -1167,9 +1266,11 @@ with the terms of said license. 'CLISPWORD] 'FORWORD) (OR (EQ CLISPCONTEXT 'FORWORD) - (EQ CLISPCONTEXT 'FOR/BIND](* ;; "i used to have just a (NULL (AND DWIMIFYFLG ONEFLG)) but this means tht if you have a predicate in an iterative statement, e.g. when x=y+z that it doesnt dwimify completely. the above clause handles it but i dont remember why i had the original one in there.") - (* ; - "reason for the or check is so that DO doesnt get treated as an IS word when coming from an i.s.") + (EQ CLISPCONTEXT 'FOR/BIND] + + (* ;; "i used to have just a (NULL (AND DWIMIFYFLG ONEFLG)) but this means tht if you have a predicate in an iterative statement, e.g. when x=y+z that it doesnt dwimify completely. the above clause handles it but i dont remember why i had the original one in there.") + (* ; + "reason for the or check is so that DO doesnt get treated as an IS word when coming from an i.s.") (SETQ TEM (CLISPATOM1A TYP CLTYP TAIL)) (COND ((OR DWIMIFYFLG (EQ TEM PARENT)) @@ -1190,21 +1291,26 @@ with the terms of said license. TAIL) (T (CAR (LISTP TAIL] (COND - ((AND TENTATIVE (NEQ TENTATIVE 'CERTAINLY)) (* ;; "Tentative is set to CERTAINLY when we are sure the correction will be CLISP, and to avoid somebody else setting to T . IN this casse there will be no message. This occurs when a message has already been printed, e.g. in X*FOO Y , when user is asked FOO Y -> (FOO Y), the approveal of the CLISP transformation is implicit.") + ((AND TENTATIVE (NEQ TENTATIVE 'CERTAINLY)) + + (* ;; "Tentative is set to CERTAINLY when we are sure the correction will be CLISP, and to avoid somebody else setting to T . IN this casse there will be no message. This occurs when a message has already been printed, e.g. in X*FOO Y , when user is asked FOO Y -> (FOO Y), the approveal of the CLISP transformation is implicit.") + (SETQ CLISPCHANGES (LIST TEM (CLISPATOM1B) TAIL (CDR TAIL) TENTATIVE NOFIXVARSLST0)) - (* ;; "note --- (CDR TAIL) used to be endtail in above expression, however, for situations where clispatom1a munches for a while, this does not produce the right message, e.g. dwimifying .... FOO:1='ZAP ...") + + (* ;; "note --- (CDR TAIL) used to be endtail in above expression, however, for situations where clispatom1a munches for a while, this does not produce the right message, e.g. dwimifying .... FOO:1='ZAP ...") + (AND DWIMIFYFLG (SETQ CLISPCHANGE NIL)) (DWIMERRORRETURN))) (RETURN TEM) - OPR (* ; - "We have hit an operator inside of an atom.") + OPR (* ; + "We have hit an operator inside of an atom.") (COND ((NEQ L LST0) - (SETQ TEM (PACK (LDIFF LST0 L))) (* ; - "Collects characters to the right of the last operator in the atom.") + (SETQ TEM (PACK (LDIFF LST0 L))) (* ; + "Collects characters to the right of the last operator in the atom.") (COND ((AND (FLOATP TEM) (OR (EQ (CAR L) @@ -1212,7 +1318,7 @@ with the terms of said license. (EQ (CAR L) '+-)) (EQ (CAR (NLEFT LST0 1 L)) - 'E)) (* ; "E.G. X+1.0E-5*Y") + 'E)) (* ; "E.G. X+1.0E-5*Y") (AND (EQ (CAR L) '+-) (FRPLACA L '-)) @@ -1222,13 +1328,16 @@ with the terms of said license. (SETQ ATMS (NCONC1 ATMS (CAR L))) [COND (ENDTAIL) - [(NULL TYP) (* ; "First operator.") + [(NULL TYP) (* ; "First operator.") (SETQ TYP (CAR L)) (SETQ CLTYP CLTYP1) (SETQ BROADSCOPE (GETPROP TYP 'BROADSCOPE)) (SETQ NOTFLG (EQ (GETPROP TYP 'LISPFN) 'NOT] - [NOTFLG (* ;; "It is not only necessary that we are processing a NOT, but that it immediately precede the current operator.") + [NOTFLG + + (* ;; "It is not only necessary that we are processing a NOT, but that it immediately precede the current operator.") + (SETQ CLTYP CLTYP1) (SETQ BROADSCOPE (GETPROP (CAR L) 'BROADSCOPE)) @@ -1237,22 +1346,28 @@ with the terms of said license. 'NOT] ((STOPSCAN? CLTYP1 CLTYP (CAR L) (OR (NEQ L LST0) - OPRFLAG)) (* ;; "This operator delimits the scope of the first operator found. Set ENDTAIL to be the first thing not within the scope of the operator.") + OPRFLAG)) + + (* ;; "This operator delimits the scope of the first operator found. Set ENDTAIL to be the first thing not within the scope of the operator.") + (SETQ ENDTAIL (COND - ((EQ L CHARLST) (* ; - "The scope delimiting operator was the first thing in an atom, e.g. A*B +C or A*B + C.") + ((EQ L CHARLST) (* ; + "The scope delimiting operator was the first thing in an atom, e.g. A*B +C or A*B + C.") CURRTAIL) (T (FLAST ATMS] [SETQ OPRFLAG (AND BRACKET (EQ (CAR L) - (CADR BRACKET] (* ; - "OPRFLAG is T aater > since no right hand operand is reuired.") + (CADR BRACKET] (* ; + "OPRFLAG is T aater > since no right hand operand is reuired.") (COND ([AND (CDR L) CURRTAIL (OR (AND BRACKET (EQ (CAR L) (CADR BRACKET))) (EQ (CAR L) - '~] (* ;; "So that the rest of the atom will be looked at as a unit before being unpacked, e.g. ~GR, want to look up GR. Also want to look at rest of atom as a unit following >, e.g. FOO_EQUAL C. By starting over with a new atom, we also perform the OPRFLAG terminating check, as in FOO_C.") + '~] + + (* ;; "So that the rest of the atom will be looked at as a unit before being unpacked, e.g. ~GR, want to look up GR. Also want to look at rest of atom as a unit following >, e.g. FOOâ†EQUAL C. By starting over with a new atom, we also perform the OPRFLAG terminating check, as in FOOâ†C.") + (/RPLNODE CURRTAIL (CAR CURRTAIL) (CONS (PACK (CDR L)) (CDR CURRTAIL))) @@ -1261,22 +1376,25 @@ with the terms of said license. (SETQ LST0 (CDR L)) (SETQ L (AND (NEQ (CAR L) '%') - (CDR L))) (* ; - "Following a ' no operaars are recognized in the rest of the atm.") + (CDR L))) (* ; + "Following a ' no operaars are recognized in the rest of the atm.") (GO LP]) (CLRPLNODE [LAMBDA (X A D) (PROG ((L (CDR UNDOSIDE))) (COND - (NOSAVEFLG (* ; - "X is not contained in original expression, so don't bother to save") + (NOSAVEFLG (* ; + "X is not contained in original expression, so don't bother to save") (GO OUT))) LP (COND - ((EQ L (CDR UNDOSIDE0)) (* ; "X has not previously been saved") + ((EQ L (CDR UNDOSIDE0)) (* ; "X has not previously been saved") (/RPLNODE X A D) (RETURN X)) - ((NEQ X (CAAR L)) (* ;; "If X is EQ to CAR of one of the entries on UNDOOSIDE, then the contents of this node have already been saved, so it is ok to smash it.") + ((NEQ X (CAAR L)) + + (* ;; "If X is EQ to CAR of one of the entries on UNDOOSIDE, then the contents of this node have already been saved, so it is ok to smash it.") + (SETQ L (CDR L)) (GO LP))) OUT (FRPLACA X A) @@ -1284,8 +1402,10 @@ with the terms of said license. (RETURN X]) (STOPSCAN? - [LAMBDA (CLTYP2 CLTYP1 OPR OPRFLAG) (* wt%: "16-AUG-78 21:47") - (* ;; "STOPSCAN? is T if operator corresponding to CLTYPX would stop scan for operator corresponding to CLTYP, i.e. if former is of lower or same precedence as latter.") + [LAMBDA (CLTYP2 CLTYP1 OPR OPRFLAG) (* wt%: "16-AUG-78 21:47") + + (* ;; "STOPSCAN? is T if operator corresponding to CLTYPX would stop scan for operator corresponding to CLTYP, i.e. if former is of lower or same precedence as latter.") + (AND CLTYP2 CLTYP1 (PROG NIL (COND [BROADSCOPE (COND @@ -1295,18 +1415,26 @@ with the terms of said license. [(EQ CLTYP2 'BRACKET) (RETURN (COND [(EQ OPR (CAR BRACKET)) - (* ; "a left bracket") - (* ;; "e.g. for X+Y< -- stop scanning. note that for binary brackets, it never stops as is consistent with them being very tight operators, i.e. FOO_A{..} parses as FOO_ (A{..})") + (* ; "a left bracket") + + (* ;; "e.g. for X+Y< -- stop scanning. note that for binary brackets, it never stops as is consistent with them being very tight operators, i.e. FOOâ†A{..} parses as FOO↠(A{..})") + (AND OPRFLAG (EQ BRACKETCNT 1) (GETP OPR 'UNARYOP] ((EQ CLTYP1 'BRACKET) - (* ;; "i.e. if OPR is the right bracket for BRACKET, or if OPR is some other bracket inside of scope of BRACKET.") - (* ;; "if cltyp1 is ot a bracket, then bracket is not the operator, and should really treat the whole bracketed expression as an operand and not stop the scan.") + + (* ;; "i.e. if OPR is the right bracket for BRACKET, or if OPR is some other bracket inside of scope of BRACKET.") + + (* ;; "if cltyp1 is ot a bracket, then bracket is not the operator, and should really treat the whole bracketed expression as an operand and not stop the scan.") + (ZEROP BRACKETCNT] ((NOT (ZEROP BRACKETCNT)) (RETURN NIL)) ((GETPROP OPR 'UNARYOP) - (RETURN OPRFLAG) (* ;; "If OPRFLAG is NIL, we have just seen a unary operator with no operand, so under no circumstance stop the scan. E.g. X*-Y. Note that this does NOT say do not consider next operand as possible operatr, so that X*-+Y will generate an error, not try to multiply X by (minus +). The case whee the unary operaar is ' is handled specially in CLISPATOM1 and CLISPATOM1A.") + (RETURN OPRFLAG) + + (* ;; "If OPRFLAG is NIL, we have just seen a unary operator with no operand, so under no circumstance stop the scan. E.g. X*-Y. Note that this does NOT say do not consider next operand as possible operatr, so that X*-+Y will generate an error, not try to multiply X by (minus +). The case whee the unary operaar is ' is handled specially in CLISPATOM1 and CLISPATOM1A.") + )) (RETURN (COND ([NOT (ILESSP (COND @@ -1324,13 +1452,17 @@ with the terms of said license. ((ATOM CLTYP1) CLTYP1) (T (CDR CLTYP1] - (* ;; "Not sure of this. it is an attempt to handle the A*B_C+D case. Here the initial cltyp is that of *, but since the right precedence of _ is looser than that of *, means that it should be operative.") + + (* ;; "Not sure of this. it is an attempt to handle the A*Bâ†C+D case. Here the initial cltyp is that of *, but since the right precedence of ↠is looser than that of *, means that it should be operative.") + (SETQ CLTYP CLTYP2) NIL]) (CLUNARYMINUS? - [LAMBDA (OPRFLAG) (* lmm "20-May-84 20:02") - (* ;; "True if minus is unary. This is the case when either (1) it immediately follows an operator (the (AND TYP (NULL OPRFLAG)) check) or (2) it is the first thing in a list (the (EQ CURRTAIL SUBPARENT) check) or else, car of form is a function and not a variable, and --- negates its first argument. The case where car of form is amisspeleed function is handled, because the tentatitve correction for binry minus will be tried, and then when spelling correction on function name suceeds, this will be implemeneted. then there will be another call to clispatom when its aagument is evaluated, and this time the functionis spelled right. Note that the cse where car of a form is a misspelled variable works also, even when the variabl could be confusec for a function, since the correction on the variable is tried first.") + [LAMBDA (OPRFLAG) (* lmm "20-May-84 20:02") + + (* ;; "True if minus is unary. This is the case when either (1) it immediately follows an operator (the (AND TYP (NULL OPRFLAG)) check) or (2) it is the first thing in a list (the (EQ CURRTAIL SUBPARENT) check) or else, car of form is a function and not a variable, and --- negates its first argument. The case where car of form is amisspeleed function is handled, because the tentatitve correction for binry minus will be tried, and then when spelling correction on function name suceeds, this will be implemeneted. then there will be another call to clispatom when its aagument is evaluated, and this time the functionis spelled right. Note that the cse where car of a form is a misspelled variable works also, even when the variabl could be confusec for a function, since the correction on the variable is tried first.") + (OR (AND TYP (NULL OPRFLAG)) (EQ CURRTAIL SUBPARENT) (AND (EQ CURRTAIL (CDR SUBPARENT)) @@ -1352,9 +1484,12 @@ with the terms of said license. '" " T]) (CLBINARYMINUS? - [LAMBDA ($TAIL MINUSTAIL) (* wt%: "10-OCT-78 21:22") - (* ;; "used when a negative number follows a list. we dont know if a space was typed before the --- or not, so in situation ike ((list) -2) or (x* (list) -2) we ask. warren ^Z") - (* ;; "the EQ used to check tail against subparent. i changed it because on calls to dwimify0? from record, e.g. (ADD z:1 -1), was trying to treat -1 as binary even though it shouldnt have.") + [LAMBDA ($TAIL MINUSTAIL) (* wt%: "10-OCT-78 21:22") + + (* ;; "used when a negative number follows a list. we dont know if a space was typed before the --- or not, so in situation ike ((list) -2) or (x* (list) -2) we ask. warren ↑Z") + + (* ;; "the EQ used to check tail against subparent. i changed it because on calls to dwimify0? from record, e.g. (ADD z:1 -1), was trying to treat -1 as binary even though it shouldnt have.") + (AND (EQ TAIL PARENT) [OR (LISTP (CAR TAIL)) (NUMBERP (CAR TAIL)) @@ -1379,8 +1514,10 @@ with the terms of said license. (CDR MINUSTAIL]) (CLISPATOM1A - [LAMBDA (TYP CLTYP TAIL NOSAVEFLG) (* lmm " 4-SEP-83 22:50") - (* ;;; "This function is similar to CLISPATOM1 except that elements of TAIL do not have to be unpacked. It is called from either CLISPATOM1 or CLISPATOM2 when more than one operator was encountered in a cluster. CADR of TAIL is TYP, the next operator to be processed, and CLTYP is its CLISPTYPE. CLISPATOM1A scans down TAIL looking for the right hand boundary of TYP, but does not unpack any atoms. It then calls CLISPATOM2 to assemble the form, and then if necessary repeats the process. For example, if the original cluster was A+B*C, the call to CLISPATOM2 from CLISPATOM1 would replace this with (IPLUS A B * C). CLISPATOM2 would then call CLISPATOM1A with TAIL= (B * C). Similary, if the original cluster were A*B+C, the call to CLISPATOM2 from CLISPATOM1 would replace this with (ITIMES A B) with + C having been spliced into the tail. CLISPATOM1 would then call CLISPATOM1A with TAIL= ((ITIMES A B) + C ...)") + [LAMBDA (TYP CLTYP TAIL NOSAVEFLG) (* lmm " 4-SEP-83 22:50") + +(* ;;; "This function is similar to CLISPATOM1 except that elements of TAIL do not have to be unpacked. It is called from either CLISPATOM1 or CLISPATOM2 when more than one operator was encountered in a cluster. CADR of TAIL is TYP, the next operator to be processed, and CLTYP is its CLISPTYPE. CLISPATOM1A scans down TAIL looking for the right hand boundary of TYP, but does not unpack any atoms. It then calls CLISPATOM2 to assemble the form, and then if necessary repeats the process. For example, if the original cluster was A+B*C, the call to CLISPATOM2 from CLISPATOM1 would replace this with (IPLUS A B * C). CLISPATOM2 would then call CLISPATOM1A with TAIL= (B * C). Similary, if the original cluster were A*B+C, the call to CLISPATOM2 from CLISPATOM1 would replace this with (ITIMES A B) with + C having been spliced into the tail. CLISPATOM1 would then call CLISPATOM1A with TAIL= ((ITIMES A B) + C ...)") + (PROG (ENDTAIL OPRFLAG BROADSCOPE CLTYP0 BRACKETCNT BRACKET ISFLG) TOP (SETQ ISFLG (EQ (CAR (GETPROP TYP 'CLISPCLASS)) 'ISWORD)) @@ -1389,8 +1526,8 @@ with the terms of said license. 1) (T 0))) [SETQ ENDTAIL (COND - ((EQ TYP (CAR TAIL)) (* ; - "TYP is car of TAIL for unary operatrs, CADR for binary.") + ((EQ TYP (CAR TAIL)) (* ; + "TYP is car of TAIL for unary operatrs, CADR for binary.") TAIL) (T (CDR TAIL] [COND @@ -1437,8 +1574,8 @@ with the terms of said license. (GO OUT)) [SETQ OPRFLAG (AND (EQ CLTYP0 'BRACKET) (EQ (CAR ENDTAIL) - (CADR BRACKET] (* ; - "E.g. X_ see comment in CLISPATOM1") + (CADR BRACKET] (* ; + "E.g. X↠see comment in CLISPATOM1") ) ((AND OPRFLAG (ZEROP BRACKETCNT) (NULL BROADSCOPE)) @@ -1453,15 +1590,20 @@ with the terms of said license. 'CLISPWORD)) 'FORWORD) (OR (EQ CLISPCONTEXT 'FORWORD) - (EQ CLISPCONTEXT 'FOR/BIND](* ;; "E.g. A+B*C+D. The first call to CLISPATOM1A is with TAIL (B * C + D). The first call to CLISPATOM2 changes this to ((ITIMES B C) + D), and then we loop back to the top of CLISPATOM1A. The reason for the OR is so that do does not get treated as an IS WORD when coming from an i.s.") + (EQ CLISPCONTEXT 'FOR/BIND] + + (* ;; "E.g. A+B*C+D. The first call to CLISPATOM1A is with TAIL (B * C + D). The first call to CLISPATOM2 changes this to ((ITIMES B C) + D), and then we loop back to the top of CLISPATOM1A. The reason for the OR is so that do does not get treated as an IS WORD when coming from an i.s.") + (GO TOP))) - (AND TENTATIVE (SETQQ TENTATIVE PROBABLY)) (* ; - "Don't consider another interpretation if there are two or more CLISP operators in this cluster.") + (AND TENTATIVE (SETQQ TENTATIVE PROBABLY)) (* ; + "Don't consider another interpretation if there are two or more CLISP operators in this cluster.") (RETURN TAIL]) (CLISPATOM1B - [LAMBDA NIL (* wt%: 25-FEB-76 1 41) - (* ;; "Copies changes.") + [LAMBDA NIL (* wt%: 25-FEB-76 1 41) + + (* ;; "Copies changes.") + (PROG ((L UNDOSIDE) (L1 (CDR UNDOSIDE0)) LST) @@ -1475,7 +1617,7 @@ with the terms of said license. (CDAAR L))) LST))) ((EQ (CAAR L) - '/PUTHASH) (* ; "Pattern match.") + '/PUTHASH) (* ; "Pattern match.") (SETQ LST (CONS (LIST '/PUTHASH (CADAR L) (GETHASH (CADAR L) CLISPARRAY) @@ -1484,9 +1626,10 @@ with the terms of said license. (GO LP]) (CLISPATOM2 - [LAMBDA NIL (* bvm%: "21-Nov-86 11:56") - (* ;; - "Assembles LISP forms from the CLISP expressions") + [LAMBDA NIL (* bvm%: "21-Nov-86 11:56") + + (* ;; "Assembles LISP forms from the CLISP expressions") + (PROG ((PARENT PARENT) VAR1 VAR2 Z (UNARYFLG (GETPROP TYP 'UNARYOP)) (LISPFN (GETPROP TYP 'LISPFN)) @@ -1494,7 +1637,10 @@ with the terms of said license. ENDTAIL-1) (AND (NEQ TYP (CAR TAIL)) UNARYFLG - (SETQ TAIL (CDR TAIL))) (* ;; "On calls from CLISPATOM1A, TYP is always CADR of TAIL. e.g. in X+Y 'Z, on the call to CLISPATOM2 to process ', TAIL would be (IPLUS X Y) ' Z.") + (SETQ TAIL (CDR TAIL))) + + (* ;; "On calls from CLISPATOM1A, TYP is always CADR of TAIL. e.g. in X+Y 'Z, on the call to CLISPATOM2 to process ', TAIL would be (IPLUS X Y) ' Z.") + [COND ((AND (SETQ TEM (GETP (CAR ENDTAIL) 'CLISPBRACKET)) @@ -1523,42 +1669,55 @@ with the terms of said license. (AND (EQ (CAR ENDTAIL) '~) (GETPROP (CADR ENDTAIL) - 'CLISPTYPE] (* ; "X+Y~=Z is OK.") + 'CLISPTYPE] (* ; "X+Y~=Z is OK.") ) - ((AND UNARYFLG (CLISPATOM2C TAIL)) (* ; "E.G. (~FOO 'X Y) is OK.") + ((AND UNARYFLG (CLISPATOM2C TAIL)) (* ; "E.G. (~FOO 'X Y) is OK.") ) - (T (* ; "E.G. (X + Y ' Z)") + (T (* ; "E.G. (X + Y ' Z)") (DWIMERRORRETURN (LIST 2 ENDTAIL PARENT] [(AND (NULL FORMSFLG) - (EQ PARENT TAIL)) (* ;; "An missing operand error is going to be generated if something isnt done in the next COND, e.g (X*Y Z)") + (EQ PARENT TAIL)) + + (* ;; "An missing operand error is going to be generated if something isnt done in the next COND, e.g (X*Y Z)") + (COND ((AND ENDTAIL DWIMIFYFLG (EQ CLISPCONTEXT 'IFWORD) (CLISPRESPELL ENDTAIL CLISPIFWORDSPLST)) - (* ; - "Found a correction; tell CLISPIF to try again.") + (* ; + "Found a correction; tell CLISPIF to try again.") (CL:THROW 'CLISPIF0 :RESPELL)) [(AND ENDTAIL (CLISPRESPELL ENDTAIL CLISPINFIXSPLST)) - (* ;; "E.g. (X + Y LSS Z). Note that we do not try to correct spelling on infixes unless the form is otherwise going to cause an eror, e.g. in (FOO X_Y ORR --), the ORR is not checked for here. Thus in the event that the next thing on ENDTAIL is a CLISP transformation, e.g. (FOO X_Y Z_W), we do not have to do any extra work. This algorithm contains the implicit assumption that all the operatrs on CLISPINFIXSPLST (i.e. the ones we correct for) will terminate the scope of all non-broadscope operators. Otherwise, if FOO is a non-broadscope operator, and FIE would not terminate FOO, and FIE is on CLISPINFIXSPLST, the form (LIST A FOO B FIEE C) would parse as (LIST (A FOO B) FIE C), which is wrong. In this case, not only would we have to backup to CLISPATOM1 using RETEVAL as in CLIPATOMB, we would also have to check for misspelled operaaors appearng in CAR of ENDTAIL even when an error would not otherwise be generated, e.g. in (LIST X_Y Z_W) we would have to check the spelling of Z_W. Note that when the current operator is broadscope, we always perform spelling correction (via the call to DWIIFY! in CLISPTOM2B) since once parentheses are inserted, we can't distinguish e.g. (X AND Y ORR Z) from (X AND (Y ORR Z)).") + + (* ;; "E.g. (X + Y LSS Z). Note that we do not try to correct spelling on infixes unless the form is otherwise going to cause an eror, e.g. in (FOO Xâ†Y ORR --), the ORR is not checked for here. Thus in the event that the next thing on ENDTAIL is a CLISP transformation, e.g. (FOO Xâ†Y Zâ†W), we do not have to do any extra work. This algorithm contains the implicit assumption that all the operatrs on CLISPINFIXSPLST (i.e. the ones we correct for) will terminate the scope of all non-broadscope operators. Otherwise, if FOO is a non-broadscope operator, and FIE would not terminate FOO, and FIE is on CLISPINFIXSPLST, the form (LIST A FOO B FIEE C) would parse as (LIST (A FOO B) FIE C), which is wrong. In this case, not only would we have to backup to CLISPATOM1 using RETEVAL as in CLIPATOMB, we would also have to check for misspelled operaaors appearng in CAR of ENDTAIL even when an error would not otherwise be generated, e.g. in (LIST Xâ†Y Zâ†W) we would have to check the spelling of Zâ†W. Note that when the current operator is broadscope, we always perform spelling correction (via the call to DWIIFY! in CLISPTOM2B) since once parentheses are inserted, we can't distinguish e.g. (X AND Y ORR Z) from (X AND (Y ORR Z)).") + (COND (DWIMIFYFLG (CL:THROW (COND ((LISTP CLISPCONTEXT) - (* ;; "We want to go back to the clispatom1 above this call to wtfix, e.g. consider X AND Y_T ORR Z. In this case, we are dwimifying (Y_T ORR Z) but we want to go back to higher level. Used to do this via (RETDWIM0 'CLISPATOM1 (RETDWIM0 'WTFIX)), but now we just tell WTFIX to throw again.") + + (* ;; "We want to go back to the clispatom1 above this call to wtfix, e.g. consider X AND Yâ†T ORR Z. In this case, we are dwimifying (Yâ†T ORR Z) but we want to go back to higher level. Used to do this via (RETDWIM0 'CLISPATOM1 (RETDWIM0 'WTFIX)), but now we just tell WTFIX to throw again.") + 'WTFIX) (T 'CLISPATOM1)) :RESPELL] ([CLISPATOM2C (COND (UNARYFLG TAIL) - (T (CDR TAIL] (* ; "E.G. FOO_GETP 'FIE 'EXPR") + (T (CDR TAIL] (* ; "E.G. FOOâ†GETP 'FIE 'EXPR") ) - (T (* ; "E.g. (LIST * X Y)") + (T (* ; "E.g. (LIST * X Y)") (DWIMERRORRETURN (LIST 2 ENDTAIL PARENT] ((CLISPATOM2C (COND (UNARYFLG TAIL) (T (CDR TAIL] (COND - ((EQ CLTYP 'BRACKET) (* ;; "Note that as currently implemented, ENDTAIL can be NIL. i.e. there is no check for whether or not matching > where actually found. This enables user to insert expressions like < where actually found. This enables user to insert expressions like <, the scope may include the entire IF statement, e.g. IF A THEN , the scope may include the entire IF statement, e.g. IF A THEN ((FOO X) AND Y)") + (CDR TAIL)) (* ; + "inserts parens in VAR1, e.g. (FOO X AND Y) -> ((FOO X) AND Y)") (SETQ BACKUPFLG T) (SETQ TAIL TEM))) (COND @@ -1661,10 +1830,13 @@ with the terms of said license. (CLISPBROADSCOPE1 TAIL PARENT BACKUPFLG] B (SETQ VAR1 (CAR TAIL)) (SELECTQ TYP - (%: (AND LISPFN (GO C)) (* ; - "means user has redefined : as a normal lisp operator") - (SETQ Z (CLISPCAR/CDR (SETQ TEM VAR2))) (* ;; "the value returned by CLISPCAR/CDR indicates whether there was more than one operator involved, and is used to set CLISPCHANGE below.") - (SETQ TEM (CLISPATOM2D NIL VAR1)) (* ; "Inserts new expressioninto TAIL.") + (%: (AND LISPFN (GO C)) (* ; + "means user has redefined : as a normal lisp operator") + (SETQ Z (CLISPCAR/CDR (SETQ TEM VAR2))) + + (* ;; "the value returned by CLISPCAR/CDR indicates whether there was more than one operator involved, and is used to set CLISPCHANGE below.") + + (SETQ TEM (CLISPATOM2D NIL VAR1)) (* ; "Inserts new expressioninto TAIL.") (COND (DWIMIFYFLG (AND CLISPCHANGE (GO OUT)) (SETQ CLISPCHANGE TEM)) @@ -1673,24 +1845,24 @@ with the terms of said license. (CLISPATOM2A (CDR VAR2) VAR2) (AND TENTATIVE Z (SETQQ TENTATIVE PROBABLY)) - (* ; - "Means there was more than one : operator.") + (* ; + "Means there was more than one : operator.") (GO OUT)) - (_ [COND + (↠[COND ((NLISTP VAR1) (SETQ TEM TYP)) - (T (* ; - "_ in connection with a : operator.") + (T (* ; + "↠in connection with a : operator.") [SETQ TEM (SELECTQ (CAR VAR1) (CAR 'RPLACA) (CDR 'RPLACD) ((NCONC NCONC1) (CAR VAR1)) - ((replace REPLACE) (* ; - "From record declaration assigmnent.") + ((replace REPLACE) (* ; + "From record declaration assigmnent.") (CLISPATOM2D NIL (CLISPRECORD VAR1 VAR2 T)) - (* ; - "Where the right hand operand to the _ will be DWIMIFIED, and TENTATIVE set, etc.") + (* ; + "Where the right hand operand to the ↠will be DWIMIFIED, and TENTATIVE set, etc.") (GO C1)) (COND ([OR (SETQ TEM (GETPROP (CAR VAR1) @@ -1698,13 +1870,17 @@ with the terms of said license. (PROGN (DWIMIFY1? VAR1) (SETQ TEM (GETPROP (CAR VAR1) 'SETFN] - (* ;; "E.G. User converts X \ FOO to (GETP X FOO), and puts PUT on SETFN of GETP, so that X \ FOO_T becomes (PUT X FOO T)") + + (* ;; "E.G. User converts X \ FOO to (GETP X FOO), and puts PUT on SETFN of GETP, so that X \ FOOâ†T becomes (PUT X FOO T)") + (CLISPATOM2D NIL (CONS (CLISPLOOKUP TEM (CADR VAR1)) (APPEND (CDR VAR1) VAR2))) - (* ;; "SETFN. Must be handled this way because VAR1 may correspond to more than one operand, e.g. X \ FOO_T -> (ELT X FOO) _T and must go to (SETA X FOO T)") + + (* ;; "SETFN. Must be handled this way because VAR1 may correspond to more than one operand, e.g. X \ FOOâ†T -> (ELT X FOO) â†T and must go to (SETA X FOO T)") + (GO C1)) - (T (DWIMERRORRETURN '_] + (T (DWIMERRORRETURN 'â†] (SETQ LISPFN (GETPROP TEM 'LISPFN)) (SETQ VAR1 (CADR VAR1] (SETQ LISPFN (CLISPLOOKUP TEM VAR1 NIL LISPFN)) @@ -1712,8 +1888,8 @@ with the terms of said license. ((AND (EQ LISPFN 'SETQ) (EQ (CAR VAR2) '%') - (NULL (CDDR VAR2))) (* ; - "Last AND clause to detect FOO _ ' FIE : 2 type of operations.") + (NULL (CDDR VAR2))) (* ; + "Last AND clause to detect FOO ↠' FIE : 2 type of operations.") (SETQQ LISPFN SETQQ) (SETQ VAR2 (CDR VAR2] (COND @@ -1727,8 +1903,8 @@ with the terms of said license. LISPFN)) (COND (UNARYFLG [SETQ VAR1 (COND - ((CDR VAR2) (* ; - "E.g. NOT is a unary operator which may take more than one expression, e.g. NOT A = B") + ((CDR VAR2) (* ; + "E.g. NOT is a unary operator which may take more than one expression, e.g. NOT A = B") VAR2) ((AND TYPE-IN? (EQ LISPFN 'QUOTE) (EQ (CAR VAR2) @@ -1740,8 +1916,8 @@ with the terms of said license. (GO INSERT))) [SETQ TEM (COND ((AND VAR2 (NULL (CDR VAR2))) - (CAR VAR2] (* ; - "TEM is the right-hand argument, if it is a single item.") + (CAR VAR2] (* ; + "TEM is the right-hand argument, if it is a single item.") (COND ((SELECTQ LISPFN (EQ (COND @@ -1751,8 +1927,8 @@ with the terms of said license. (IPLUS (COND ((AND (LISTP VAR1) (EQ (CAR VAR1) - 'IPLUS)) (* ; - "Leave asis, so X+Y+1 goes to (IPLUS X Y 1) instead of (ADD1 (IPLUS X Y))") + 'IPLUS)) (* ; + "Leave asis, so X+Y+1 goes to (IPLUS X Y 1) instead of (ADD1 (IPLUS X Y))") NIL) ((EQ TEM 1) (SETQQ LISPFN ADD1)) @@ -1778,25 +1954,40 @@ with the terms of said license. (COND ((AND PARENT (ATOM PARENT)) (CLISPATOM2A TAIL TAIL) - (GO OUT))) (* ;; "Corresponds to the case where the entire expression became an atom, e.g. X~=NIL gging to X, or --- 3 going to -3.0") - (SETQ Z (CDR PARENT)) (* ;; "Z is used to find the operands for DWIMIFYING. It is now set so that CAR of it coresponds VAR1 and CADR of it coresponds CAR of VAR2.") + (GO OUT))) + + (* ;; "Corresponds to the case where the entire expression became an atom, e.g. X~=NIL gging to X, or --- 3 going to -3.0") + + (SETQ Z (CDR PARENT)) + + (* ;; "Z is used to find the operands for DWIMIFYING. It is now set so that CAR of it coresponds VAR1 and CADR of it coresponds CAR of VAR2.") + (COND ((CLISPNOEVAL LISPFN) (AND DWIMIFYFLG (SETQ CLISPCHANGE TEM)) (GO NEG)) (DWIMIFYFLG (AND CLISPCHANGE (NULL UNARYFLG) - (GO C1)) (* ;; "If CLISPCHANGE is T and this is not a UNARY operation, the first operand has already been dwimified.") + (GO C1)) + + (* ;; "If CLISPCHANGE is T and this is not a UNARY operation, the first operand has already been dwimified.") + (SETQ CLISPCHANGE TEM)) ((NOT (ATOM (CAR Z))) (GO C1))) (AND (NEQ LISPFN 'SETQ) - (CLISPATOM2A Z PARENT)) (* ;; "Dwimifies VAR1, e.g. ((A+B) *C). If CLISPCHANGE is T, VAR1 has already been processed, e.g. A*B+C, becomes ((ITIMES A A) + C), and the A and B have already been checked by the first call to CLISPATOM2. VAR1 is also dwimified when running provided it is atomic. so that if it or VAR2 is unbound, an alternate correction will be tried, e.g. mistyping a variable named FOO-1 as FOOO-1.") + (CLISPATOM2A Z PARENT)) + + (* ;; "Dwimifies VAR1, e.g. ((A+B) *C). If CLISPCHANGE is T, VAR1 has already been processed, e.g. A*B+C, becomes ((ITIMES A A) + C), and the A and B have already been checked by the first call to CLISPATOM2. VAR1 is also dwimified when running provided it is atomic. so that if it or VAR2 is unbound, an alternate correction will be tried, e.g. mistyping a variable named FOO-1 as FOOO-1.") + C1 [COND (UNARYFLG (GO C2)) ((AND (LISTP VAR1) (EQ LISPFN (CAR VAR1)) (FMEMB LISPFN '(AND OR IPLUS ITIMES FPLUS FTIMES PLUS TIMES)) - (NEQ VAR1 (CAR CLISPLASTSUB))) (* ;; "Handles nospreads, e.g. A+B+C becomes (IPLUS A B C) Note that where necessary, VAR1 has already been dwimified. The CLISPLASTSUB check is to prevent parens from beig taken out when VAR1 is the result of an IS PHRASE since this is needed later.") + (NEQ VAR1 (CAR CLISPLASTSUB))) + + (* ;; "Handles nospreads, e.g. A+B+C becomes (IPLUS A B C) Note that where necessary, VAR1 has already been dwimified. The CLISPLASTSUB check is to prevent parens from beig taken out when VAR1 is the result of an IS PHRASE since this is needed later.") + (CLRPLNODE Z (CADR VAR1) (APPEND (CDDR VAR1) VAR2] @@ -1804,33 +1995,39 @@ with the terms of said license. (COND ((OR DWIMIFYFLG (LITATOM (CAR Z))) (CLISPATOM2A Z PARENT))) - C2 (* ; - "Z is now set so that it corresponds to the right hand argument of the oprator.") + C2 (* ; + "Z is now set so that it corresponds to the right hand argument of the oprator.") (COND ([AND Z (SETQ CLTYP (GETPROP (SETQ LISPFN (CAR Z)) - 'CLISPTYPE] (* ; - "The second operand is itself an operator, e.g. a+*b.") + 'CLISPTYPE] (* ; + "The second operand is itself an operator, e.g. a+*b.") (COND ([OR (NULL (CDR Z)) - (NULL (GETPROP LISPFN 'UNARYOP] (* ; - "The GETP check is because this is not an error if the operator is unary.") + (NULL (GETPROP LISPFN 'UNARYOP] (* ; + "The GETP check is because this is not an error if the operator is unary.") (DWIMERRORRETURN 2))) - (CLISPATOM1A LISPFN CLTYP Z ENDTAIL) (* ;; "If ENDTAIL is non-nil, the LDIFF copied this portion of TAIL, so it is not necessary to do any saving.") + (CLISPATOM1A LISPFN CLTYP Z ENDTAIL) + + (* ;; "If ENDTAIL is non-nil, the LDIFF copied this portion of TAIL, so it is not necessary to do any saving.") + ) ((NULL (CDR Z))) ((SETQ CLTYP (GETPROP (SETQ LISPFN (CADR Z)) 'CLISPTYPE)) (CLISPATOM1A LISPFN CLTYP Z ENDTAIL))) NEG [COND - (NEGFLG (* ; - "An operator was negated, e.g. X ~MEMB y") + (NEGFLG (* ; + "An operator was negated, e.g. X ~MEMB y") (CLRPLNODE PARENT 'NOT (LIST (CONS (CAR PARENT) (CDR PARENT] [COND ([AND (EQ (CAR PARENT) 'NOT) (LISTP (SETQ TEM (CADR PARENT))) - (NOT (EQUAL PARENT (SETQ TEM (NEGATE TEM] (* ;; "Special stuff for negation. Done fter everything to take care of both X~=Y, and ~ (EQ X Y) in the same way.") + (NOT (EQUAL PARENT (SETQ TEM (NEGATE TEM] + + (* ;; "Special stuff for negation. Done fter everything to take care of both X~=Y, and ~ (EQ X Y) in the same way.") + [COND ((EQ PARENT (CAR TAIL)) (CLRPLNODE TAIL TEM (CDR TAIL))) @@ -1841,26 +2038,27 @@ with the terms of said license. OUT (RETURN TAIL]) (CLISPNOEVAL - [LAMBDA (FN DEFAULT) (* lmm "29-Jul-86 00:00") - (* ;; - "returns true if FN doesn't evaluate its args. If not sure, return DEFAULT") + [LAMBDA (FN DEFAULT) (* lmm "29-Jul-86 00:00") + + (* ;; "returns true if FN doesn't evaluate its args. If not sure, return DEFAULT") + (PROG (TEM) [COND ((SETQ TEM (FASSOC FN DWIMEQUIVLST)) (SETQ FN (CDR TEM] (RETURN (AND (SELECTQ (ARGTYPE FN) - ((1 3) (* ; "NLAMBDA") + ((1 3) (* ; "NLAMBDA") T) - (NIL (* ; - "udf -- see what else we know about it") + (NIL (* ; + "udf -- see what else we know about it") (OR (FMEMB FN NLAMA) (FMEMB FN NLAML) (COND ((NOT (OR (GETPROP FN 'MACRO-FN) (GETLIS FN MACROPROPS))) DEFAULT) - [DWIMINMACROSFLG (* ; - "Macros are treated as LAMBDA forms unless INFO prop says otherwise") + [DWIMINMACROSFLG (* ; + "Macros are treated as LAMBDA forms unless INFO prop says otherwise") (RETURN (EQMEMB 'NOEVAL (GETPROP FN 'INFO] (T T)))) (OR (FMEMB FN NLAMA) @@ -1868,14 +2066,21 @@ with the terms of said license. (NOT (EQMEMB 'EVAL (GETPROP FN 'INFO]) (CLISPLOOKUP - [LAMBDA (WORD $VAR1 $VAR2 $LISPFN) (* lmm "20-May-84 19:08") - (* ;; "In most cases, it is not necessary to do a full lookup. This is quick an dirty check inside of the block to avoid calling CLISPLOOKUP0 It will work whenever there are no local declarations.") + [LAMBDA (WORD $VAR1 $VAR2 $LISPFN) (* lmm "20-May-84 19:08") + + (* ;; "In most cases, it is not necessary to do a full lookup. This is quick an dirty check inside of the block to avoid calling CLISPLOOKUP0 It will work whenever there are no local declarations.") + (PROG (TEM CLASS CLASSDEF) (SETQ CLASS (GETPROP WORD 'CLISPCLASS)) - (SETQ CLASSDEF (GETPROP CLASS 'CLISPCLASSDEF)) (* ;; "used to be getprop word, but this meant GT worked differently than gt. also this new way is consistent with clispifylooup. shuld it bb (OR (getprop word) (getprop class))?") + (SETQ CLASSDEF (GETPROP CLASS 'CLISPCLASSDEF)) + + (* ;; "used to be getprop word, but this meant GT worked differently than gt. also this new way is consistent with clispifylooup. shuld it bb (OR (getprop word) (getprop class))?") + [SETQ TEM (COND ((AND CLASSDEF (SETQ TEM (GETLOCALDEC EXPR FAULTFN))) - (* ;; "must do full lookup. Note that it is not necessary to do a call to CLISPLOOKUP0 if word has a CLASS, but no CLASSDEF, e.g. FGTP, FMEMB, etc., since if these are ued as infix operators, they mean the corresponding functin regardless of declaraton. I.e. The CLASSDEF property says that this is the name of an infix operator. The CLASS property is used as a back pointer to the name of the operator/class of which this word is a member.") + + (* ;; "must do full lookup. Note that it is not necessary to do a call to CLISPLOOKUP0 if word has a CLASS, but no CLASSDEF, e.g. FGTP, FMEMB, etc., since if these are ued as infix operators, they mean the corresponding functin regardless of declaraton. I.e. The CLASSDEF property says that this is the name of an infix operator. The CLASS property is used as a back pointer to the name of the operator/class of which this word is a member.") + (CLISPLOOKUP0 WORD $VAR1 $VAR2 TEM $LISPFN CLASS CLASSDEF)) (T (SELECTQ CLASS (VALUE (RETURN (GETATOMVAL WORD))) @@ -1901,22 +2106,26 @@ with the terms of said license. (RETURN TEM]) (CLISPATOM2A - [LAMBDA (TAIL PARENT) (* lmm "21-Jun-85 16:49") + [LAMBDA (TAIL PARENT) (* lmm "21-Jun-85 16:49") (AND TAIL (NULL BROADSCOPE) (PROG ((DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) (CLISPCONTEXT (AND DWIMIFYFLG CLISPCONTEXT)) - DWIMIFYCHANGE TEM) (* ;; "If BROADSCOPE is T, everything has already been dwimified. See comments in clispatm2 and clispatom2b1") - (* ;; "CLISPATOM2A sets up state variables itself rather than calling DWIMIFY1? or DWIMIFY2? because it wants to be able to add to NOFIXVARSLST0.") + DWIMIFYCHANGE TEM) + + (* ;; "If BROADSCOPE is T, everything has already been dwimified. See comments in clispatm2 and clispatom2b1") + + (* ;; "CLISPATOM2A sets up state variables itself rather than calling DWIMIFY1? or DWIMIFY2? because it wants to be able to add to NOFIXVARSLST0.") + (COND ((NULL DWIMIFYFLG) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST))) [SETQ TEM (COND - ((OR (AND (NEQ TYP '_) - (NEQ TYP '¬)) - (LISTP VAR1)) (* ; - "VAR1 is a list when the _ is a record expression.") + ((OR (AND (NEQ TYP 'â†) + (NEQ TYP '_)) + (LISTP VAR1)) (* ; + "VAR1 is a list when the ↠is a record expression.") 'DONTKNOW) ((OR (FMEMB VAR1 VARS) (FMEMB VAR1 NOFIXVARSLST0)) @@ -1925,8 +2134,8 @@ with the terms of said license. (AND (NULL DWIMIFYING) (STKSCAN VAR1 FAULTPOS)) (GETPROP VAR1 'GLOBALVAR) - (FMEMB VAR1 GLOBALVARS)) (* ; - "Added to NOFIXVARSLST0 so will be avilable for spelling correction in the future.") + (FMEMB VAR1 GLOBALVARS)) (* ; + "Added to NOFIXVARSLST0 so will be avilable for spelling correction in the future.") (SETQ NOFIXVARSLST0 (CONS VAR1 NOFIXVARSLST0)) 'PROBABLY) ([AND (NEQ CLISPCONTEXT 'FOR/BIND) @@ -1937,14 +2146,17 @@ with the terms of said license. (OR [AND VARS (SETQ TEM (FIXSPELL VAR1 NIL VARS NIL NIL NIL NIL NIL T 'MUSTAPPROVE] (SETQ TEM (FIXSPELL VAR1 NIL SPELLINGS3 NIL NIL NIL NIL NIL T - 'MUSTAPPROVE] (* ;; "FIXSPELL is called instead of CLISPRESPELL because we dont want runon corrections, and also we have performed msot of the checks of CLISPRESPELL.") + 'MUSTAPPROVE] + + (* ;; "FIXSPELL is called instead of CLISPRESPELL because we dont want runon corrections, and also we have performed msot of the checks of CLISPRESPELL.") + (CLRPLNODE (CDR PARENT) TEM (CDDR PARENT)) 'CERTAINLY) (T (SETQ NOFIXVARSLST0 (CONS VAR1 NOFIXVARSLST0)) - (* ; - "Added to NOFIXVARSLST0 so that it will be available for spelling correction in the future.") + (* ; + "Added to NOFIXVARSLST0 so that it will be available for spelling correction in the future.") 'DONTKNOW] (RETURN (COND [(LISTP (CAR TAIL)) @@ -1955,8 +2167,8 @@ with the terms of said license. ([AND TAIL (CAR TAIL) (LITATOM (CAR TAIL)) (NOT (GETPROP (CAR TAIL) - 'CLISPTYPE] (* ; - "We already know that the atom has no operators internal to it, having scanned through it earlier.") + 'CLISPTYPE] (* ; + "We already know that the atom has no operators internal to it, having scanned through it earlier.") (SETQ CLISPCONTEXT NIL) (COND ((AND (NULL (DWIMIFY2 TAIL PARENT T NIL T 'NORUNONS)) @@ -1965,7 +2177,7 @@ with the terms of said license. (SETQ TENTATIVE TEM]) (CLISPBROADSCOPE - [LAMBDA ($TYP L CONTEXT) (* lmm "29-Jul-86 00:26") + [LAMBDA ($TYP L CONTEXT) (* lmm "29-Jul-86 00:26") (PROG ((BRACKETCNT 0) (L0 L)) LP [COND @@ -2012,7 +2224,9 @@ with the terms of said license. ((EQ CONTEXT 'IS) 'IS) (T - (* ;; "Reason for the OR is to handle things like X IS A NUMBER AND NOT LT Y. In this case would be dwimifying (NOT LT Y) but when go to dwimify (NOT) want CLISPATOMIS? to be able to se the higher context.") + + (* ;; "Reason for the OR is to handle things like X IS A NUMBER AND NOT LT Y. In this case would be dwimifying (NOT LT Y) but when go to dwimify (NOT) want CLISPATOMIS? to be able to se the higher context.") + (OR (AND DWIMIFYFLG (LISTP CLISPCONTEXT )) @@ -2026,15 +2240,19 @@ with the terms of said license. (CAR X) (CAR X) NIL NIL NIL CONTEXT)) - (T (* ;; "FLG says that the parens were inserted here, so that CONTEXT should be passed on to DWIMIFY1 in case there is a spelling error, e.g. (TAIL AND Y ORR Z) gets handled differently than (TAIL AND Y OR Z)") + (T + (* ;; "FLG says that the parens were inserted here, so that CONTEXT should be passed on to DWIMIFY1 in case there is a spelling error, e.g. (TAIL AND Y ORR Z) gets handled differently than (TAIL AND Y OR Z)") + (DWIMIFY1? (CAR X) (AND FLG CONTEXT]) (CLISPATOM2C - [LAMBDA (TAIL0) (* lmm "20-May-84 19:55") - (* ;; "Checks for the case where user leaves out arentheses in front of functon name that follows an operator, e.g. (LIST X+ADD1 Y)") - (SETQ TAIL0 (CDR TAIL0)) (* ; - "TAIL0 is as of the right hand operand.") + [LAMBDA (TAIL0) (* lmm "20-May-84 19:55") + + (* ;; "Checks for the case where user leaves out arentheses in front of functon name that follows an operator, e.g. (LIST X+ADD1 Y)") + + (SETQ TAIL0 (CDR TAIL0)) (* ; + "TAIL0 is as of the right hand operand.") (COND ([AND (NEQ TYP '%') (NEQ TYP '%:) @@ -2047,7 +2265,7 @@ with the terms of said license. [COND ((EQ (CDR Y) (CDAR Y)) - (* ; "Unary operator") + (* ; "Unary operator") (CAAR Y)) (T (CONCAT (RETDWIM2 (CAAR Y)) (COND @@ -2061,7 +2279,7 @@ with the terms of said license. (CONCAT [COND ((EQ (CDR Y) (CDAR Y)) - (* ; "Unary operator") + (* ; "Unary operator") (CAAR Y)) (T (CONCAT (RETDWIM2 (CAAR Y)) (COND @@ -2076,34 +2294,52 @@ with the terms of said license. (CDDR Y] (T (CONS X (CDDR Y] '")"] - (CONS TAIL TAIL0] (* ;; "The GETP check is for situations like (LIST X_'FOO Y) i.e. a unary operator could never take care of the rest of the list.") + (CONS TAIL TAIL0] + + (* ;; "The GETP check is for situations like (LIST Xâ†'FOO Y) i.e. a unary operator could never take care of the rest of the list.") + (/RPLNODE TAIL0 (CONS (CAR TAIL0) (CDR TAIL0))) - (SETQ ENDTAIL NIL) (* ; - "Once you print a message, you dont want to go and try another interpretation.") + (SETQ ENDTAIL NIL) (* ; + "Once you print a message, you dont want to go and try another interpretation.") (SETQQ TENTATIVE CERTAINLY]) (CLISPATOM2D - [LAMBDA (X Y) (* ;; "Inserts new expression into TAIL. Value is T if expression was not parenthesized, PARTIAL if it was, i.e. if it corresponded to the new CAR of TAIL. If X is NIL, Y is the whole expression.") + [LAMBDA (X Y) + + (* ;; "Inserts new expression into TAIL. Value is T if expression was not parenthesized, PARTIAL if it was, i.e. if it corresponded to the new CAR of TAIL. If X is NIL, Y is the whole expression.") + (COND ((AND (NULL ENDTAIL) (NULL FORMSFLG) (OR (NULL PARENT) - (EQ PARENT TAIL))) (* ;; "This is the case in which we do not want to 'subordinate' the expression with an extra pair of parentheses. E.g. (LIST (A+B)). The ENDTAIL check is necessary because if it is not NIL, there are more expressions following the first one, e.g. (LIST (A*B+C)) and we must keep this expression separate, i.e. make (A*B+C) become ((ITIMES A A) + C)") + (EQ PARENT TAIL))) + + (* ;; "This is the case in which we do not want to 'subordinate' the expression with an extra pair of parentheses. E.g. (LIST (A+B)). The ENDTAIL check is necessary because if it is not NIL, there are more expressions following the first one, e.g. (LIST (A*B+C)) and we must keep this expression separate, i.e. make (A*B+C) become ((ITIMES A A) + C)") + (COND - ((NULL X) (* ;; "Y is the entire expression to be inserted, but we can't use it because we have to 'take out' the parentheses.") + ((NULL X) + + (* ;; "Y is the entire expression to be inserted, but we can't use it because we have to 'take out' the parentheses.") + (CLRPLNODE TAIL (CAR Y) (CDR Y)) (AND (SETQ X (GETHASH Y CLISPARRAY)) - (CLISPTRAN TAIL X)) (* ;; "Must move translation to new expression. This only occurs if the expression is enclosed in prentheses, e.g. (X: (--))") + (CLISPTRAN TAIL X)) + + (* ;; "Must move translation to new expression. This only occurs if the expression is enclosed in prentheses, e.g. (X: (--))") + (AND (EQ Y (CAR CLISPLASTSUB)) - (FRPLACA CLISPLASTSUB TAIL)) (* ;; "Y is the expression returned by CLISPATOMIS but it is not going to apear in the new expression, so must change clisplastsub to correspnd") + (FRPLACA CLISPLASTSUB TAIL)) + + (* ;; "Y is the expression returned by CLISPATOMIS but it is not going to apear in the new expression, so must change clisplastsub to correspnd") + ) (T (CLRPLNODE TAIL X Y))) (SETQ PARENT TAIL) T) - (T (* ; - "Here we must parenthesize the expression so as to subordinate it.") + (T (* ; + "Here we must parenthesize the expression so as to subordinate it.") [SETQ Y (COND ((NULL X) Y) @@ -2111,24 +2347,26 @@ with the terms of said license. (NUMBERP (CAR Y))) (MINUS (CAR Y))) (T (CONS X Y] - (CLRPLNODE TAIL Y ENDTAIL) (* ; - "ENDTAIL being all the stuff not belonging to the CLISP expression, i.e. beyond its scope.") + (CLRPLNODE TAIL Y ENDTAIL) (* ; + "ENDTAIL being all the stuff not belonging to the CLISP expression, i.e. beyond its scope.") (SETQ PARENT (CAR TAIL)) 'PARTIAL]) (CLISPCAR/CDR - [LAMBDA (LST) (* lmm "21-Jun-85 16:50") - (* ;; "Handles the : infix operatr.") + [LAMBDA (LST) (* lmm "21-Jun-85 16:50") + + (* ;; "Handles the : infix operatr.") + (PROG ([SETQFLG (OR (EQ (CAR ENDTAIL) - '_) + 'â†) (EQ (CAR ENDTAIL) - '¬] + '_] TAILFLG N TEM VAL) (SETQ VAR2 NIL) LP (SETQ TAILFLG NIL) [COND ((EQ (CAR LST) - '%:) (* ; "Tail") + '%:) (* ; "Tail") (SETQ TAILFLG T) (SETQ LST (CDR LST] (COND @@ -2136,7 +2374,7 @@ with the terms of said license. (SETQ VAR1 (LIST (COND ((NULL SETQFLG) (GO ERROR)) - (TAILFLG (* ; "X::_") + (TAILFLG (* ; "X::â†") 'NCONC) (T 'NCONC1)) VAR1)) @@ -2181,12 +2419,12 @@ with the terms of said license. (GO NEG))) LP1 [COND ((AND (IGREATERP N 4) - (ILESSP N 9)) (* ; - "X:N for N greater than 8 goes to (NTH X N)") + (ILESSP N 9)) (* ; + "X:N for N greater than 8 goes to (NTH X N)") (SETQ N (IPLUS N -4)) (SETQ VAR1 (LIST 'CDDDDR VAR1)) (AND (NULL VAR2) - (SETQ VAR2 VAR1)) (* ; "VAR2 marks the TAIL where the original operand appears, so thaadwimifying will continue from there.") + (SETQ VAR2 VAR1)) (* ; "VAR2 marks the TAIL where the original operand appears, so thaadwimifying will continue from there.") (GO LP1)) ((AND SETQFLG (NULL (CDR LST))) (SETQ VAR1 (CLISPCAR/CDR1 1 (CLISPCAR/CDR1 (SUB1 N) @@ -2226,15 +2464,17 @@ with the terms of said license. (GO LP2]) (CLISPCAR/CDR1 - [LAMBDA (N X TAILFLG SETQFLG) (* lmm "20-May-84 19:56") - (* ;; "All three level car and cdr operations go back to the corresponding function, i.e. CDAAR clispifies to X:1:1::1 and goes back to CDAAR.") + [LAMBDA (N X TAILFLG SETQFLG) (* lmm "20-May-84 19:56") + + (* ;; "All three level car and cdr operations go back to the corresponding function, i.e. CDAAR clispifies to X:1:1::1 and goes back to CDAAR.") + (PROG (TEM) (COND ((ZEROP N) (RETURN X)) ((AND (NULL DWIMIFYFLG) - CHECKCARATOMFLG) (* ; - "If CHECKCARATOMFLG is T, then checks to see if the car/cdr chain goes through an atom (non-list)") + CHECKCARATOMFLG) (* ; + "If CHECKCARATOMFLG is T, then checks to see if the car/cdr chain goes through an atom (non-list)") (CLISPCAR/CDR2 N X))) [SETQ TEM (COND ([AND (NULL SETQFLG) @@ -2242,11 +2482,17 @@ with the terms of said license. (SETQ TEM (COND ((EQ N 1) (SELECTQ (CAR X) - (CAR (* ;; "The apparent incompleteness of the SELECTQ is bcause CAR of CDR would appear in CLISS as 2 and be handled directly, similarly for CDR of CDR.") + (CAR + + (* ;; "The apparent incompleteness of the SELECTQ is bcause CAR of CDR would appear in CLISS as 2 and be handled directly, similarly for CDR of CDR.") + (COND (TAILFLG 'CDAR) (T 'CAAR))) - (CAAR (* ;; "Similarly, CAR of CDAR would come in as CADR of CAR, CDR of CDAR as CDDR of CAR, so checks for CDAR and CDDR are not necessary.") + (CAAR + + (* ;; "Similarly, CAR of CDAR would come in as CADR of CAR, CDR of CDAR as CDDR of CAR, so checks for CDAR and CDDR are not necessary.") + (COND (TAILFLG 'CDAAR) (T 'CAAAR))) @@ -2256,11 +2502,14 @@ with the terms of said license. NIL)) ((AND (EQ N 2) (EQ (CAR X) - 'CAR)) (* ;; "CADR of CDR would be written as X:3, similaly CAAR of CDR, CDAR of CDR, and CDDR of CDR are all taken care of.") + 'CAR)) + + (* ;; "CADR of CDR would be written as X:3, similaly CAAR of CDR, CDAR of CDR, and CDDR of CDR are all taken care of.") + (COND (TAILFLG 'CDDAR) - (T 'CADAR] (* ; - "If SETQFLG is T, want to leave the outer CAR or CDR because gets replaced by rplaca/d later.") + (T 'CADAR] (* ; + "If SETQFLG is T, want to leave the outer CAR or CDR because gets replaced by rplaca/d later.") (FRPLACA X TEM)) [(IGREATERP N 4) (SETQ TEM (CLISPLOOKUP 'NTH VAR1)) @@ -2284,7 +2533,7 @@ with the terms of said license. (RETURN TEM]) (CLISPCAR/CDR2 - [LAMBDA (N X) (* lmm "20-May-84 19:56") + [LAMBDA (N X) (* lmm "20-May-84 19:56") (PROG ((NODE (STKEVAL FAULTPOS X))) LP [COND ((ZEROP N) @@ -2296,13 +2545,18 @@ with the terms of said license. (GO LP]) (CLISPATOMIS1 - [LAMBDA (SUBJ OBJ ALST EXP NEGATE) (* lmm "20-May-84 20:03") - (* ;; "ALST is cdr of the value returned by clispmatchup. CAR is split into the two arguments SUBJ and OBJ.") + [LAMBDA (SUBJ OBJ ALST EXP NEGATE) (* lmm "20-May-84 20:03") + + (* ;; "ALST is cdr of the value returned by clispmatchup. CAR is split into the two arguments SUBJ and OBJ.") + (SELECTQ (CAR SUBJ) ((AND OR) [CONS (CAR SUBJ) (MAPCAR (CDR SUBJ) - (FUNCTION (LAMBDA (X) (* ;; "The AND is bcause it is ok for NEGFLG to be T instead of LISTONLY on recursive calls, because (NOT (NULL X)) can go to X in this case since we have the tail to put it in.") + (FUNCTION (LAMBDA (X) + + (* ;; "The AND is bcause it is ok for NEGFLG to be T instead of LISTONLY on recursive calls, because (NOT (NULL X)) can go to X in this case since we have the tail to put it in.") + (CLISPATOMIS1 X OBJ ALST EXP (AND NEGATE T]) (PROGN (SETQ EXP (SUBLIS (CONS (CONS OBJ SUBJ) ALST) @@ -2312,9 +2566,10 @@ with the terms of said license. (T EXP]) (CLISPATOMARE1 - [LAMBDA (X FLG) (* lmm "29-Jul-86 00:27") - (* ;; - "value is an edit pushdown list (of tails) leding to the place of the last is subject.") + [LAMBDA (X FLG) (* lmm "29-Jul-86 00:27") + + (* ;; "value is an edit pushdown list (of tails) leding to the place of the last is subject.") + (PROG (L TEM) (SETQ L (CDR X)) LP (COND @@ -2333,21 +2588,24 @@ with the terms of said license. (RETURN NIL]) (CLISPATOMARE2 - [LAMBDA (L Z) (* lmm " 4-SEP-83 23:07") + [LAMBDA (L Z) (* lmm " 4-SEP-83 23:07") (PROG (X X1) [COND ((NULL (CDR L)) (COND (Z (RETURN (CAR Z))) - (T (* ; - "E.g. X AND Y IS A NUMBER ARE ATOMS.") + (T (* ; + "E.g. X AND Y IS A NUMBER ARE ATOMS.") (DWIMERRORRETURN (LIST 'PHRASE (CDR TAIL) PARENT] - (SETQ X (CAADR L)) (* ; "the parent of (CAR L)") + (SETQ X (CAADR L)) (* ; "the parent of (CAR L)") (SETQ X1 (CDAR L)) [COND ((AND DEST (EQ (CAR L) - (CDR X))) (* ;; "move inner expression out. case 1: (A OR B ARE NUMBERS AND C OR D ARE LISTS) VAR1 is (OR (AND (OR (NUMBERP A) (NUMBERP B)) C) D) but the AND is reaaly the top leveloperator. case 2: (A OR B IS A NUMBER AND C OR D ARE LISTS) VAR1 is (OR A (AND (NUMBERP B) C) D) here the OR should be the top leveloperator. The difference is that") + (CDR X))) + + (* ;; "move inner expression out. case 1: (A OR B ARE NUMBERS AND C OR D ARE LISTS) VAR1 is (OR (AND (OR (NUMBERP A) (NUMBERP B)) C) D) but the AND is reaaly the top leveloperator. case 2: (A OR B IS A NUMBER AND C OR D ARE LISTS) VAR1 is (OR A (AND (NUMBERP B) C) D) here the OR should be the top leveloperator. The difference is that") + (FRPLACA (CADR L) (CADR X))) (T (FRPLACD (CAR L] @@ -2363,8 +2621,10 @@ with the terms of said license. (T X1]) (CLISPATOMIS2 - [LAMBDA (X) (* ; "wt: 25-FEB-76 1 51") - (* ;; "Used by clispatomaRE and clispatomIis? to eliminate unnecessary nesting of ands and ors after finishing processing. (Too hard to do on the fly as we built pushdown list of tails etc.) NOte that we cant remove parens from around clisplastsub since it might be needed later in parsing. Thus X AND Y ARE NUMBERS AND GREATER THAN 3 must be left as (AND (NUMBERP X) (NUMBER Y) (AND (IGREATERP X 3) (IGREATERP Y 3)))") + [LAMBDA (X) (* ; "wt: 25-FEB-76 1 51") + + (* ;; "Used by clispatomaRE and clispatomIis? to eliminate unnecessary nesting of ands and ors after finishing processing. (Too hard to do on the fly as we built pushdown list of tails etc.) NOte that we cant remove parens from around clisplastsub since it might be needed later in parsing. Thus X AND Y ARE NUMBERS AND GREATER THAN 3 must be left as (AND (NUMBERP X) (NUMBER Y) (AND (IGREATERP X 3) (IGREATERP Y 3)))") + (PROG (($TYP (CAR X))) LP [AND (LISTP (CAR X)) (NEQ (CAR X) @@ -2388,299 +2648,335 @@ with the terms of said license. (DEFINEQ (WTFIX - [LAMBDA (FAULTX FAULTARGS FAULTAPPLYFLG) (* lmm "15-Apr-86 09:59") + [LAMBDA (FAULTX FAULTARGS FAULTAPPLYFLG) (* lmm "15-Apr-86 09:59") (PROG (FAULTPOS FAULTFN EXPR VARS TAIL PARENT SUBPARENT FORMSFLG ONLYSPELLFLG DWIMIFYFLG TEM) (RETURN (WTFIX1]) (WTFIX0 - [LAMBDA (FAULTX TAIL PARENT SUBPARENT ONLYSPELLFLG) (* ;; "Internal entry from dwimify1 and dwimify2. EXPR, FAULTFN, VARS, TAIL, and FORMSFLG already correctly bound.") + [LAMBDA (FAULTX TAIL PARENT SUBPARENT ONLYSPELLFLG) + + (* ;; "Internal entry from dwimify1 and dwimify2. EXPR, FAULTFN, VARS, TAIL, and FORMSFLG already correctly bound.") + (PROG (FAULTARGS FAULTAPPLYFLG (FAULTPOS (COND ((NULL (AND DWIMIFYFLG DWIMIFYING)) - (* ; - "Originally started out evaluting, so there is a higher faultpos.") + (* ; + "Originally started out evaluting, so there is a higher faultpos.") FAULTPOS))) (DWIMIFYFLG T)) (RETURN (WTFIX1]) (WTFIX1 - [LAMBDA NIL (* bvm%: "21-Nov-86 18:37") - (* ;; "Replaces FAULT1 when DWIM is on. on u.b.a.'s FAULTX is the atom. On u.d.f.'s involving forms, FAULTX is the form. On u.d.f.'s from APPLY, faultx is the name of the function, FAULTARGS the arguments, and FAULTAPPLYFLG is T. Also is called directly to process a form from DWIMIFY. In this case, EXPR, VARS, ..., NOSPELLFLG0 are supplied, and FINDFN is not called.") + [LAMBDA NIL (* bvm%: "21-Nov-86 18:37") + + (* ;; "Replaces FAULT1 when DWIM is on. on u.b.a.'s FAULTX is the atom. On u.d.f.'s involving forms, FAULTX is the form. On u.d.f.'s from APPLY, faultx is the name of the function, FAULTARGS the arguments, and FAULTAPPLYFLG is T. Also is called directly to process a form from DWIMIFY. In this case, EXPR, VARS, ..., NOSPELLFLG0 are supplied, and FINDFN is not called.") + (AND DWIMFLG (LET [(RESULT - (CL:CATCH - 'WTFIX - (XNLSETQ - (PROG ((NOSPELLFLG0 NOSPELLFLG) - (CLISPERTYPE) - (DWIM.GIVE.UP.TIME (OR DWIM.GIVE.UP.TIME (SETUPTIMER DWIM.GIVE.UP.INTERVAL))) - TYPE-IN? BREAKFLG FAULTXX CHARLST FAULTEM1 NEWTAIL HISTENTRY FIXCLK CLISPCHANGES - SIDES) (* ; "LIST because this used to be a XNLSETQ. I think callers only want to know whether we returned something interesting, or somebody called (RETDWIM)") - [COND - (DWIMIFYFLG (* ;; "Call from WTFIX0. Note that while this call from DWIMIFY1 or DWIMIFY2, the user may or may not have been DWIMIFYING, e.g. when IF's are encountered in evaluation, DWIMIFY1 and DWIMIFY2 are used. The variable DWIMIFYING is T if the call to DWIMIFY! or DWIMIFY2 is from an explicit call to DWIMIFY (or DWIMIFYFNS)") - (SETQ TYPE-IN? (EQ FAULTFN 'TYPE-IN)) - (* ;; "DWIMIFY is called on typein for processing FOR's and IF's. In this case, want to treat user approval the same as for type-in.") - ) - (T (SETQ FIXCLK (CLOCK 2)) (* ;; "If EXPR is given, i.e. if DWIMIFYFLG is gong to be T, the clkock is being measured at some higher caal to WTFIX or DWIMIIY.") - [SETQ FAULTPOS (STKPOS (COND - (FAULTAPPLYFLG 'FAULTAPPLY) - (T 'FAULTEVAL] - (AND (NEQ CLEARSTKLST T) - (SETQ CLEARSTKLST (CONS FAULTPOS CLEARSTKLST))) - (* ; - "In case user control-ds out of correction, this will relstk faultpos") - (SETQ FAULTFN (FINDFN (FSTKNTH -1 FAULTPOS) - T)) (* ;; "The value of FINDFN is the name of the (interpreted) function in which the error occurred. FINDFN also sets the free variable EXPR to the definition of that function. If the error occurred under a call to EVAL, the value of FINDFN is EVAL, and EXPR is set to the expression being evaluated, i.e. the argument to EVAL. If the error occurred under an APPLY, the value of FINDFN is the first argument to APPLY, and EXPR is set to the second argument to APPLY, i.e. the list of arguments. In this case, FAULTX will usually be EQ to the value returned by FINDFN, and FAULTARGS EQ to EXPR. However, WTFIX may also be called from FAULTAPPLY, and FINDFN not find an APPLY, as occurs on undefined functions called from compiled code. For this reason, FIXAPPLY always uses FAULTX and FAULTARGS, not FAULTFN and EXPR.") - (SETQ VARS (AND (SETQ FAULTEM1 (OR BREAKFLG (LISTP EXPR))) - (GETVARS FAULTEM1] - [AND (NULL TYPE-IN?) - (SETQ SIDES (CDR (LISTGET1 LISPXHIST 'SIDE] - (AND TYPE-IN? (NULL DWIMIFYFLG) - [COND - (FAULTAPPLYFLG (EQ FAULTX (CAAAAR LISPXHISTORY))) - (T (OR (EQ FAULTX (CAAAAR LISPXHISTORY)) - (EQUAL FAULTX (CAAAR LISPXHISTORY] - (SETQ HISTENTRY (CAAR LISPXHISTORY))) - [COND - ([LITATOM (SETQ FAULTXX (COND - (FAULTAPPLYFLG FAULTX) - ((NLISTP FAULTX) - FAULTX) - (T (CAR FAULTX] - (SETQ CHARLST (DUNPACK FAULTXX WTFIXCHCONLST] - (COND - ((AND (NULL FAULTAPPLYFLG) - (LITATOM FAULTX)) - (FIXATOM) - (SHOULDNT)) - (FAULTAPPLYFLG (FIXAPPLY) - (SHOULDNT)) - ([AND TYPE-IN? (EQ FAULTXX (CAAR HISTENTRY)) - (AND (NEQ NOSPELLFLG T) - (AND (SETQ FAULTEM1 (FMEMB LPARKEY CHARLST)) - (NULL (AND CLISPFLG (STRPOSL CLISPCHARRAY FAULTXX] - (* ;; "LPARKEY is the lowercase version of left prentheses, normally 8, rparkey is normally 9, but user can reset them for different terminals. The EQ distinguishes between (CONS8ADD1 3) which is handled by a call to FIX89 from CLISPATOM, and FOO8A B C ']' , which is handled by FIX89TYPEIN, since it requires changing an EVAL to an APPLY.") - (FIX89TYPEIN FAULTEM1 CHARLST)) - ((AND CLISPFLG CHARLST (LITATOM (SETQ FAULTEM1 (CADR FAULTX))) - (OR (GETPROP FAULTEM1 'CLISPTYPE) - (FMEMB (SETQ FAULTEM1 (NTHCHAR FAULTEM1 1)) - CLISPCHARS)) - [OR (NOT (GETPROP FAULTEM1 'UNARYOP)) - (AND (EQ FAULTEM1 '~) - (GETPROP (PACK (CDR (DUNPACK (CADR FAULTX) - WTFIXCHCONLST1))) - 'CLISPTYPE] - (NOT (CLISPNOTVARP (CAR FAULTX))) - (CLISPNOTVARP (CADR FAULTX))) (* ; - "So that things like (SUM + X) will work, i.e. not be interpreted as iterative statement.") - (GO NX0)) - ((NULL CHARLST) - (GO NX2))) (* ; - "Both FIXAPPLY and FIXATOM exit via RETDWIM so there is no need for a return here in WTFIX.") - TOP [SELECTQ (CAR FAULTX) - (F/L [/RPLNODE - FAULTX - 'FUNCTION - (LIST (CONS 'LAMBDA - (COND - ([AND (CDDR FAULTX) - [OR (NULL (CADR FAULTX)) - (AND (LISTP (CADR FAULTX)) - (EVERY (CADR FAULTX) - (FUNCTION (LAMBDA (X) - (AND X (NEQ X T) - (LITATOM X] - (OR (MEMB (CAADR FAULTX) - (FREEVARS (CDDR FAULTX))) - (NOT (CLISPFUNCTION? (CADR FAULTX) - 'OKVAR] - (CDR FAULTX)) - (T (CONS (LIST 'X) - (CDR FAULTX] - (GO OUT)) - (CLISP%: (ERSETQ (CLISPDEC0 FAULTX FAULTFN)) - (SETQ FAULTX T)) - (COND - [[CAR (LISTP (SETQ FAULTEM1 (GETPROP (CAR FAULTX) - 'CLISPWORD] - (RESETVARS [(LCASEFLG (AND LCASEFLG (NULL TYPE-IN?] - (SELECTQ (CAR FAULTEM1) - (FORWORD (SETQ FAULTX (OR (CLISPFOR FAULTX) - (RETDWIM)))) - (IFWORD (SETQ FAULTX (CLISPIF FAULTX)) - (SETQ HISTENTRY NIL)) - (MATCHWORD (* ; - "CAR of FAULTX either MATCH or match.") - (CLISPTRAN FAULTX (MAKEMATCH FAULTX))) - (PREFIXFN (PROG ((EXPR FAULTX)) - (SETQ FAULTEM1 (CDR FAULTX)) - [COND - ((EQ (CAR (LISTP (CAR FAULTEM1))) - 'CLISP%:) - (ERSETQ (CLISPDEC0 (CAR FAULTEM1) - FAULTFN] - [COND - ((EQ (CAR (LISTP (CAR FAULTEM1))) - COMMENTFLG) - (SETQ FAULTEM1 (CDR FAULTEM1] - [SETQ FAULTEM1 - (APPEND (COND - [(AND (NULL (CDR FAULTEM1)) - (LISTP (CAR FAULTEM1] - (T FAULTEM1] - (RESETVARS ((CLISPFLG T)) - (DWIMIFY1? FAULTEM1)) - (CLISPELL FAULTX) - (CLISPTRAN FAULTX FAULTEM1))) - (SETQ FAULTX (APPLY* (CAR FAULTEM1) - FAULTX] - (T (GO NX0] - (AND DWIMIFYFLG (SETQ CLISPCHANGE T)) - (GO OUT) - NX0 (COND - [(GETD (CAR FAULTX)) - (COND - ([NULL (PROG (TYPE-IN? (FAULTFN (CAR FAULTX))) - (RETURN (COND - ((FIXLAMBDA (GETD (CAR FAULTX))) - (* ; - "This is the case where (FOO --) is being evaluated, and the definition of FOO is bad.") - (AND FILEPKGFLG (LITATOM FAULTFN) - (MARKASCHANGED FAULTFN 'FNS)) - T] - (SETQ NOSPELLFLG0 T) - (GO NX3) (* ; "So DWIMUSERFN can be called.") - ] - ((AND (OR (GETPROP (CAR FAULTX) - 'EXPR) - (GETPROP (CAR FAULTX) - 'CODE)) - (DWIMUNSAVEDEF (CAR FAULTX))) - (SETQ FAULTFN NIL) (* ; - "So that RETDWIM won't do a MARKASCHANGED") - ) - ((SETQ FAULTEM1 (GETPROP (CAR FAULTX) - 'FILEDEF)) - (COND - ((WTFIXLOADEF FAULTEM1) - (GO OUT))) - (RETDWIM)) - (T (GO NX1))) - (GO OUT) - NX1 (COND - ((AND (CLISPNOTVARP (CAR FAULTX)) - (SETQ FAULTEM1 (CLISPATOM CHARLST FAULTX FAULTX))) - (* ; "E.g. (FOO_ATOM) OR (FOO_ form)") - (SETQ FAULTX FAULTEM1) - (GO OUT))) - NX2 (COND - ([AND CLISPFLG (SETQ FAULTEM1 (CADR FAULTX)) - (OR (LITATOM FAULTEM1) - (AND (NUMBERP FAULTEM1) - (MINUSP FAULTEM1) - (CLBINARYMINUS? FAULTX))) - (OR (GETPROP FAULTEM1 'CLISPTYPE) - (FMEMB (CAR (SETQ FAULTEM1 (DUNPACK FAULTEM1 WTFIXCHCONLST1))) - CLISPCHARS)) - (SETQ FAULTEM1 (CLISPATOM FAULTEM1 (CDR FAULTX) - FAULTX T)) - (COND - [(OR (NEQ FAULTXX (CAR FAULTX)) - (AND CLISPARRAY (GETHASH FAULTX CLISPARRAY] - (DWIMIFYFLG (SETQ CHARLST (DUNPACK FAULTXX WTFIXCHCONLST)) - (* ; "LST may have been clobbered") - (SETQ CLISPCHANGE NIL] (* ;; "E.g. (FOO _atom) or (FOO _ form). The NEQ check is necessary to handle situations like (FOOO N-1) where an CLISP transformation is performed, but it does not correct CAR of the form. (In this case, we must continue to the spelling correction part below, and set CLISPCHANGE to NIL so that DWIMIFY1 will not be confused.) Note that if FOO also happens to be the name of a function, then WTFIX will not be called and the CLISP transformation not be performed until the arguments of FOO are evaluated and cause a u.b.a. error. Then DWIM will have to back up as described in FIXATOM and FIXATOM1.") - (SETQ FAULTX FAULTEM1) - (GO OUT)) - ((AND (NULL NOSPELLFLG0) - DWIMIFYFLG - (LISTP (CADR FAULTX)) - (FIXLAMBDA FAULTX)) (* ;; "The DWIMIFYFLG check is because in normal course of events, it never makes sense for LAMBDA to appear as CAR of a FORM. However, DWIMIFY1 is called on open LAMBDA expressions.") - (GO OUT)) - ((AND (NULL NOSPELLFLG0) - (LISTP (CAR FAULTX)) - (LISTP (CADAR FAULTX)) - (FIXLAMBDA (CAR FAULTX))) (* ;; "This corresponds to the case where LAMBDA is misspelled in an open LAMBDA expression. Note that an open lambda expression only makes sense when there is a non-atomic argument list, so dont both spelling correcting if this is notthe case.") - (GO OUT))) - NX3 (COND - [[SOME DWIMUSERFORMS (FUNCTION (LAMBDA (DWIMUSERFORM) - (SETQ FAULTEM1 (EVAL DWIMUSERFORM] - (COND - (FAULTAPPLYFLG (RETDWIM FAULTPOS FAULTEM1 T FAULTARGS)) - (T (RETDWIM FAULTPOS FAULTEM1] - (NOSPELLFLG0 (GO FAIL)) - [[AND CHARLST (SETQ FAULTXX - (OR (FIXSPELL (CAR FAULTX) - NIL SPELLINGS2 NIL FAULTX NIL NIL NIL T) - (AND DWIMIFYFLG NOFIXFNSLST0 - (FIXSPELL (CAR FAULTX) - NIL NOFIXFNSLST0 NIL FAULTX NIL NIL NIL T] - (* ; - "The extra argument to FIXSPELL indicates that SPLITS re tolerated, e.g. (BREAKFOO)") - (COND - ((EQ (CAAR HISTENTRY) - (CAR FAULTX)) - (/RPLNODE HISTENTRY FAULTX (CDR HISTENTRY)) - (* ;; "Normally, RETDWIM patches the histroy entry to corresond to a list input, even if it was typed in as a line. In the special case of a pselling correction, we leave the entry as a line.") - )) - (SETQ HISTENTRY NIL) - (COND - ((NOT (FGETD FAULTXX)) (* ; - "E.g. USER misspells FOR, IF, F/L etc. These are all contained on SPELLINGS2.") - (GO TOP] - ((AND CLISPFLG DWIMIFYFLG (CDR FAULTX) - (LISTP CLISPCONTEXT) - (FIXSPELL (CAR FAULTX) - NIL CLISPISWORDSPLST NIL FAULTX NIL NIL NIL T) - (SETQ FAULTEM1 (CLISPATOM (DUNPACK (CAR FAULTX) - WTFIXCHCONLST) - TAIL PARENT)))(* ;; "E.g. X IS A NUMBER AND LESS THAN Y. CLISPATOM will call CLISPATOMIS? which will retfrom back past here or generate an error. NOte that if (CAR FAUULTX) had been spelled correctly, thiswold have happened in first call to CLISPATOM at NX1 earlir. However, we dont do the misspelled check until here because it is more likely user has misspelled the name of one of his functions.") - ) - ([AND CLISPFLG (NULL CLISPCHANGES) - (NULL CLISPERTYPE) - (SETQ FAULTEM1 (CADR FAULTX)) - (LITATOM FAULTEM1) - (SETQ FAULTEM1 (FIXSPELL FAULTEM1 NIL CLISPINFIXSPLST NIL - (OR (AND DWIMIFYFLG (LISTP CLISPCONTEXT)) - (CDR FAULTX)) - NIL NIL NIL T)) - (COND - ((AND DWIMIFYFLG (LISTP CLISPCONTEXT)) - (* ;; - "Return from the corresponding DWIMUNDOCATCH with a value telling CLISPATOM to try again.") - (CL:THROW 'CLISPATOM1 :RESPELL)) - (T (LET (CLISPERTYPE) - (SETQ FAULTEM1 (CLISPATOM FAULTEM1 (CDR FAULTX) - FAULTX T] - (SETQ FAULTX FAULTEM1)) - (T (GO FAIL))) - OUT (RETDWIM FAULTPOS FAULTX) - FAIL - (RETDWIM] + (CL:CATCH 'WTFIX + (XNLSETQ + (PROG ((NOSPELLFLG0 NOSPELLFLG) + (CLISPERTYPE) + (DWIM.GIVE.UP.TIME (OR DWIM.GIVE.UP.TIME (SETUPTIMER DWIM.GIVE.UP.INTERVAL))) + TYPE-IN? BREAKFLG FAULTXX CHARLST FAULTEM1 NEWTAIL HISTENTRY FIXCLK CLISPCHANGES + SIDES) (* ; "LIST because this used to be a XNLSETQ. I think callers only want to know whether we returned something interesting, or somebody called (RETDWIM)") + [COND + (DWIMIFYFLG + + (* ;; "Call from WTFIX0. Note that while this call from DWIMIFY1 or DWIMIFY2, the user may or may not have been DWIMIFYING, e.g. when IF's are encountered in evaluation, DWIMIFY1 and DWIMIFY2 are used. The variable DWIMIFYING is T if the call to DWIMIFY! or DWIMIFY2 is from an explicit call to DWIMIFY (or DWIMIFYFNS)") + + (SETQ TYPE-IN? (EQ FAULTFN 'TYPE-IN)) + + (* ;; "DWIMIFY is called on typein for processing FOR's and IF's. In this case, want to treat user approval the same as for type-in.") + + ) + (T (SETQ FIXCLK (CLOCK 2)) + + (* ;; "If EXPR is given, i.e. if DWIMIFYFLG is gong to be T, the clkock is being measured at some higher caal to WTFIX or DWIMIIY.") + + [SETQ FAULTPOS (STKPOS (COND + (FAULTAPPLYFLG 'FAULTAPPLY) + (T 'FAULTEVAL] + (AND (NEQ CLEARSTKLST T) + (SETQ CLEARSTKLST (CONS FAULTPOS CLEARSTKLST))) + (* ; + "In case user control-ds out of correction, this will relstk faultpos") + (SETQ FAULTFN (FINDFN (FSTKNTH -1 FAULTPOS) + T)) + + (* ;; "The value of FINDFN is the name of the (interpreted) function in which the error occurred. FINDFN also sets the free variable EXPR to the definition of that function. If the error occurred under a call to EVAL, the value of FINDFN is EVAL, and EXPR is set to the expression being evaluated, i.e. the argument to EVAL. If the error occurred under an APPLY, the value of FINDFN is the first argument to APPLY, and EXPR is set to the second argument to APPLY, i.e. the list of arguments. In this case, FAULTX will usually be EQ to the value returned by FINDFN, and FAULTARGS EQ to EXPR. However, WTFIX may also be called from FAULTAPPLY, and FINDFN not find an APPLY, as occurs on undefined functions called from compiled code. For this reason, FIXAPPLY always uses FAULTX and FAULTARGS, not FAULTFN and EXPR.") + + (SETQ VARS (AND (SETQ FAULTEM1 (OR BREAKFLG (LISTP EXPR))) + (GETVARS FAULTEM1] + [AND (NULL TYPE-IN?) + (SETQ SIDES (CDR (LISTGET1 LISPXHIST 'SIDE] + (AND TYPE-IN? (NULL DWIMIFYFLG) + [COND + (FAULTAPPLYFLG (EQ FAULTX (CAAAAR LISPXHISTORY))) + (T (OR (EQ FAULTX (CAAAAR LISPXHISTORY)) + (EQUAL FAULTX (CAAAR LISPXHISTORY] + (SETQ HISTENTRY (CAAR LISPXHISTORY))) + [COND + ([LITATOM (SETQ FAULTXX (COND + (FAULTAPPLYFLG FAULTX) + ((NLISTP FAULTX) + FAULTX) + (T (CAR FAULTX] + (SETQ CHARLST (DUNPACK FAULTXX WTFIXCHCONLST] + (COND + ((AND (NULL FAULTAPPLYFLG) + (LITATOM FAULTX)) + (FIXATOM) + (SHOULDNT)) + (FAULTAPPLYFLG (FIXAPPLY) + (SHOULDNT)) + ([AND TYPE-IN? (EQ FAULTXX (CAAR HISTENTRY)) + (AND (NEQ NOSPELLFLG T) + (AND (SETQ FAULTEM1 (FMEMB LPARKEY CHARLST)) + (NULL (AND CLISPFLG (STRPOSL CLISPCHARRAY FAULTXX] + + (* ;; "LPARKEY is the lowercase version of left prentheses, normally 8, rparkey is normally 9, but user can reset them for different terminals. The EQ distinguishes between (CONS8ADD1 3) which is handled by a call to FIX89 from CLISPATOM, and FOO8A B C ']' , which is handled by FIX89TYPEIN, since it requires changing an EVAL to an APPLY.") + + (FIX89TYPEIN FAULTEM1 CHARLST)) + ((AND CLISPFLG CHARLST (LITATOM (SETQ FAULTEM1 (CADR FAULTX))) + (OR (GETPROP FAULTEM1 'CLISPTYPE) + (FMEMB (SETQ FAULTEM1 (NTHCHAR FAULTEM1 1)) + CLISPCHARS)) + [OR (NOT (GETPROP FAULTEM1 'UNARYOP)) + (AND (EQ FAULTEM1 '~) + (GETPROP (PACK (CDR (DUNPACK (CADR FAULTX) + WTFIXCHCONLST1))) + 'CLISPTYPE] + (NOT (CLISPNOTVARP (CAR FAULTX))) + (CLISPNOTVARP (CADR FAULTX))) (* ; + "So that things like (SUM + X) will work, i.e. not be interpreted as iterative statement.") + (GO NX0)) + ((NULL CHARLST) + (GO NX2))) (* ; + "Both FIXAPPLY and FIXATOM exit via RETDWIM so there is no need for a return here in WTFIX.") + TOP [SELECTQ (CAR FAULTX) + (F/L [/RPLNODE + FAULTX + 'FUNCTION + (LIST (CONS 'LAMBDA + (COND + ([AND (CDDR FAULTX) + [OR (NULL (CADR FAULTX)) + (AND (LISTP (CADR FAULTX)) + (EVERY (CADR FAULTX) + (FUNCTION (LAMBDA (X) + (AND X (NEQ X T) + (LITATOM X] + (OR (MEMB (CAADR FAULTX) + (FREEVARS (CDDR FAULTX))) + (NOT (CLISPFUNCTION? (CADR FAULTX) + 'OKVAR] + (CDR FAULTX)) + (T (CONS (LIST 'X) + (CDR FAULTX] + (GO OUT)) + (CLISP%: (ERSETQ (CLISPDEC0 FAULTX FAULTFN)) + (SETQ FAULTX T)) + (COND + [[CAR (LISTP (SETQ FAULTEM1 (GETPROP (CAR FAULTX) + 'CLISPWORD] + (RESETVARS [(LCASEFLG (AND LCASEFLG (NULL TYPE-IN?] + (SELECTQ (CAR FAULTEM1) + (FORWORD (SETQ FAULTX (OR (CLISPFOR FAULTX) + (RETDWIM)))) + (IFWORD (SETQ FAULTX (CLISPIF FAULTX)) + (SETQ HISTENTRY NIL)) + (MATCHWORD (* ; + "CAR of FAULTX either MATCH or match.") + (CLISPTRAN FAULTX (MAKEMATCH FAULTX))) + (PREFIXFN (PROG ((EXPR FAULTX)) + (SETQ FAULTEM1 (CDR FAULTX)) + [COND + ((EQ (CAR (LISTP (CAR FAULTEM1))) + 'CLISP%:) + (ERSETQ (CLISPDEC0 (CAR FAULTEM1) + FAULTFN] + [COND + ((EQ (CAR (LISTP (CAR FAULTEM1))) + COMMENTFLG) + (SETQ FAULTEM1 (CDR FAULTEM1] + [SETQ FAULTEM1 + (APPEND (COND + [(AND (NULL (CDR FAULTEM1)) + (LISTP (CAR FAULTEM1] + (T FAULTEM1] + (RESETVARS ((CLISPFLG T)) + (DWIMIFY1? FAULTEM1)) + (CLISPELL FAULTX) + (CLISPTRAN FAULTX FAULTEM1))) + (SETQ FAULTX (APPLY* (CAR FAULTEM1) + FAULTX] + (T (GO NX0] + (AND DWIMIFYFLG (SETQ CLISPCHANGE T)) + (GO OUT) + NX0 (COND + [(GETD (CAR FAULTX)) + (COND + ([NULL (PROG (TYPE-IN? (FAULTFN (CAR FAULTX))) + (RETURN (COND + ((FIXLAMBDA (GETD (CAR FAULTX))) + (* ; + "This is the case where (FOO --) is being evaluated, and the definition of FOO is bad.") + (AND FILEPKGFLG (LITATOM FAULTFN) + (MARKASCHANGED FAULTFN 'FNS)) + T] + (SETQ NOSPELLFLG0 T) + (GO NX3) (* ; "So DWIMUSERFN can be called.") + ] + ((AND (OR (GETPROP (CAR FAULTX) + 'EXPR) + (GETPROP (CAR FAULTX) + 'CODE)) + (DWIMUNSAVEDEF (CAR FAULTX))) + (SETQ FAULTFN NIL) (* ; + "So that RETDWIM won't do a MARKASCHANGED") + ) + ((SETQ FAULTEM1 (GETPROP (CAR FAULTX) + 'FILEDEF)) + (COND + ((WTFIXLOADEF FAULTEM1) + (GO OUT))) + (RETDWIM)) + (T (GO NX1))) + (GO OUT) + NX1 (COND + ((AND (CLISPNOTVARP (CAR FAULTX)) + (SETQ FAULTEM1 (CLISPATOM CHARLST FAULTX FAULTX))) + (* ; "E.g. (FOOâ†ATOM) OR (FOO↠form)") + (SETQ FAULTX FAULTEM1) + (GO OUT))) + NX2 (COND + ([AND CLISPFLG (SETQ FAULTEM1 (CADR FAULTX)) + (OR (LITATOM FAULTEM1) + (AND (NUMBERP FAULTEM1) + (MINUSP FAULTEM1) + (CLBINARYMINUS? FAULTX))) + (OR (GETPROP FAULTEM1 'CLISPTYPE) + (FMEMB (CAR (SETQ FAULTEM1 (DUNPACK FAULTEM1 WTFIXCHCONLST1))) + CLISPCHARS)) + (SETQ FAULTEM1 (CLISPATOM FAULTEM1 (CDR FAULTX) + FAULTX T)) + (COND + [(OR (NEQ FAULTXX (CAR FAULTX)) + (AND CLISPARRAY (GETHASH FAULTX CLISPARRAY] + (DWIMIFYFLG (SETQ CHARLST (DUNPACK FAULTXX WTFIXCHCONLST)) + (* ; "LST may have been clobbered") + (SETQ CLISPCHANGE NIL] + + (* ;; "E.g. (FOO â†atom) or (FOO ↠form). The NEQ check is necessary to handle situations like (FOOO N-1) where an CLISP transformation is performed, but it does not correct CAR of the form. (In this case, we must continue to the spelling correction part below, and set CLISPCHANGE to NIL so that DWIMIFY1 will not be confused.) Note that if FOO also happens to be the name of a function, then WTFIX will not be called and the CLISP transformation not be performed until the arguments of FOO are evaluated and cause a u.b.a. error. Then DWIM will have to back up as described in FIXATOM and FIXATOM1.") + + (SETQ FAULTX FAULTEM1) + (GO OUT)) + ((AND (NULL NOSPELLFLG0) + DWIMIFYFLG + (LISTP (CADR FAULTX)) + (FIXLAMBDA FAULTX)) + + (* ;; "The DWIMIFYFLG check is because in normal course of events, it never makes sense for LAMBDA to appear as CAR of a FORM. However, DWIMIFY1 is called on open LAMBDA expressions.") + + (GO OUT)) + ((AND (NULL NOSPELLFLG0) + (LISTP (CAR FAULTX)) + (LISTP (CADAR FAULTX)) + (FIXLAMBDA (CAR FAULTX))) + + (* ;; "This corresponds to the case where LAMBDA is misspelled in an open LAMBDA expression. Note that an open lambda expression only makes sense when there is a non-atomic argument list, so dont both spelling correcting if this is notthe case.") + + (GO OUT))) + NX3 (COND + [[SOME DWIMUSERFORMS (FUNCTION (LAMBDA (DWIMUSERFORM) + (SETQ FAULTEM1 (EVAL DWIMUSERFORM] + (COND + (FAULTAPPLYFLG (RETDWIM FAULTPOS FAULTEM1 T FAULTARGS)) + (T (RETDWIM FAULTPOS FAULTEM1] + (NOSPELLFLG0 (GO FAIL)) + [[AND CHARLST (SETQ FAULTXX + (OR (FIXSPELL (CAR FAULTX) + NIL SPELLINGS2 NIL FAULTX NIL NIL NIL T) + (AND DWIMIFYFLG NOFIXFNSLST0 + (FIXSPELL (CAR FAULTX) + NIL NOFIXFNSLST0 NIL FAULTX NIL NIL NIL T] + (* ; + "The extra argument to FIXSPELL indicates that SPLITS re tolerated, e.g. (BREAKFOO)") + (COND + ((EQ (CAAR HISTENTRY) + (CAR FAULTX)) + (/RPLNODE HISTENTRY FAULTX (CDR HISTENTRY)) + + (* ;; "Normally, RETDWIM patches the histroy entry to corresond to a list input, even if it was typed in as a line. In the special case of a pselling correction, we leave the entry as a line.") + + )) + (SETQ HISTENTRY NIL) + (COND + ((NOT (FGETD FAULTXX)) (* ; + "E.g. USER misspells FOR, IF, F/L etc. These are all contained on SPELLINGS2.") + (GO TOP] + ((AND CLISPFLG DWIMIFYFLG (CDR FAULTX) + (LISTP CLISPCONTEXT) + (FIXSPELL (CAR FAULTX) + NIL CLISPISWORDSPLST NIL FAULTX NIL NIL NIL T) + (SETQ FAULTEM1 (CLISPATOM (DUNPACK (CAR FAULTX) + WTFIXCHCONLST) + TAIL PARENT))) + + (* ;; "E.g. X IS A NUMBER AND LESS THAN Y. CLISPATOM will call CLISPATOMIS? which will retfrom back past here or generate an error. NOte that if (CAR FAUULTX) had been spelled correctly, thiswold have happened in first call to CLISPATOM at NX1 earlir. However, we dont do the misspelled check until here because it is more likely user has misspelled the name of one of his functions.") + + ) + ([AND CLISPFLG (NULL CLISPCHANGES) + (NULL CLISPERTYPE) + (SETQ FAULTEM1 (CADR FAULTX)) + (LITATOM FAULTEM1) + (SETQ FAULTEM1 (FIXSPELL FAULTEM1 NIL CLISPINFIXSPLST NIL + (OR (AND DWIMIFYFLG (LISTP CLISPCONTEXT)) + (CDR FAULTX)) + NIL NIL NIL T)) + (COND + ((AND DWIMIFYFLG (LISTP CLISPCONTEXT)) + + (* ;; + "Return from the corresponding DWIMUNDOCATCH with a value telling CLISPATOM to try again.") + + (CL:THROW 'CLISPATOM1 :RESPELL)) + (T (LET (CLISPERTYPE) + (SETQ FAULTEM1 (CLISPATOM FAULTEM1 (CDR FAULTX) + FAULTX T] + (SETQ FAULTX FAULTEM1)) + (T (GO FAIL))) + OUT (RETDWIM FAULTPOS FAULTX) + FAIL + (RETDWIM))))] (SELECTQ RESULT - (:RESPELL (* ; - "from CLISPATOM2 -- wants us to throw this message back to a higher CLISPATOM") + (:RESPELL (* ; + "from CLISPATOM2 -- wants us to throw this message back to a higher CLISPATOM") (CL:THROW 'CLISPATOM1 :RESPELL)) - (PROGN (* ; - "something interesting to return, or a value from RETDWIM ") + (PROGN (* ; + "something interesting to return, or a value from RETDWIM ") RESULT]) (RETDWIM - [LAMBDA (POS X APPLYFLG ARGS) (* bvm%: "21-Nov-86 18:02") + [LAMBDA (POS X APPLYFLG ARGS) (* bvm%: "21-Nov-86 18:02") (PROG NIL [AND FIXCLK HELPCLOCK (SETQ HELPCLOCK (IPLUS HELPCLOCK (IDIFFERENCE (CLOCK 2) FIXCLK] - (* ; - "So time spent in DWIM will not count towards a break.") + (* ; + "So time spent in DWIM will not count towards a break.") TOP [COND - [(OR POS X) (* ; "Successful correction.") + [(OR POS X) (* ; "Successful correction.") (AND (EQ (CAR SIDES) 'CLISP% ) [NCONC1 (CADR SIDES) (CDR (LISTGET1 LISPXHIST 'SIDE] (LISPXPUT '*LISPXPRINT* (LIST SIDES) - T LISPXHIST)) (* ;; "Some messages were printed, and the undo informaton marked. This completes the process enabling user to undo just the effects associated with the dwim change corresponding to the message printed between (CADR of this mark) and the place where the mark appears. The use of CLISP makes the mark invisible to the editor, and also does not i nterefere with printing the event.") + T LISPXHIST)) + + (* ;; "Some messages were printed, and the undo informaton marked. This completes the process enabling user to undo just the effects associated with the dwim change corresponding to the message printed between (CADR of this mark) and the place where the mark appears. The use of CLISP makes the mark invisible to the editor, and also does not i nterefere with printing the event.") + [COND ((AND DWIMIFYFLG DWIMIFYING) (SETQ DWIMIFY0CHANGE T)) @@ -2710,7 +3006,10 @@ with the terms of said license. (EQ FAULTX (CAR TAIL)) (EQ TAIL PARENT) (STRPOSL CLISPCHARRAY (CAR TAIL)) - (DWIMIFY2A TAIL CHARLST)) (* ;; "In the event that a parenthesis was left out, and (CAR TAIL) is really the name of a function (or misspelled function), spelling correction would nothave been attempted earlier in DWIMIFY2 until seeing if this was ok CLISP, so try it now. E.g. (IF A THEN FOOX-1), where FOO is name of a function, or (IF A THEN R/PLNODE X). Note that CLISPCHANGES might be NIL in the case that the clisp transformationdidn't go throuh, e.g. missing operand.") + (DWIMIFY2A TAIL CHARLST)) + + (* ;; "In the event that a parenthesis was left out, and (CAR TAIL) is really the name of a function (or misspelled function), spelling correction would nothave been attempted earlier in DWIMIFY2 until seeing if this was ok CLISP, so try it now. E.g. (IF A THEN FOOX-1), where FOO is name of a function, or (IF A THEN R/PLNODE X). Note that CLISPCHANGES might be NIL in the case that the clisp transformationdidn't go throuh, e.g. missing operand.") + (/RPLNODE TAIL (CONS (CAR TAIL) (CDR TAIL))) (SETQ X (DWIMIFY1? (CAR TAIL))) @@ -2735,14 +3034,20 @@ with the terms of said license. (CDR X] (SETQ POS FAULTPOS) (GO TOP)) - (CLISPERTYPE (* ;; "Error messages are postponed till this point because what looks like a bad clisp expression may be interpreted correctly in a different way --- e.g. _PENP will correct to openp.") + (CLISPERTYPE + + (* ;; "Error messages are postponed till this point because what looks like a bad clisp expression may be interpreted correctly in a different way --- e.g. â†PENP will correct to openp.") + (AND DWIMIFYFLG (SETQ ATTEMPTFLG T) - (SETQ CLISPCHANGE T)) (* ;; "ATTEMPTFLG to inform DWIMMFY not to add FAUTX to NOFIXLST. CLISPCHANGE is to prevent analysing cdr of the form in the case the error occurred in CAR of the form.") + (SETQ CLISPCHANGE T)) + + (* ;; "ATTEMPTFLG to inform DWIMMFY not to add FAUTX to NOFIXLST. CLISPCHANGE is to prevent analysing cdr of the form in the case the error occurred in CAR of the form.") + (AND (OR DWIMIFYFLG (NULL TYPE-IN?)) (CLISPERROR CLISPERTYPE] (COND - (DWIMIFYFLG (* ; - "ERROR! instead of CL:THROW so that UNDONLSETQ changes are undone") + (DWIMIFYFLG (* ; + "ERROR! instead of CL:THROW so that UNDONLSETQ changes are undone") (ERROR!)) (T (RELSTK FAULTPOS) [CL:THROW 'WTFIX (AND (NULL TYPE-IN?) @@ -2750,18 +3055,20 @@ with the terms of said license. ((ATOM FAULTX) (RETDWIM2 PARENT TAIL)) (T (RETDWIM2 FAULTX NIL 2] - (* ; - "The vaue retunred by WTFIX is used on the call to OLDFAULT1 for printing out a message.") + (* ; + "The vaue retunred by WTFIX is used on the call to OLDFAULT1 for printing out a message.") ]) (DWIMERRORRETURN - [LAMBDA (ARG) (* lmm " 5-SEP-83 23:51") + [LAMBDA (ARG) (* lmm " 5-SEP-83 23:51") (AND ARG (SETQ CLISPERTYPE ARG)) (ERROR!]) (DWIMARKASCHANGED - [LAMBDA (FN $SIDES) (* rmk%: "18-FEB-83 17:07") - (* ;; "Informs the file package that FN has been changed, giving CLISP as the reason if we detect (because no messages were printed) that the only changes are because of valid clisp dwimifications. Otherwise, the reason is CHANGED") + [LAMBDA (FN $SIDES) (* rmk%: "18-FEB-83 17:07") + + (* ;; "Informs the file package that FN has been changed, giving CLISP as the reason if we detect (because no messages were printed) that the only changes are because of valid clisp dwimifications. Otherwise, the reason is CHANGED") + (AND (LITATOM FN) (PROG [(L (CDR (LISTGET1 LISPXHIST 'SIDE] LP (COND @@ -2769,8 +3076,8 @@ with the terms of said license. (EQ L $SIDES)) (RETURN))) [SELECTQ (CAAR L) - ((/PUTHASH CLISPRPLNODE *) (* ; - "For some reason (ask wt!), these aren't counted as real changes") + ((/PUTHASH CLISPRPLNODE *) (* ; + "For some reason (ask wt!), these aren't counted as real changes") NIL) (RETURN (MARKASCHANGED FN 'FNS (COND ((FASSOC 'CLISP% (LISTGET1 LISPXHIST @@ -2781,12 +3088,14 @@ with the terms of said license. (GO LP]) (RETDWIM1 - [LAMBDA (L) (* lmm "20-May-84 19:58") - (* ;; "Called when about to make a CLISP transformation for which one of the atmic operands are not bound.") + [LAMBDA (L) (* lmm "20-May-84 19:58") + + (* ;; "Called when about to make a CLISP transformation for which one of the atmic operands are not bound.") + (PROG (($TAIL (CAR L)) ($CURRTAIL (CADR L)) - FLG TEM) (* ; - "CLISPCHANGES rebound so that FIXSPELL1 will only ask for approval if dwim mode indicates.") + FLG TEM) (* ; + "CLISPCHANGES rebound so that FIXSPELL1 will only ask for approval if dwim mode indicates.") [SETQ TEM (COND ((EQ (CDR $TAIL) $CURRTAIL) @@ -2811,19 +3120,25 @@ with the terms of said license. ([OR TREATASCLISPFLG (AND (EQ (CADDR L) 'PROBABLY) (OR (AND DWIMIFYFLG DWIMIFYING) - (NULL TYPE-IN?] (* ;; "The idea here is that it does not make sense to automatcaaly go ahead and perform a transformation to typein that is then going to produce an error, e.g. user type FOO_FIE where FIE is unbound. Therefore we will always ask him for type-in? Note that he may say YES even though it will produce an error, so that he can then say  ' or -> something. --- In functons, if the operation involves more than one CLISP operator (or an assignment where the variable is one of the bound varables.) we will just tell him.") + (NULL TYPE-IN?] + + (* ;; "The idea here is that it does not make sense to automatcaaly go ahead and perform a transformation to typein that is then going to produce an error, e.g. user type FOOâ†FIE where FIE is unbound. Therefore we will always ask him for type-in? Note that he may say YES even though it will produce an error, so that he can then say  ' or -> something. --- In functons, if the operation involves more than one CLISP operator (or an assignment where the variable is one of the bound varables.) we will just tell him.") + (SETQQ FLG NEEDNOTAPPROVE)) (T (SETQQ FLG MUSTAPPROVE))) (COND ((COND - ((AND TREATASCLISPFLG (NULL CLISPHELPFLG)) (* ; - "dont print any message, but do treat it as clisp") + ((AND TREATASCLISPFLG (NULL CLISPHELPFLG)) (* ; + "dont print any message, but do treat it as clisp") T) - ((OR TREATASCLISPFLG CLISPHELPFLG) (* ; - "interact (ask or inform) with user if either treatasclispflg is T, or clisphelpflg is T , or both.") + ((OR TREATASCLISPFLG CLISPHELPFLG) (* ; + "interact (ask or inform) with user if either treatasclispflg is T, or clisphelpflg is T , or both.") (FIXSPELL1 TEM (COND (LCASEFLG '" as clisp") - (T (* ;; "The reason for the check is that the user may want to key on this message for an UNDO : operation, and if he is on a 33 and it is printed as a lowercase string (even though he sees it in uppercase) he wont be able to fnd it.") + (T + + (* ;; "The reason for the check is that the user may want to key on this message for an UNDO : operation, and if he is on a 33 and it is printed as a lowercase string (even though he sees it in uppercase) he wont be able to fnd it.") + '" AS CLISP")) (COND [(EQ FLG 'NEEDNOTAPPROVE) @@ -2836,19 +3151,24 @@ with the terms of said license. (T '" TREAT"] (T (SHOULDNT))) T FLG)) - ((EQ FLG 'NEEDNOTAPPROVE) (* ; "dont interact, but treat it as clisp, e.g. when transformation is a PROBABLY and we are dwimifying.") + ((EQ FLG 'NEEDNOTAPPROVE) (* ; "dont interact, but treat it as clisp, e.g. when transformation is a PROBABLY and we are dwimifying.") T)) - (SETQ NOFIXVARSLST0 (CADDDR L)) (* ;; "Since user has approved CLISP, it is ok to set NOFIXVARSLST0 to include any variabes detected during analysis of CLISP expression, e.g. if expression were A*B A and B can now be added NOFIXVARSLST0") + (SETQ NOFIXVARSLST0 (CADDDR L)) + + (* ;; "Since user has approved CLISP, it is ok to set NOFIXVARSLST0 to include any variabes detected during analysis of CLISP expression, e.g. if expression were A*B A and B can now be added NOFIXVARSLST0") + (RETURN T))) (RETURN (COND (DWIMIFYFLG (SETQ NEXTAIL (NLEFT (CAR L) 1 $CURRTAIL)) - (* ; "Tells DWIMIFY where to continue.") + (* ; "Tells DWIMIFY where to continue.") (COND ((LISTP (CAR NEXTAIL)) (SETQ NEXTAIL (NLEFT (CAR L) 2 $CURRTAIL)) - (* ;; "E.G. In A* (FOO --), this will enable (FOO --) to be processed. If the expression immediately before CURRTAIL is an atom, we have no way of knowing if it contains a CLISP operator or not, e.g. is it A + B, or A+B. If we were to back up NEXTAIL so that DWIMIFYING continued as of this atom, it might cause a loop.") + + (* ;; "E.G. In A* (FOO --), this will enable (FOO --) to be processed. If the expression immediately before CURRTAIL is an atom, we have no way of knowing if it contains a CLISP operator or not, e.g. is it A + B, or A+B. If we were to back up NEXTAIL so that DWIMIFYING continued as of this atom, it might cause a loop.") + )) NIL]) @@ -2857,20 +3177,20 @@ with the terms of said license. (PROG (TEM) (PRIN1 '= T) (COND - [(EQ X CLST) (* ; "THE 8 is the first character.") + [(EQ X CLST) (* ; "THE 8 is the first character.") (PRINT (SETQ TEM (PACK (CDR X))) T T) (RETDWIM FAULTPOS (CONS TEM (COND - ((NULL APPLYFLG)(* ; "E.g. 8FOO X Y") + ((NULL APPLYFLG)(* ; "E.g. 8FOO X Y") (CDR FAULTX)) - (FAULTARGS (* ; "E.G. 8FOO (A B)") + (FAULTARGS (* ; "E.G. 8FOO (A B)") (LIST FAULTARGS] (T [SETQ FAULTARGS (COND - ((AND APPLYFLG FAULTARGS) (* ; - "E.g. 'FOO8)' or 'FOO8A)' or 'FOO8A B]'") + ((AND APPLYFLG FAULTARGS) (* ; + "E.g. 'FOO8)' or 'FOO8A)' or 'FOO8A B]'") (LIST FAULTARGS)) - (T (* ; - "E.g. 'FOO8A B C]' (or 'FOO8 A B]')") + (T (* ; + "E.g. 'FOO8A B C]' (or 'FOO8 A B]')") (CDR FAULTX] (RETDWIM FAULTPOS (PRINT (SETQ TEM (PACK (LDIFF CLST X))) T T) @@ -2882,8 +3202,10 @@ with the terms of said license. FAULTARGS]) (FIXLAMBDA - [LAMBDA (DEF) (* lmm "20-May-84 19:57") - (* ;; "LAMBDASPLST is initialized to (LAMBDA NLAMBDA). HOwever users can add to it for 'function' handled by DWIMMUSERFN. QLISP uses this feature.") + [LAMBDA (DEF) (* lmm "20-May-84 19:57") + + (* ;; "LAMBDASPLST is initialized to (LAMBDA NLAMBDA). HOwever users can add to it for 'function' handled by DWIMMUSERFN. QLISP uses this feature.") + (AND (LITATOM (CAR DEF)) (CDDR DEF) (NOT (FMEMB (CAR DEF) @@ -2892,10 +3214,13 @@ with the terms of said license. NIL LAMBDASPLST NIL DEF NIL NIL NIL T]) (FIXAPPLY - [LAMBDA NIL (* lmm "19-MAY-84 21:44") + [LAMBDA NIL (* lmm "19-MAY-84 21:44") (PROG (X TEM) (COND - ((NEQ FAULTFN FAULTX) (* ;; "means the call came out of compiled code, e.g. user types in FOO which contains a call to a mispelled function.") + ((NEQ FAULTFN FAULTX) + + (* ;; "means the call came out of compiled code, e.g. user types in FOO which contains a call to a mispelled function.") + (SETQ TYPE-IN? NIL))) (COND ((AND (LITATOM FAULTX) @@ -2912,8 +3237,8 @@ with the terms of said license. (GETPROP FAULTX 'CODE)) (DWIMUNSAVEDEF FAULTX)) (SETQ X FAULTX) - (SETQ FAULTFN NIL) (* ; - "So that RETDWIM won't do a NEWFILE?") + (SETQ FAULTFN NIL) (* ; + "So that RETDWIM won't do a NEWFILE?") (GO OUT)) ((SETQ TEM (GETPROP FAULTX 'FILEDEF)) (COND @@ -2923,16 +3248,16 @@ with the terms of said license. (RETDWIM)) ((AND TYPE-IN? CLISPFLG (STRPOSL CLISPCHARRAY FAULTX) (SETQ X (CLISPATOM CHARLST (SETQ TEM (LIST FAULTX FAULTARGS)) - TEM T))) (* ; - "E.g. FOO_ form. FOO _form is caught by a special check in LISPX and treated as (FOO _form)") + TEM T))) (* ; + "E.g. FOO↠form. FOO â†form is caught by a special check in LISPX and treated as (FOO â†form)") (RETDWIM FAULTPOS X)) ((AND TYPE-IN? (NEQ NOSPELLFLG T) (EQ FAULTXX (CAAR HISTENTRY)) (SETQ TEM (FMEMB LPARKEY CHARLST))) (FIX89TYPEIN TEM CHARLST T)) ((AND (LISTP FAULTX) - (FIXLAMBDA FAULTX)) (* ; - "LAMBDA or NLAMBDA misspelled in LAMBDA expression being applied, e.g. a functional argument.") + (FIXLAMBDA FAULTX)) (* ; + "LAMBDA or NLAMBDA misspelled in LAMBDA expression being applied, e.g. a functional argument.") (SETQ X FAULTX) (GO OUT))) NX (COND @@ -2950,7 +3275,7 @@ with the terms of said license. (RETDWIM FAULTPOS X T FAULTARGS]) (FIXATOM - [LAMBDA NIL (* bvm%: "21-Nov-86 16:38") + [LAMBDA NIL (* bvm%: "21-Nov-86 16:38") (PROG (X Y TAIL0) (COND ((NULL TAIL) @@ -2958,19 +3283,22 @@ with the terms of said license. (BLIPVAL '*FORM* X))) (RELSTK X))) (SETQ TAIL0 (AND (NEQ ONLYSPELLFLG 'NORUNONS) - TAIL)) (* ;; "ONLYSPELLFLG is NORUNONS for calls from CLISPATOM2A, i.e. when DWIMIYING one of the operands to an infix operator. IN this case it never makes sense to do a runon spelling correction, e.g. FOOX*A shouldnt correct to (ITIMES FOO X A), althouh it may correct to FOO X*A.") + TAIL)) + + (* ;; "ONLYSPELLFLG is NORUNONS for calls from CLISPATOM2A, i.e. when DWIMIYING one of the operands to an infix operator. IN this case it never makes sense to do a runon spelling correction, e.g. FOOX*A shouldnt correct to (ITIMES FOO X A), althouh it may correct to FOO X*A.") + (COND ((SETQ X (CLISPATOM CHARLST TAIL PARENT)) (GO OUT)) ([AND (CDR TAIL) (LITATOM (SETQ Y (CADR TAIL))) (FMEMB (CHCON1 Y) - (CHARCODE (_ ¬))) + (CHARCODE (↠_))) (PROG (CLISPERTYPE) (RETURN (SETQ X (CLISPATOM (UNPACK Y) (CDR TAIL) - PARENT T] (* ; - "E.G. (LIST FOO _ 3) where FOO is unbound at the time. See comment in WTFIX.") + PARENT T] (* ; + "E.G. (LIST FOO ↠3) where FOO is unbound at the time. See comment in WTFIX.") (GO OUT)) ([AND DWIMUSERFORMS (SOME DWIMUSERFORMS (FUNCTION (LAMBDA (DWIMUSERFORM) (SETQ X (EVAL DWIMUSERFORM] @@ -2978,10 +3306,15 @@ with the terms of said license. ((OR (EQ NOSPELLFLG T) (AND NOSPELLFLG (NULL TYPE-IN?)) (GETPROP FAULTX 'GLOBALVAR) - (FMEMB FAULTX GLOBALVARS)) (* ;; "For efficiency, GLOBALVARS is a global variable itself for DWIMBLOCK. Thus FIXATOM obtains the top level value, not the one rebound by BCOMPL2. However, in the case that there are block declarations aafecting globalvars, the variables would also have been added to NOFIXVARSLST, so this is ok.") + (FMEMB FAULTX GLOBALVARS)) + + (* ;; "For efficiency, GLOBALVARS is a global variable itself for DWIMBLOCK. Thus FIXATOM obtains the top level value, not the one rebound by BCOMPL2. However, in the case that there are block declarations aafecting globalvars, the variables would also have been added to NOFIXVARSLST, so this is ok.") + (RETDWIM)) ((AND VARS (SETQ X (FIXSPELL FAULTX NIL VARS NIL TAIL0 NIL NIL NIL T))) - (* ;; "Corrects spellings using LAMBDA and PROG variables of function in which error occurred, or function that is broken.") + + (* ;; "Corrects spellings using LAMBDA and PROG variables of function in which error occurred, or function that is broken.") + ) ((SETQ X (FIXSPELL FAULTX NIL SPELLINGS3 NIL TAIL0 NIL NIL NIL T))) ((AND DWIMIFYFLG (EQ CLISPCONTEXT 'IFWORD) @@ -2991,7 +3324,7 @@ with the terms of said license. (FIXSPELL FAULTX NIL CLISPFORWORDSPLST NIL T NIL NIL NIL T)) (CL:THROW 'CLISPFOR0 :RESPELL)) [(AND DWIMIFYFLG NOFIXVARSLST0 (SETQ X - (FIXSPELL FAULTX NIL NOFIXVARSLST0 NIL TAIL0 NIL NIL NIL + (FIXSPELL FAULTX NIL NOFIXVARSLST0 NIL TAIL0 NIL NIL NIL T] ((AND DWIMIFYFLG CLISPFLG (OR (EQ CLISPCONTEXT 'IS) (AND (LISTP CLISPCONTEXT) @@ -2999,11 +3332,14 @@ with the terms of said license. (EQ TAIL PARENT))) (SETQ X (FIXSPELL FAULTX NIL CLISPISWORDSPLST NIL TAIL NIL NIL NIL T))) (COND - ((EQ CLISPCONTEXT 'IS) (* ;; "In this case, we are dwimifying the tail before processing it in clispatomis so is sufficient just to correct spelling and return.") + ((EQ CLISPCONTEXT 'IS) + + (* ;; "In this case, we are dwimifying the tail before processing it in clispatomis so is sufficient just to correct spelling and return.") + ) ((SETQ X (CLISPATOM (DUNPACK X WTFIXCHCONLST) - TAIL PARENT)) (* ; - "E.g. X IS A NUMBER OR STRNG, STRNG being misspelled. Will call CLISPATOMIS? which will retfrom.") + TAIL PARENT)) (* ; + "E.g. X IS A NUMBER OR STRNG, STRNG being misspelled. Will call CLISPATOMIS? which will retfrom.") )) (GO OUT)) ([AND CLISPFLG (NULL CLISPCHANGES) @@ -3037,18 +3373,23 @@ with the terms of said license. (T (RETDWIM))) [COND ((AND (NULL TAIL0) - (EQ FAULTX (CAR TAIL))) (* ; - "If TAIL0 is not NIL, the RPLNODE has aleady been done.") + (EQ FAULTX (CAR TAIL))) (* ; + "If TAIL0 is not NIL, the RPLNODE has aleady been done.") (/RPLNODE TAIL X (CDR TAIL] OUT [COND - ((AND NEWTAIL (NULL DWIMIFYFLG)) (* ;; "The interpreter has already made up its mind about how to handle the first operand of the CLISP expression, e.g. it has already been evaluated as an argument, or else is about to be called as a function. Therefore continuing the computation requires some fiddling around.") + ((AND NEWTAIL (NULL DWIMIFYFLG)) + + (* ;; "The interpreter has already made up its mind about how to handle the first operand of the CLISP expression, e.g. it has already been evaluated as an argument, or else is about to be called as a function. Therefore continuing the computation requires some fiddling around.") + (SETQ X (FIXATOM1] (RETDWIM FAULTPOS X]) (FIXATOM1 - [LAMBDA NIL (* lmm "20-SEP-83 23:37") - (* ;; - "Called when evaluation went too far before DWIM fixed an CLISP expression. See comment in FIXATOM") + [LAMBDA NIL (* lmm "20-SEP-83 23:37") + + (* ;; + "Called when evaluation went too far before DWIM fixed an CLISP expression. See comment in FIXATOM") + (PROG ((POS (STKNTH -1 FAULTPOS)) X OLDTAIL OLDFN) (SETQ OLDTAIL (BLIPVAL '*TAIL* POS)) @@ -3058,7 +3399,7 @@ with the terms of said license. (COND ((NEQ TAIL OLDTAIL) (GO ERROR))) - (SETBLIPVAL '*TAIL* POS NIL NEWTAIL) (* ; "Change the binding for the tai") + (SETBLIPVAL '*TAIL* POS NIL NEWTAIL) (* ; "Change the binding for the tai") (FIXCONTINUE (CADAR NEWTAIL)) (SETQ X (CAR NEWTAIL)) (GO OUT)) @@ -3066,52 +3407,76 @@ with the terms of said license. (SETQ OLDFN (BLIPVAL '*FN* POS)) [COND ([COND - ((NEQ TAIL OLDTAIL) (* ; - "E.g. (COND (ZAP _ T 3)) where ZAP is A u.b.a.") + ((NEQ TAIL OLDTAIL) (* ; + "E.g. (COND (ZAP ↠T 3)) where ZAP is A u.b.a.") T) - ((LISTP NEWTAIL) (* ; "E.G. (LIST FOO X + Y)") + ((LISTP NEWTAIL) (* ; "E.G. (LIST FOO X + Y)") (NEQ OLDFN (CAR PARENT))) - [(ATOM (CADR PARENT)) (* ;; "e.g. (FOO AND T) where FOO is the name of a function as well as a variable. the check here used to be (NEQ OLDFN (CADR PARENT)). however this fails for things like (FOO : FIE) which at this point would be (fetch FIE of FOO), i.e. cant assume that car of form is now CADR") + [(ATOM (CADR PARENT)) + + (* ;; "e.g. (FOO AND T) where FOO is the name of a function as well as a variable. the check here used to be (NEQ OLDFN (CADR PARENT)). however this fails for things like (FOO : FIE) which at this point would be (fetch FIE of FOO), i.e. cant assume that car of form is now CADR") + (AND (NEQ OLDFN (CADR PARENT)) (NEQ OLDFN (CADDDR PARENT] - (T (* ;; "For infixes like EQ, AND, OR, the function that was about to be called may now be parenthesized, e.g. (FOO X EQ Y) becomes (EQ (FOO X) Y) However, it is also possible that it was not a function at all, e.g. (FOO GT 4 AND FOO LT 6)") - (NOT (FMEMB OLDFN (CADR PARENT] (* ;; "The procedure followed assumes that Y gives the binding for TAIL, and Z gives the binding for the name of the function that is about to be called. This checks to make sure that this is in fact the cas") + (T + (* ;; "For infixes like EQ, AND, OR, the function that was about to be called may now be parenthesized, e.g. (FOO X EQ Y) becomes (EQ (FOO X) Y) However, it is also possible that it was not a function at all, e.g. (FOO GT 4 AND FOO LT 6)") + + (NOT (FMEMB OLDFN (CADR PARENT] + + (* ;; "The procedure followed assumes that Y gives the binding for TAIL, and Z gives the binding for the name of the function that is about to be called. This checks to make sure that this is in fact the cas") + (GO BAD)) - ((NLISTP NEWTAIL) (* ;; "Occurs when CAR of an xpression in which a CLISP operator is used is the name of a function, e.g. (FOO + X), (FOO X AND FIE Y). Note that at this point in the evaluton, the nterpreter is evaluating the 'arguments' for that function, and plans to call it when they have all been evaluated") + ((NLISTP NEWTAIL) + + (* ;; "Occurs when CAR of an xpression in which a CLISP operator is used is the name of a function, e.g. (FOO + X), (FOO X AND FIE Y). Note that at this point in the evaluton, the nterpreter is evaluating the 'arguments' for that function, and plans to call it when they have all been evaluated") + NIL) ((OR (CDR NEWTAIL) (ZEROP (LOGAND (ARGTYPE (CAR PARENT)) - 2))) (* ;; "Either there are more arguments following the CLISP expression, or, in the case of a spread, evaluate, it doesn't matter if an extra NIL is passed. Therefore, proceed by smashing the last argument with the value of the CLISP expression, (CAR NEWTAIL), change the binding for the tail to be (CDR NEWTAIL), and RETDWIM with the next expression on TAIL, (CADR NEWTAIL) e.g. (LIST T 2 + 3 6)") + 2))) + + (* ;; "Either there are more arguments following the CLISP expression, or, in the case of a spread, evaluate, it doesn't matter if an extra NIL is passed. Therefore, proceed by smashing the last argument with the value of the CLISP expression, (CAR NEWTAIL), change the binding for the tail to be (CDR NEWTAIL), and RETDWIM with the next expression on TAIL, (CADR NEWTAIL) e.g. (LIST T 2 + 3 6)") + [SETBLIPVAL '*ARGVAL* POS NIL (STKEVAL POS (FIXLISPX/ (CAR NEWTAIL] (SETBLIPVAL '*TAIL* POS NIL (CDR NEWTAIL)) (SETQ X (CADR NEWTAIL)) (GO OUT)) - (T (* ;; "The function to be called is a nospread function, e.g. LIST, and the CLISP expression was its last argument, e.g. (LIST X (--) *2) Therefore can only continue by reevaluating the whole form") + (T + (* ;; "The function to be called is a nospread function, e.g. LIST, and the CLISP expression was its last argument, e.g. (LIST X (--) *2) Therefore can only continue by reevaluating the whole form") + (FIXCONTINUE (CADAR NEWTAIL) (AND (NULL TYPE-IN?) FAULTFN] - (SETBLIPVAL '*TAIL* POS NIL NIL) (* ; - "Makes tail of the argument list be NIL") - (SETBLIPVAL '*FN* POS NIL 'FIXATOM2) (* ; - "A nospread, evaluate function whose value is the value of its last argument") + (SETBLIPVAL '*TAIL* POS NIL NIL) (* ; + "Makes tail of the argument list be NIL") + (SETBLIPVAL '*FN* POS NIL 'FIXATOM2) (* ; + "A nospread, evaluate function whose value is the value of its last argument") (SETQ X PARENT) - (GO OUT) (* ;; "PARENT will be evaluated, and its value stored on the stack. Then since the tail of the argument list is now NIL, the interpreter figures that the evaluation of arguments is finished, and calls the function. However since Z was changed, FIXATOM2 will be called instead, and it will return as its value its last argument, which will be the value of PARENT. Voila") - BAD (* ; "Stack not in normal state") + (GO OUT) + + (* ;; "PARENT will be evaluated, and its value stored on the stack. Then since the tail of the argument list is now NIL, the interpreter figures that the evaluation of arguments is finished, and calls the function. However since Z was changed, FIXATOM2 will be called instead, and it will return as its value its last argument, which will be the value of PARENT. Voila") + + BAD (* ; "Stack not in normal state") (SELECTQ (STKNAME (SELECTQ (SYSTEMTYPE) - ((JERICHO D) (* ; "Skip over internal frames") + ((JERICHO D) (* ; "Skip over internal frames") (REALSTKNTH -1 POS T POS)) POS)) (COND (COND - ((EQ PARENT NEWTAIL) (* ;; "The CLISP transformation changed the predicate of a COND clause, e.g. (COND (FOO _ form --) --) Since the COND would ordinarily continue down that clause, it is necessary to continue by constructing an appropriate COND expression, and returning its value as the value of the entire COND") + ((EQ PARENT NEWTAIL) + + (* ;; "The CLISP transformation changed the predicate of a COND clause, e.g. (COND (FOO ↠form --) --) Since the COND would ordinarily continue down that clause, it is necessary to continue by constructing an appropriate COND expression, and returning its value as the value of the entire COND") + [SETQ X (CONS 'COND (FMEMB PARENT (STKARG 1 POS] (RELSTK FAULTPOS) (SETQ FAULTPOS POS) (GO OUT)) - (T (* ;; "The CLISP transformation did not affect the predicate of a COND clause, so can continue by just evaluating PARENT E.G. (COND (T FOO _ 2))") + (T + (* ;; "The CLISP transformation did not affect the predicate of a COND clause, so can continue by just evaluating PARENT E.G. (COND (T FOO ↠2))") + (SETQ X (CAR NEWTAIL)) (GO OUT)))) - ((PROGN PROG1) (* ; - "Error in SELECTQ clause, e.g. (SELECTQ -- (-- A * B)) or error in savesetq") + ((PROGN PROG1) (* ; + "Error in SELECTQ clause, e.g. (SELECTQ -- (-- A * B)) or error in savesetq") (SETQ X (CONS (STKNAME POS) NEWTAIL)) (RELSTK FAULTPOS) @@ -3141,7 +3506,7 @@ with the terms of said license. (RETDWIM]) (FIXCONTINUE1 - [LAMBDA (X) (* True if it is ok to reevaluate X.) + [LAMBDA (X) (* True if it is ok to reevaluate X.) (OR (EQ (CAR X) 'QUOTE) (AND [OR (FMEMB (CAR X) @@ -3166,26 +3531,31 @@ with the terms of said license. (GO LP]) (CLISPATOM - [LAMBDA (CLST TAIL PARENT NOFIX89) (* lmm "20-May-84 19:46") - (* ;; "CLST is an exploded character list for CAR of TAIL, which is a tail of PARENT, although not necessarily a proper tail. ONLYSPELLFLG=T indicates that the ONLY corrections to be attempted are spelling corrections. Occurs on calls from CLISPATOM2a.") + [LAMBDA (CLST TAIL PARENT NOFIX89) (* lmm "20-May-84 19:46") + + (* ;; "CLST is an exploded character list for CAR of TAIL, which is a tail of PARENT, although not necessarily a proper tail. ONLYSPELLFLG=T indicates that the ONLY corrections to be attempted are spelling corrections. Occurs on calls from CLISPATOM2a.") + (AND (NULL ONLYSPELLFLG) (PROG (TEM) (COND [(AND (NULL CLISPCHANGES) (OR (EQ CLISPFLG T) (AND (EQ CLISPFLG 'TYPE-IN) - TYPE-IN?))) (* ;; "If CLISPCHANGES is not NIL, a CLISP correction has already been found, so don't bother to find another, e.g. in (X+Y + Z), if X and Y are not bound vriables, after ggetting (IPLUS X Y Z), this would be undone and saved, pending spelling correction on X+Y. Therefore don't do the transformation that staats with +Z.") + TYPE-IN?))) + + (* ;; "If CLISPCHANGES is not NIL, a CLISP correction has already been found, so don't bother to find another, e.g. in (X+Y + Z), if X and Y are not bound vriables, after ggetting (IPLUS X Y Z), this would be undone and saved, pending spelling correction on X+Y. Therefore don't do the transformation that staats with +Z.") + (RETURN (COND ((SETQ TEM (CLISPATOM0 CLST TAIL PARENT)) TEM) (CLISPCHANGES (SETQ CHARLST (DUNPACK FAULTXX WTFIXCHCONLST)) - (* ; - "Since DWIMIFY2, and hence WTFIX, may have been called, LST may have been clobbered.") + (* ; + "Since DWIMIFY2, and hence WTFIX, may have been called, LST may have been clobbered.") NIL] ((AND (EQ (CAR CLST) '%') - (GETPROP '%' 'CLISPTYPE)) (* ; - "So ' can be disabled when CLISP is turned off as well.") + (GETPROP '%' 'CLISPTYPE)) (* ; + "So ' can be disabled when CLISP is turned off as well.") [COND [(CDR CLST) [SETQ TEM (LIST 'QUOTE (PACK (CDR CLST] @@ -3218,29 +3588,32 @@ with the terms of said license. ((AND TYPE-IN? (EQ (CAR TEM) LPARKEY) (EQ (CAR (SETQ TEM (FLAST CLST))) - RPARKEY)) (* ;; "This corresponds to the case where an atom was typed in containing both an 8 and a 9, e.g. FILES?89 or 8EDITF9. Note that if the atom were part of a larger expression, either CAR of form, or appearing in a tail, (as indicated by TAIL being non-NIL), the fix is performed by FIX89, and involves editing the expression. In the case covered here, the fix requires changing the EVAL to an apppropriate APPLY. The case where the 8 or 9 error appears in an APPLY context, or line format, is taken care of in WTFIX.") + RPARKEY)) + + (* ;; "This corresponds to the case where an atom was typed in containing both an 8 and a 9, e.g. FILES?89 or 8EDITF9. Note that if the atom were part of a larger expression, either CAR of form, or appearing in a tail, (as indicated by TAIL being non-NIL), the fix is performed by FIX89, and involves editing the expression. In the case covered here, the fix requires changing the EVAL to an apppropriate APPLY. The case where the 8 or 9 error appears in an APPLY context, or line format, is taken care of in WTFIX.") + (FIX89TYPEIN (FMEMB LPARKEY (SETQ TEM (LDIFF CLST TEM))) TEM T]) (GETVARS - [LAMBDA (X) (* lmm "20-May-84 19:24") + [LAMBDA (X) (* lmm "20-May-84 19:24") (PROG (L POS TEM) (COND - ((EQ X T) (* ; - "context is inside of a BREAK --- Gets variables of BRKFN.") + ((EQ X T) (* ; + "context is inside of a BREAK --- Gets variables of BRKFN.") (SETQ POS (STKPOS 'BREAK1 -1 FAULTPOS)) [COND ((AND [NOT (EQ 0 (STKNARGS (SETQ TEM (FSTKNTH -1 POS] - (LITATOM (STKARGNAME 1 TEM))) (* ; - "If the first argument's name is #0 or #100, there are no genuine variables.") + (LITATOM (STKARGNAME 1 TEM))) (* ; + "If the first argument's name is #0 or #100, there are no genuine variables.") (SETQ L (VARIABLES TEM] (SETQ X (STKARG 1 POS)) (RELSTK TEM) - (RELSTK POS) (* ; - "Sets X to BRKEXP the first argument to BREAK1. Used for getting PROG variables below.") + (RELSTK POS) (* ; + "Sets X to BRKEXP the first argument to BREAK1. Used for getting PROG variables below.") ) [(EQ (CAR X) - 'LAMBDA) (* ; "Gets variables for expression X.") + 'LAMBDA) (* ; "Gets variables for expression X.") (SETQ L (APPEND (CADR X] (T (RETURN NIL))) (RETURN (NCONC L (AND (LISTP X) @@ -3252,18 +3625,24 @@ with the terms of said license. (T (CAR X]) (GETVARS1 - [LAMBDA (X) (* DD%: " 2-Dec-81 16:49") - (* ;; "Looks for a PROG.") + [LAMBDA (X) (* DD%: " 2-Dec-81 16:49") + + (* ;; "Looks for a PROG.") + (SELECTQ [CAR (SETQ X (CAR (LISTP (LAST (LISTP X] ((PROG RESETVARS) X) - ((RESETLST RESETVAR RESETFORM) + ((RESETLST + RESETVAR + RESETFORM) (GETVARS1 X)) NIL]) (FIX89 - [LAMBDA (FORM N POS) (* bvm%: "21-Nov-86 18:47") - (* ;; "Handles corrections for 8 and 9 errors. N is either 8 or 9.0 POS is optional, and if given, it is the position of the 8 or 9 in the offending atom, and also indicates that the user has already approved the correction.") + [LAMBDA (FORM N POS) (* bvm%: "21-Nov-86 18:47") + + (* ;; "Handles corrections for 8 and 9 errors. N is either 8 or 9.0 POS is optional, and if given, it is the position of the 8 or 9 in the offending atom, and also indicates that the user has already approved the correction.") + (PROG [SPLIT89FLG (C (COND ((EQ N LPARKEY) 'FIX8) @@ -3272,29 +3651,30 @@ with the terms of said license. ([OR (AND (ATOM FAULTX) (NULL TAIL)) (AND (NULL POS) - (NULL (FIX89A FAULTX N] (* ; - "pointless to attempt an 8 or 9 correction if TAIL is NIL.") - (RETURN NIL))) (* ; - "Gets user approval if necessary, i.e. if TYPE-IN? is NIL and APPROVEFLG is T.") + (NULL (FIX89A FAULTX N] (* ; + "pointless to attempt an 8 or 9 correction if TAIL is NIL.") + (RETURN NIL))) (* ; + "Gets user approval if necessary, i.e. if TYPE-IN? is NIL and APPROVEFLG is T.") (EDITE EXPR (LIST (LIST 'ORR (LIST (LIST (COND ((ATOM FORM) 'F) (T 'F=)) FORM T) (LIST C NIL POS)) - NIL))) (* ; - "Constructs command of form ((ORR ((F= FORM T) C) NIL)) C is either FIX8 or FIX9 depending on call.") + NIL))) (* ; + "Constructs command of form ((ORR ((F= FORM T) C) NIL)) C is either FIX8 or FIX9 depending on call.") (RETURN (COND - ((NULL SPLIT89FLG) (* ; "Set in SPLIT89 if successful.") + ((NULL SPLIT89FLG) (* ; "Set in SPLIT89 if successful.") (EXEC-FORMAT "couldn't~%%") NIL) (T (AND DWIMIFYFLG (SETQ 89CHANGE T)) T]) (FIXPRINTIN - [LAMBDA (FN FLG) (* wt%: 12-OCT-76 21 40) - (* ;; - "If FLG is T, printing goes on history lst.") + [LAMBDA (FN FLG) (* wt%: 12-OCT-76 21 40) + + (* ;; "If FLG is T, printing goes on history lst.") + (AND FN (NEQ FN 'TYPE-IN) (PROG ((LISPXHIST (AND FLG LISPXHIST))) (AND (NEQ (POSITION T) @@ -3305,7 +3685,10 @@ with the terms of said license. [(OR (AND DWIMIFYFLG DWIMIFYING) (NULL FAULTAPPLYFLG)) (COND - (LCASEFLG (* ;; "Done this way instead of just printing the lower case version because users may want to efer to the message to undo a dwim correction, e.g. by typing UNDO : $IN$.") + (LCASEFLG + + (* ;; "Done this way instead of just printing the lower case version because users may want to efer to the message to undo a dwim correction, e.g. by typing UNDO : $IN$.") + '"in ") (T '"IN "] (LCASEFLG '"below ") @@ -3316,7 +3699,7 @@ with the terms of said license. (RETURN FN]) (FIX89A - [LAMBDA (X N POS) (* wt%: 25-FEB-76 1 40) + [LAMBDA (X N POS) (* wt%: 25-FEB-76 1 40) [COND ((LISTP X) (SETQ X (CAR X] @@ -3337,14 +3720,20 @@ with the terms of said license. NIL]) (CLISPFUNCTION? - [LAMBDA (TL TYPE FN1 FN2 Y) (* lmm "20-May-84 18:56") - (* ;; "returns TRUE if (CAR TAIL) corresponds to the name of a function (Possibly misspelled). If TYP=NOTVAR, checks first to make sure (CAR TAIL) does not correspond to the name of a variable.") - (* ;; "FN1 and FN2 are used to compute the arguments to FIXSPELL1. FN1 is given (CAR TAIL) and Y as its arguments, FN2 (CAR TAIL) or the corrected spelling, and Y. If FN1 is supplied, FIXSPELL is called so as not to print any messages, and the interaction takes place under CLISPUNCTION? control via a direct call to FIXSPELL1. In this case, if TYP=QUIET, no message is printed at all. --- If FN1 is not suppied, FIXSPELL will take care of the interaction, if any, othrwisre there are no error messages.") + [LAMBDA (TL TYPE FN1 FN2 Y) (* lmm "20-May-84 18:56") + + (* ;; "returns TRUE if (CAR TAIL) corresponds to the name of a function (Possibly misspelled). If TYP=NOTVAR, checks first to make sure (CAR TAIL) does not correspond to the name of a variable.") + + (* ;; "FN1 and FN2 are used to compute the arguments to FIXSPELL1. FN1 is given (CAR TAIL) and Y as its arguments, FN2 (CAR TAIL) or the corrected spelling, and Y. If FN1 is supplied, FIXSPELL is called so as not to print any messages, and the interaction takes place under CLISPUNCTION? control via a direct call to FIXSPELL1. In this case, if TYP=QUIET, no message is printed at all. --- If FN1 is not suppied, FIXSPELL will take care of the interaction, if any, othrwisre there are no error messages.") + (PROG (TEM CHRLST) (COND ((NULL (LITATOM (CAR TL))) (RETURN NIL)) - ((LISTP TYPE) (* ;; "Means that we already know that (CAR TAIL) is not the name of a variable, and is also not the name of a function.") + ((LISTP TYPE) + + (* ;; "Means that we already know that (CAR TAIL) is not the name of a variable, and is also not the name of a function.") + (SETQ CHRLST TYPE) (GO SPELL)) ([AND (EQ TYPE 'NOTVAR) @@ -3394,19 +3783,24 @@ with the terms of said license. NIL T (AND (OR FN1 (LISTP TEM)) 'MUSTAPPROVE) (AND (LISTP TEM) - 'n] (* ;; "If TYP=QUIET (from DWIMIFY2), the message is printed only on spelling correction. For other calls, e.g. TYP=OKVAR, or TYP=NOTVAR, the message is printed even if no correction involved.") + 'n] + + (* ;; "If TYP=QUIET (from DWIMIFY2), the message is printed only on spelling correction. For other calls, e.g. TYP=OKVAR, or TYP=NOTVAR, the message is printed even if no correction involved.") + [AND TEM FN1 (COND - ((LISTP TEM) (* ; "Run on correction.") + ((LISTP TEM) (* ; "Run on correction.") (/RPLNODE TL (CAR TEM) (CONS (CDR TEM) (CDR TL))) (SETQ TEM (CAR TEM))) (T (/RPLNODE TL TEM (CDR TL] - (* ;; "If FN1 is NIL, TAIL would have been given to FIXSPPELL, and in this case the correction would already have been stmashed into TAIL.") + + (* ;; "If FN1 is NIL, TAIL would have been given to FIXSPPELL, and in this case the correction would already have been stmashed into TAIL.") + (CAR TL]) (CLISPNOTVARP - [LAMBDA (X) (* lmm "20-May-84 19:45") + [LAMBDA (X) (* lmm "20-May-84 19:45") (AND (NOT (BOUNDP X)) (NOT (FMEMB X VARS)) [NOT (FMEMB X (COND @@ -3421,7 +3815,7 @@ with the terms of said license. (NOT (FMEMB X (LISTP SPECVARS]) (CLISP-SIMPLE-FUNCTION-P - [LAMBDA (CARFORM) (* lmm "18-Jul-86 16:45") + [LAMBDA (CARFORM) (* lmm "18-Jul-86 16:45") (AND (OR (FGETD CARFORM) (GET CARFORM 'EXPR) (AND (NOT (GET CARFORM 'CLISPWORD)) @@ -3430,7 +3824,7 @@ with the terms of said license. T]) (CLISPELL - [LAMBDA (FORM TYPE) (* lmm "20-May-84 18:54") + [LAMBDA (FORM TYPE) (* lmm "20-May-84 18:54") (PROG (VAL TEM RESPELLTAIL) [MAPC (LISTGET1 LISPXHIST 'RESPELLS) (FUNCTION (LAMBDA (X) @@ -3452,9 +3846,12 @@ with the terms of said license. (RETURN VAL]) (FINDFN - [LAMBDA (POS FLG) (* lmm "21-May-84 00:40") - (* ;; "Used by HELPFIX and WTFIX. Locates highest interpreted form in the current chain of interpretation, sets free variable EXPR to this expression and returns the NAME of the corresponding function, or 'BREAK-EXP', 'EVAL', or 'TYPE-IN' depending on context. also sets free variable TYPE-IN? to T if the expression was typed in by the user.") - (* ;; "When called from WTFIX, (FLG is T) and sets the variable BREAKFLG to T if the expression was typed into a BREAK, (In this case, DWIM uses the lambda and/or prog variables for spelling corrections.)") + [LAMBDA (POS FLG) (* lmm "21-May-84 00:40") + + (* ;; "Used by HELPFIX and WTFIX. Locates highest interpreted form in the current chain of interpretation, sets free variable EXPR to this expression and returns the NAME of the corresponding function, or 'BREAK-EXP', 'EVAL', or 'TYPE-IN' depending on context. also sets free variable TYPE-IN? to T if the expression was typed in by the user.") + + (* ;; "When called from WTFIX, (FLG is T) and sets the variable BREAKFLG to T if the expression was typed into a BREAK, (In this case, DWIM uses the lambda and/or prog variables for spelling corrections.)") + (PROG1 [PROG (NAME TOKEN TEM) [COND ((NULL POS) @@ -3515,31 +3912,36 @@ with the terms of said license. (GO LP)) (INTERNAL (GO LP3)) (NIL 'EVAL) - (%: (* ; - "Call to EVAL comes from a BREAK (i.e. via a LISPX which was called from BREAK1.)") + (%: (* ; + "Call to EVAL comes from a BREAK (i.e. via a LISPX which was called from BREAK1.)") (AND FLG (SETQ BREAKFLG T)) (SETQ TYPE-IN? T) 'TYPE-IN) - (BREAK (* ; - "Call to EVAL from evaluation of a breakcommand.") + (BREAK (* ; + "Call to EVAL from evaluation of a breakcommand.") (AND FLG (SETQ BREAKFLG T)) 'BREAKCOMS) - (BREAK-EXP (* ; - "Call to EVAL from EVAL, OK, or GO command.") + (BREAK-EXP (* ; + "Call to EVAL from EVAL, OK, or GO command.") (COND ((NULL (EVALV 'BRKTYPE POS)) - (* ;; "Since BRKTYPE is NIL, we are in a user BREAK. Therefore, if broken function is an EXPR, want to stop searching, otherwise continue (latter can only occur when FINDFN is called as result of EDIT command since WTFIX will never be called out of compiled function.)") + + (* ;; "Since BRKTYPE is NIL, we are in a user BREAK. Therefore, if broken function is an EXPR, want to stop searching, otherwise continue (latter can only occur when FINDFN is called as result of EDIT command since WTFIX will never be called out of compiled function.)") + (SETQ TEM (STKPOS 'BREAK1 -1 POS)) (RELSTK POS) [SETQ NAME (STKNAME (SETQ POS (STKNTH -1 TEM TEM] (GO LP2)) - (T (* ;; "EVAL, OK, or GO command to non-user BREAK expression, e.g. get a non-numeric arg BREAK, fix the BRKEXP, do an EVAL, and get another error.") + (T + + (* ;; "EVAL, OK, or GO command to non-user BREAK expression, e.g. get a non-numeric arg BREAK, fix the BRKEXP, do an EVAL, and get another error.") + 'BREAK-EXP))) (COND ((LISTP TOKEN) (COND - ((NLISTP EXPR) (* ; - "permits caller to specify the tail") + ((NLISTP EXPR) (* ; + "permits caller to specify the tail") (SETQ TAIL TOKEN))) 'EVAL) (T (SETQ TYPE-IN? T) @@ -3551,7 +3953,10 @@ with the terms of said license. (GO LP)) (INTERNAL (GO LP3)) NIL) - (SETQ TYPE-IN? TOKEN) (* ;; "WTFIX would already know that this was an apply error because of FAULTAPPLYFLG. However, FINDFN is called to find out whether the expression was typed in or not.") + (SETQ TYPE-IN? TOKEN) + + (* ;; "WTFIX would already know that this was an apply error because of FAULTAPPLYFLG. However, FINDFN is called to find out whether the expression was typed in or not.") + (RETURN (COND (FLG (SETQ EXPR (STKARG 2 POS)) (STKARG 1 POS)) @@ -3559,21 +3964,21 @@ with the terms of said license. (RELSTK POS]) (DWIMUNSAVEDEF - [LAMBDA (FN FLG) (* lmm "11-DEC-81 21:23") + [LAMBDA (FN FLG) (* lmm "11-DEC-81 21:23") (LISPXPRIN2 FN T T) [AND (NULL FLG) (NULL TYPE-IN?) (NEQ (CAR SIDES) 'CLISP% ) (SETQ SIDES (LIST 'CLISP% (LIST COMMENTFLG (FLAST (LISTGET1 LISPXHIST '*LISPXPRINT*)) - SIDES] (* ; - "FLG is TRUE on calls from CLISPIFY, in which case SIDES is not relevant (or even bound)") + SIDES] (* ; + "FLG is TRUE on calls from CLISPIFY, in which case SIDES is not relevant (or even bound)") (LISPXPRIN1 '" unsaved" T) (LISPXTERPRI T) (UNSAVEDEF FN]) (CHECKTRAN - [LAMBDA (X) (* lmm "20-May-84 19:01") + [LAMBDA (X) (* lmm "20-May-84 19:01") (DECLARE (GLOBALVARS %#CLISPARRAY CLISPARRAY CLISPTRANFLG)) (OR (AND CLISPARRAY (GETHASH X CLISPARRAY)) (AND CLISPTRANFLG (EQ (CAR X) @@ -3583,9 +3988,10 @@ with the terms of said license. (DEFINEQ (CLISPIF - [LAMBDA (FORM) (* bvm%: "21-Nov-86 18:09") - (* ;; - "Translates (IF -- THEN -- ELSEIF -- THEN -- ELSE --) to equivalent COND.") + [LAMBDA (FORM) (* bvm%: "21-Nov-86 18:09") + + (* ;; "Translates (IF -- THEN -- ELSEIF -- THEN -- ELSE --) to equivalent COND.") + (COND (DWIMIFYFLG (SETQ ATTEMPTFLG T) (SETQ CLISPCHANGE T))) @@ -3601,18 +4007,23 @@ with the terms of said license. (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST))) (SELECTQ (DWIMUNDOCATCH 'CLISPIF0 (SETQ TEM (CLISPIF0 FORM))) - (:RESPELL (* ;; "A misspelled IF word was detected. We now go through respellings and make any corrections that occur in FORM. Note that more than one correction may have been involved, e.g. IF FOO XTHENN PRINT X.") + (:RESPELL + (* ;; "A misspelled IF word was detected. We now go through respellings and make any corrections that occur in FORM. Note that more than one correction may have been involved, e.g. IF FOO XTHENN PRINT X.") + (COND ((CLISPELL FORM 'IFWORD) (SETQ NOFIXFNSLST0 FNSLST0) - (SETQ NOFIXVARSLST0 VARSLST0) (* ;; "The additions made to these lists may be wrong as a result of the misspelling of the IF word, e.g. a variaae kay have appeared in a function slot.") + (SETQ NOFIXVARSLST0 VARSLST0) + + (* ;; "The additions made to these lists may be wrong as a result of the misspelling of the IF word, e.g. a variaae kay have appeared in a function slot.") + (GO LP)))) - (NIL (* ; "error")) + (NIL (* ; "error")) (RETURN TEM)) (RETDWIM]) (CLISPIF0 - [LAMBDA (FORM) (* lmm " 4-SEP-83 22:54") + [LAMBDA (FORM) (* lmm " 4-SEP-83 22:54") (PROG (X Y PRED TEM L L0 L-1 CLAUSE DWIMIFYCHANGE $SIDES) (SETQ L FORM) [AND CLISPIFTRANFLG (SETQ Y (LIST (CONS (CAR L] @@ -3620,7 +4031,10 @@ with the terms of said license. LP (SELECTQ (CAR L) ((IF if) (COND - [(EQ L (CDR L-1)) (* ;; "No IF's should be seen after the initial one except when immediately following an ELSE. In this case the two words are treated the same as ELSEIF.") + [(EQ L (CDR L-1)) + + (* ;; "No IF's should be seen after the initial one except when immediately following an ELSE. In this case the two words are treated the same as ELSEIF.") + (SETQ PRED NIL) (COND (CLISPIFTRANFLG (OR [EQ (CAR L-1) @@ -3638,7 +4052,7 @@ with the terms of said license. Y)))) ((ELSE else) (SETQ X (NCONC1 X (CLISPIF1 PRED L0 L FORM))) - (SETQ L-1 L) (* ; "To enable ELSE IF as two words.") + (SETQ L-1 L) (* ; "To enable ELSE IF as two words.") (SETQ PRED T) (AND CLISPIFTRANFLG (SETQ Y (CONS (CONS (CAR L)) Y)))) @@ -3646,7 +4060,10 @@ with the terms of said license. [SETQ PRED (COND ((EQ L0 L) (GO ERROR)) - (T (* ;; "The reason for doing the LDIFF even when L is (CDR L0) is that can't just set pred to CAR of L is becuase then couldnt distinguish no predicate from IF NIL THEN -- (Actually encountered by one user.)") + (T + + (* ;; "The reason for doing the LDIFF even when L is (CDR L0) is that can't just set pred to CAR of L is becuase then couldnt distinguish no predicate from IF NIL THEN -- (Actually encountered by one user.)") + (LDIFF L0 L] [COND (CLISPIFTRANFLG (OR (LISTP (CAR Y)) @@ -3662,7 +4079,10 @@ with the terms of said license. (AND CLISPIFTRANFLG (SETQ Y (DREVERSE Y))) (/RPLNODE FORM 'COND X) [SETQ $SIDES (CDR (LISTGET1 LISPXHIST 'SIDE] - (SETQ L (CDR FORM)) (* ;; "The COND must appear in the original definition before DWIMIFYing can be done, or else correction of 8 and 9 errors won't work. Some unnecessary work may be done by virtue of DWIMIFYING the whole IF statement, even when it is being evaluated (as opposed to being dwimified). however, in most cases, if the user employs IF, there will be other CLISP constructs in the predicates and consequents.") + (SETQ L (CDR FORM)) + + (* ;; "The COND must appear in the original definition before DWIMIFYing can be done, or else correction of 8 and 9 errors won't work. Some unnecessary work may be done by virtue of DWIMIFYING the whole IF statement, even when it is being evaluated (as opposed to being dwimified). however, in most cases, if the user employs IF, there will be other CLISP constructs in the predicates and consequents.") + LP2 (SETQ CLAUSE (CAR L)) (COND [(LISTP (CAR CLAUSE)) @@ -3692,7 +4112,10 @@ with the terms of said license. (GO LP2))) (CLISPIF2 FORM) (COND - (CLISPIFTRANFLG (* ;; "Bletcherous PROG here because fool Interlisp-D compiler can't handle MAP2CAR right when inside a BLOCKS") + (CLISPIFTRANFLG + + (* ;; "Bletcherous PROG here because fool Interlisp-D compiler can't handle MAP2CAR right when inside a BLOCKS") + (PROG ((LF (CDR FORM)) (LY Y) (FIRSTP T) @@ -3711,16 +4134,19 @@ with the terms of said license. (SETQ FIRSTP) (GO LP)) (SETQ TEM (CONS (CAR FORM) - (CDR FORM))) (* ; - "the conditional expression, which is now in the function, and is going to be smashed") + (CDR FORM))) (* ; + "the conditional expression, which is now in the function, and is going to be smashed") (RPLNODE FORM (CAR X) - (CDR X)) (* ; - "puts the clisp back in /rplnode unnecessary since this was already saved above.") + (CDR X)) (* ; + "puts the clisp back in /rplnode unnecessary since this was already saved above.") [COND ((AND (EQ (CAAR $SIDES) FORM) (EQUAL (CAAR $SIDES) - (CDAR $SIDES))) (* ;; "so function wont be marked as changed reason for EQUAL check is if it was converted to lower case, than do want to retain side informaton.") + (CDAR $SIDES))) + + (* ;; "so function wont be marked as changed reason for EQUAL check is if it was converted to lower case, than do want to retain side informaton.") + (FRPLACA (CAR $SIDES) '*] (CLISPTRAN FORM TEM))) @@ -3729,7 +4155,7 @@ with the terms of said license. (DWIMERRORRETURN (LIST 4 L FORM]) (CLISPIF1 - [LAMBDA (PRED L0 L FORM) (* lmm "26-Jul-84 05:01") + [LAMBDA (PRED L0 L FORM) (* lmm "26-Jul-84 05:01") (COND (PRED (CONS (COND ((OR (NLISTP PRED) @@ -3737,7 +4163,10 @@ with the terms of said license. PRED) (T (CAR PRED))) (LDIFF L0 L))) - ((EQ L0 L) (* ;; "Note that ELSE or ELSEIF can imediately follow a THEN by virtue of the PRED check in earlier clause.") + ((EQ L0 L) + + (* ;; "Note that ELSE or ELSEIF can imediately follow a THEN by virtue of the PRED check in earlier clause.") + (DWIMERRORRETURN (LIST 4 L FORM))) ((EQ (CDR L0) L) @@ -3745,7 +4174,7 @@ with the terms of said license. (T (LIST (LDIFF L0 L]) (CLISPIF2 - [LAMBDA (X) (* lmm "16-Sep-85 18:15") + [LAMBDA (X) (* lmm "16-Sep-85 18:15") (PROG (TEM1 TEM2 TEM3) (COND ((NEQ (CAR X) @@ -3754,21 +4183,24 @@ with the terms of said license. X) (EQ (CAR TEM1) T) - (NULL (CDDR TEM1))) (* ;; "Changes expression of X (COND -- (T (COND **))) to (COND -- **) useful for producing more aesthetic code when the 'DO' portion of a 'FOR' statement is an 'IF' Converts") + (NULL (CDDR TEM1))) + + (* ;; "Changes expression of X (COND -- (T (COND **))) to (COND -- **) useful for producing more aesthetic code when the 'DO' portion of a 'FOR' statement is an 'IF' Converts") + (/RPLNODE TEM2 (CADR X) (CDDR X))) ((AND (EQ (CAR TEM1) T) (EQ [CADR (LISTP (SETQ TEM3 (CAR (SETQ TEM2 (NLEFT X 2] X) - (NULL (CDDR TEM2))) (* ; - "Converts expression of X (COND (& (COND --)) (T **)) to (COND ((NEGATION &) **) --)") + (NULL (CDDR TEM2))) (* ; + "Converts expression of X (COND (& (COND --)) (T **)) to (COND ((NEGATION &) **) --)") (/RPLNODE TEM1 (CAR TEM3) (CDR TEM1)) (/RPLNODE TEM2 TEM1 (CDADR TEM3]) (CLISPIF3 - [LAMBDA (CLAUSE ORIGWORDPAIR FIRSTCLAUSEFLG) (* JonL "22-APR-83 19:46") + [LAMBDA (CLAUSE ORIGWORDPAIR FIRSTCLAUSEFLG) (* JonL "22-APR-83 19:46") (PROG NIL (RETURN (CONS [COND [FIRSTCLAUSEFLG (COND @@ -3798,9 +4230,10 @@ with the terms of said license. (DEFINEQ (CLISPFOR - [LAMBDA (FORM) (* bvm%: "21-Nov-86 18:10") - (* ;; - "Translates iterative statements, e.g., (for X in Y until --)") + [LAMBDA (FORM) (* bvm%: "21-Nov-86 18:10") + + (* ;; "Translates iterative statements, e.g., (for X in Y until --)") + (COND (DWIMIFYFLG (SETQ ATTEMPTFLG T) (SETQ CLISPCHANGE T))) @@ -3813,11 +4246,13 @@ with the terms of said license. (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST))) (SELECTQ (DWIMUNDOCATCH 'CLISPFOR0 (SETQ TEM (CLISPFOR0 FORM))) - (:RESPELL (* ;; "A misspelled I.S. word was detected. We now go through respellings and make any corrections that occur in FORM. Note that more than one correction may have been involved, e.g. FOR X IN YWHILLE Z FOO XTHENN PRINT X.") + (:RESPELL + (* ;; "A misspelled I.S. word was detected. We now go through respellings and make any corrections that occur in FORM. Note that more than one correction may have been involved, e.g. FOR X IN YWHILLE Z FOO XTHENN PRINT X.") + (COND ((CLISPELL FORM 'FORWORD) (GO LP)))) - (NIL (* ; "error")) + (NIL (* ; "error")) (RETURN TEM)) (RETURN]) @@ -3904,7 +4339,7 @@ with the terms of said license. [COND [(NULL (CAR I.S.OPR)) - (* ;; "The i.s.type does not define the i.s.type for the i.s. e.g. Larry's UPTO which is defined as (BIND $$MAX_BODY TO $$MAX)") + (* ;; "The i.s.type does not define the i.s.type for the i.s. e.g. Larry's UPTO which is defined as (BIND $$MAXâ†BODY TO $$MAX)") (COND ((NULL (CDR I.S.OPR)) @@ -4240,7 +4675,7 @@ with the terms of said license. 'SETQ) (EQ (CAR TEM) 'SETQQ)) (* ; - "IN OLD X _ .. or IN (OLD X _ ..), or IN OLD (X _ ..) or IN (OLD (X _ ..))") + "IN OLD X ↠.. or IN (OLD X ↠..), or IN OLD (X ↠..) or IN (OLD (X ↠..))") (CLISPFORINITVAR (SETQ LSTVAR (CADR TEM)) (CADDR TEM))) (T (SHOULDNT 'CLISPFOR0] @@ -4424,12 +4859,17 @@ with the terms of said license. (RETURN EXP]) (CLISPFOR0A - [LAMBDA ($I.S.OPR I.S. LASTPTR) (* rmk%: " 6-Oct-84 12:11") - (* ;; "Thisfunction is called when we hit the first i.s.opr following one defined via an istype property. The problems with such operaaors is that we cannot dwiify their operands (or any operands in the i.s.) until we have scanned the entire i.s. and found aal the VARS. This requires that we obtain the definitions of each i.s.opr from its property list, since there may be BIND's in the defiition. However, we cannot substiute in the operands until after we dwimify the operands, since otherwise any errors corrected in the operands wont be seen in the original i.s. when the user prints it after it is dwimified. Furthermore, if we substitute in before we dwimify, we cant distinguish the case where the usr writes a $$VAL, thereby requiring a PROG in the translation, from that where a $$VAL is specified in the definition for the i.s.opr e.g. for COLLECT or JOIN, but nevertheless it is ok to translate to a mapping function. Therefore we insert the definition and take note of thoe things requiring substiution later. and furthermore leave in the original i.s.opr so its operand can also be dwimified.") - (DECLARE (SPECVARS LASTPTR)) (* ; - "Used freely by IS.OPRS in IDL -- Ron") + [LAMBDA ($I.S.OPR I.S. LASTPTR) (* rmk%: " 6-Oct-84 12:11") + + (* ;; "Thisfunction is called when we hit the first i.s.opr following one defined via an istype property. The problems with such operaaors is that we cannot dwiify their operands (or any operands in the i.s.) until we have scanned the entire i.s. and found aal the VARS. This requires that we obtain the definitions of each i.s.opr from its property list, since there may be BIND's in the defiition. However, we cannot substiute in the operands until after we dwimify the operands, since otherwise any errors corrected in the operands wont be seen in the original i.s. when the user prints it after it is dwimified. Furthermore, if we substitute in before we dwimify, we cant distinguish the case where the usr writes a $$VAL, thereby requiring a PROG in the translation, from that where a $$VAL is specified in the definition for the i.s.opr e.g. for COLLECT or JOIN, but nevertheless it is ok to translate to a mapping function. Therefore we insert the definition and take note of thoe things requiring substiution later. and furthermore leave in the original i.s.opr so its operand can also be dwimified.") + + (DECLARE (SPECVARS LASTPTR)) (* ; + "Used freely by IS.OPRS in IDL -- Ron") [COND - ((CDR (LISTP $I.S.OPR)) (* ;; "OTHERS. Note that an i.s.opr defned by an i.s.opr property can specify an i.s.type, OTHERS, or both.") + ((CDR (LISTP $I.S.OPR)) + + (* ;; "OTHERS. Note that an i.s.opr defned by an i.s.opr property can specify an i.s.type, OTHERS, or both.") + (SETQ I.S.OPRSLST (CONS LASTPTR I.S.OPRSLST)) (SETQ I.S. (NCONC [COPY (COND ((EQ (CADR $I.S.OPR) @@ -4440,17 +4880,20 @@ with the terms of said license. I.S.]) (CLISPFOR1 - [LAMBDA (PTRS FLG) (* wt%: "28-APR-80 16:11") + [LAMBDA (PTRS FLG) (* wt%: "28-APR-80 16:11") (PROG ((OPRTAIL (CADAR PTRS)) BODYTAIL (NXTOPRTAIL (CADDAR PTRS)) - Z TEM LSTFLG BODY) (* ;; "X is the TAIL of the iterative statement beginning with the operator, Y the tail beginning with the next opeator.") + Z TEM LSTFLG BODY) + + (* ;; "X is the TAIL of the iterative statement beginning with the operator, Y the tail beginning with the next opeator.") + (SELECTQ (CAAR PTRS) ((FOR BIND DECLARE ORIGINAL NIL) (GO OUT)) ((IN ON) (AND (NULL FLG) - (GO OUT)) (* ; "Already done.") + (GO OUT)) (* ; "Already done.") ) (AS (SETQ I.V. (CADDDR (CAR PTRS))) (GO OUT)) @@ -4470,14 +4913,16 @@ with the terms of said license. 'MODIFIER)) (CDDR OPRTAIL)) ((CDR OPRTAIL)) - (T (* ;; "special kluge to allow an i.s.opr to smash lastptr to indicate that this operator/operand is to be ignored, e.g. for handling (EVERY CHARACTER IN Z IS --)") + (T + (* ;; "special kluge to allow an i.s.opr to smash lastptr to indicate that this operator/operand is to be ignored, e.g. for handling (EVERY CHARACTER IN Z IS --)") + (GO OUT] (COND - ((EQ BODYTAIL NXTOPRTAIL) (* ; "2 FORWORDS in a row.") + ((EQ BODYTAIL NXTOPRTAIL) (* ; "2 FORWORDS in a row.") (CLISPFORERR OPRTAIL NXTOPRTAIL 'MISSING)) ((NEQ (CDR BODYTAIL) - NXTOPRTAIL) (* ; - "More than one expression between two forwords.") + NXTOPRTAIL) (* ; + "More than one expression between two forwords.") (GO BREAK))) [COND ((NLISTP (CAR BODYTAIL)) @@ -4491,7 +4936,7 @@ with the terms of said license. (NEQ (CAAR PTRS) 'TO) (SETQ Z (CLISPFUNCTION? BODYTAIL 'NOTVAR] - (* ; "E.G. DO PRINT, BY SUB1, etc.") + (* ; "E.G. DO PRINT, BY SUB1, etc.") [COND ((NULL (SETQ TEM (OR FIRSTI.V. I.V.))) (CLISPFORERR OPRTAIL NIL 'WHAT)) @@ -4499,8 +4944,8 @@ with the terms of said license. ((EQ OPRTAIL I.S.TYPE) TEM) (T (SETQ TEM I.V.))) - (CAR DUMMYVARS)) (* ; - "In the case that an i.v. was supplied, make the change permanent. For $$TEM, undo it later.") + (CAR DUMMYVARS)) (* ; + "In the case that an i.v. was supplied, make the change permanent. For $$TEM, undo it later.") (SETQ UNDOLST (CONS (CONS BODYTAIL (CONS (CAR BODYTAIL) (CDR BODYTAIL))) UNDOLST] @@ -4532,40 +4977,53 @@ with the terms of said license. (COND (NXTOPRTAIL (CLISPRPLNODE (SETQ Z (NLEFT OPRTAIL 1 NXTOPRTAIL)) (CAR Z) - NIL))) (* ; - "Breaks the list justbefore the next operator.") + NIL))) (* ; + "Breaks the list justbefore the next operator.") (CLISPRPLNODE BODYTAIL (SETQ Z (CONS (CAR BODYTAIL) (CDR BODYTAIL))) - NXTOPRTAIL) (* ;; "Puts parentheses in --- E.g. For X in FOO Y do -- becomes for X in (FOO Y) do necessary in order to call DWIMIFY. Maybe should give DWIMIFY an rgument like stoptail?") - (* ;; "Done this way instead of changing CDR X because CDR of first PTR is not EQ to the entry in the history list.") + NXTOPRTAIL) + + (* ;; "Puts parentheses in --- E.g. For X in FOO Y do -- becomes for X in (FOO Y) do necessary in order to call DWIMIFY. Maybe should give DWIMIFY an rgument like stoptail?") + + (* ;; "Done this way instead of changing CDR X because CDR of first PTR is not EQ to the entry in the history list.") + [DWIMIFY2 Z Z T (COND (I.S.TYPE 'IFWORD) - (T (* ; - "so if it sees a function in a variable position, it will insert parens, e.g. FOR X IN Y PRINT Z") + (T (* ; + "so if it sees a function in a variable position, it will insert parens, e.g. FOR X IN Y PRINT Z") 'FORWORD] A (COND - ((NULL (CDR Z)) (* ;; "Because DWIMIFY2 was called with FORMSFLG T, this came out as a list of forms, but there was only one form. E.g. X_ (FOO) became ((SETQ X (FOO))).") + ((NULL (CDR Z)) + + (* ;; "Because DWIMIFY2 was called with FORMSFLG T, this came out as a list of forms, but there was only one form. E.g. X↠(FOO) became ((SETQ X (FOO))).") + (/RPLNODE Z (CAAR Z) (CDAR Z)) (GO C))) B [SELECTQ (CAAR PTRS) - ((I.S.TYPE FIRST FINALLY EACHTIME) (* ; - "More than one form permitted in operator --- means implicit progn.") + ((I.S.TYPE FIRST FINALLY EACHTIME) (* ; + "More than one form permitted in operator --- means implicit progn.") (SETQ UNDOLST (CONS (CONS OPRTAIL (CONS (CAR OPRTAIL) (CDR OPRTAIL))) UNDOLST)) - (SETQ BODY (CONS 'PROGN (APPEND Z))) (* ; - "for possible use in substituting into an i.s.opr") + (SETQ BODY (CONS 'PROGN (APPEND Z))) (* ; + "for possible use in substituting into an i.s.opr") (CLISPRPLNODE OPRTAIL (CDR BODY) - (CDR OPRTAIL)) (* ;; "Smashes the operatr itself with the body of i.s. so that when we get back to clispfor0, can distinguish the implicit progn case from others. The setting of UNDOLST is to enable restoration.") + (CDR OPRTAIL)) + + (* ;; "Smashes the operatr itself with the body of i.s. so that when we get back to clispfor0, can distinguish the implicit progn case from others. The setting of UNDOLST is to enable restoration.") + [AND (NULL LSTFLG) (CLISPRPLNODE BODYTAIL (CAR Z) (NCONC (CDR Z) - (CDR BODYTAIL] (* ; "Takes parentheses back out.") + (CDR BODYTAIL] (* ; "Takes parentheses back out.") (GO C)) (COND [(FMEMB (CAR PTRS) - I.S.OPRSLST) (* ;; "ok for a user defined opeator to have several arguments. (maybe we should phase out the errors and insertion of automatic DO??)") + I.S.OPRSLST) + + (* ;; "ok for a user defined opeator to have several arguments. (maybe we should phase out the errors and insertion of automatic DO??)") + (SETQ BODY (CONS 'PROGN (APPEND Z))) (SETQ UNDOLST (CONS (CONS OPRTAIL (CONS (CAR OPRTAIL) (CDR OPRTAIL))) @@ -4578,9 +5036,9 @@ with the terms of said license. (LSTFLG (CLISPFORERR OPRTAIL)) (I.S.TYPE (CLISPFORERR I.S.TYPE BODYTAIL)) ((EVERY (CDR Z) - (FUNCTION LISTP)) (* ; "E.g. For X in Y print Z --.") - (* ; - "This really should be taken care of in DWIMIFY2 --- I.e. (Y prinnt Z)") + (FUNCTION LISTP)) (* ; "E.g. For X in Y print Z --.") + (* ; + "This really should be taken care of in DWIMIFY2 --- I.e. (Y prinnt Z)") (/RPLNODE BODYTAIL (CAR Z) (/NCONC (CDR Z) NXTOPRTAIL)) @@ -4593,22 +5051,24 @@ with the terms of said license. (CLISPFOR4 Z)) [COND ((FMEMB (CAR PTRS) - I.S.OPRSLST) (* ; - "I.S.OPRLST is the list of those entries on forptrs defined by an I.S.OPR.") + I.S.OPRSLST) (* ; + "I.S.OPRLST is the list of those entries on forptrs defined by an I.S.OPR.") (RETURN (PROG ((END (CADDAR PTRS)) LST) [OR BODY (COND ((EQ (CAR (GETPROP (CADR (SETQ BODY (CADAR PTRS))) 'CLISPWORD)) - 'FORWORD) (* ; "modifier") + 'FORWORD) (* ; "modifier") (SETQ BODY (CADDR BODY))) (T (SETQ BODY (CADR BODY] - (* ;; "BODY is the operand to the I.S.OPR operator. END is the tail of the i.s. beginning with the next operator following it. The in between operators are the result of the expansion, and need to be dwiified, i.e. processed by clispfor1, and then have i.v. and body substituted into them.") + + (* ;; "BODY is the operand to the I.S.OPR operator. END is the tail of the i.s. beginning with the next operator following it. The in between operators are the result of the expansion, and need to be dwiified, i.e. processed by clispfor1, and then have i.v. and body substituted into them.") + (SETQ LST (CDR PTRS)) LP1 (COND ((NEQ (CADAR LST) - END) (* ; - "CADR of each entry on PTRS is the actual tail.") + END) (* ; + "CADR of each entry on PTRS is the actual tail.") (SETQ LST (CLISPFOR1 LST)) (GO LP1))) (SETQ LST (CDR PTRS)) @@ -4616,9 +5076,11 @@ with the terms of said license. ((NEQ (CADAR LST) END) (PROG ((LST1 (CADAR LST)) - (END1 (CADDAR LST))) (* ; - "The tail of the iterative statement begining with the opeator") - (* ;; "tail of iterative statement beginning with next operator the segment between tem and nxt corresponds to the body of this opeator") + (END1 (CADDAR LST))) (* ; + "The tail of the iterative statement begining with the opeator") + + (* ;; "tail of iterative statement beginning with next operator the segment between tem and nxt corresponds to the body of this opeator") + LP3 (COND ((EQ (SETQ LST1 (CDR LST1)) END1) @@ -4635,9 +5097,10 @@ with the terms of said license. OUT (RETURN (CDR PTRS]) (CLISPRPLNODE - [LAMBDA (X A D) (* wt%: 16-DEC-75 23 43) - (* ;; - "like /rplnode, except that dwimnewfile? does not count it as a change to the function") + [LAMBDA (X A D) (* wt%: 16-DEC-75 23 43) + + (* ;; "like /rplnode, except that dwimnewfile? does not count it as a change to the function") + (COND ((LISTP X) [AND LISPXHIST (UNDOSAVE (LIST 'CLISPRPLNODE X (CAR X) @@ -4647,12 +5110,15 @@ with the terms of said license. (T (ERRORX (LIST 4 X]) (CLISPFOR2 - [LAMBDA (LST FLG) (* lmm "13-Aug-84 16:42") + [LAMBDA (LST FLG) (* lmm "13-Aug-84 16:42") [MAP (SETQ LST (DREVERSE LST)) (FUNCTION (LAMBDA (X) (SELECTQ (CAAR X) (WHEN [RPLACA X (COND - (FLG (* ;; "When FLG is true, we are computing a condition forDOING it, and when FLG=NIL, for not doing it, hence difference in sign.") + (FLG + + (* ;; "When FLG is true, we are computing a condition forDOING it, and when FLG=NIL, for not doing it, hence difference in sign.") + (CADADR (CAR X))) (T (NEGATE (CADADR (CAR X]) (UNLESS [RPLACA X (COND @@ -4666,9 +5132,11 @@ with the terms of said license. LST]) (CLISPFOR3 - [LAMBDA (LST) (* wt%: 25-FEB-76 1 59) - (* ;; - "Used to process FINALLY, EACHTIME, and FIRST lists. LST is a list of form (FINALLY . tail)") + [LAMBDA (LST) (* wt%: 25-FEB-76 1 59) + + (* ;; + "Used to process FINALLY, EACHTIME, and FIRST lists. LST is a list of form (FINALLY . tail)") + (PROG (TEM) (RETURN (MAPCONC (DREVERSE LST) (FUNCTION (LAMBDA (X) @@ -4677,11 +5145,13 @@ with the terms of said license. (LIST (CADR TEM]) (CLISPFORVARS - [LAMBDA (PTRS) (* lmm "20-Jul-86 12:40") - (* ;; "Does for FOR and BIND what CLISPFOR1 does for the rest of the ptrs. LST is either a (FOR --) or (BIND --) entry from PTRS. CLISPFOR3 handles the following pathological cases. The variables may be spread out, or listed, they may involve assignments, either spread out or listed, and they may be terminated by a form or function in the case that there is no FOROPR. E.g. FOR X Y Z (PRINT X), FOR (X Y Z) PRINT X, FOR X Y _ T Z PRINTT X, FOR (X (Y_T) Z) (PRINT X) etc.") + [LAMBDA (PTRS) (* lmm "20-Jul-86 12:40") + + (* ;; "Does for FOR and BIND what CLISPFOR1 does for the rest of the ptrs. LST is either a (FOR --) or (BIND --) entry from PTRS. CLISPFOR3 handles the following pathological cases. The variables may be spread out, or listed, they may involve assignments, either spread out or listed, and they may be terminated by a form or function in the case that there is no FOROPR. E.g. FOR X Y Z (PRINT X), FOR (X Y Z) PRINT X, FOR X Y ↠T Z PRINTT X, FOR (X (Yâ†T) Z) (PRINT X) etc.") + (PROG (TEM OLDFLG LST LST0 L1 VARLST IV (CLISPCONTEXT 'FOR/BIND)) - (* ; - "clispcontext tells CLISPATOM2 not to try spelling correction on the variable name.") + (* ; + "clispcontext tells CLISPATOM2 not to try spelling correction on the variable name.") (SETQ L1 (CADDR (CAR PTRS))) [SETQ LST0 (SETQ LST (CDR (CADAR PTRS] LP (COND @@ -4690,7 +5160,7 @@ with the terms of said license. (COND ((LITATOM (CAR LST0)) (SELECTQ (CADR LST0) - ((_ ¬) + ((↠_) (RPLACA LST0 (LIST 'SETQ (CAR LST0) (CADDR LST0))) (RPLACD LST0 (CDDDR LST0)) @@ -4701,8 +5171,8 @@ with the terms of said license. (SETQ LST0 TEM))) [(LISTP (CAR LST0)) (SELECTQ (CAAR LST0) - ((SETQQ SAVESETQQ) (* ; - "SAVESETQ and SAVESETQQ can occur on typein if the user should happen to DW a portion of the I.s.") + ((SETQQ SAVESETQQ) (* ; + "SAVESETQ and SAVESETQQ can occur on typein if the user should happen to DW a portion of the I.s.") ) ((SETQ SAVESETQ) (DWIMIFY2 (CDDAR LST0) @@ -4710,9 +5180,9 @@ with the terms of said license. T)) (COND ((AND (OR (EQ (CADAR LST0) - '_) + 'â†) (EQ (CADAR LST0) - '¬)) + '_)) (NULL (CDDDAR LST0))) [FRPLACA LST0 (CONS 'SETQ (CONS (CAAR LST0) (CDDAR LST0] @@ -4727,22 +5197,33 @@ with the terms of said license. (SETQ X (CDR X)) (GO LX))) (CLISPFORVARS1 (CAR LST0) - (EQ L1 (CDR LST))) (* ;; "The second argument to CLISPFORVARS1 corresonds to FORMSFLG in the call to DWIMIFY2, e.g. FOR X (Y_T) want FORMSFLG to be NIL. but FOR (X_T Y) want it to be T.") + (EQ L1 (CDR LST))) + + (* ;; "The second argument to CLISPFORVARS1 corresonds to FORMSFLG in the call to DWIMIFY2, e.g. FOR X (Yâ†T) want FORMSFLG to be NIL. but FOR (Xâ†T Y) want it to be T.") + (COND ((AND (LISTP (CAAR LST0)) - (NULL (CDAR LST0))) (* ;; "form was (A_form) and now is ((SETQ A form)) so remove extra parentheses inserted because formsflg was (incorrectly) T. Note that when we called clispforvars1, we donot know whether (CAR LST0) is of the form (A_B C_D) or (A _ B), i.e. one or two assignments.") + (NULL (CDAR LST0))) + + (* ;; "form was (Aâ†form) and now is ((SETQ A form)) so remove extra parentheses inserted because formsflg was (incorrectly) T. Note that when we called clispforvars1, we donot know whether (CAR LST0) is of the form (Aâ†B Câ†D) or (A ↠B), i.e. one or two assignments.") + (FRPLACA LST0 (CAAR LST0] ((AND (EQ LST0 LST) - (EQ L1 (CDR LST0))) (* ; "Says this is the first argument.") + (EQ L1 (CDR LST0))) (* ; "Says this is the first argument.") (CLISPFORVARS1 (CAR LST0) T)) (I.S.TYPE (CLISPFORERR LST0 I.S.TYPE)) - (T (* ;; "Necessary because LST0 may not really correspnd to ssructure in the original statement, because of ldiff.") + (T + (* ;; "Necessary because LST0 may not really correspnd to ssructure in the original statement, because of ldiff.") + (GO ADDDO] (T (CLISPFORERR LST0))) (SETQ LST0 (CDR LST0)) (GO LP) - NX (* ;; "The area between LST and LST0 now corresponds to the (dwimified) variables. They may appears as a segment or as a list.") + NX + + (* ;; "The area between LST and LST0 now corresponds to the (dwimified) variables. They may appears as a segment or as a list.") + (SETQ LST0 (COND ([AND (EQ LST0 (CDR LST)) (LISTP (CAR LST)) @@ -4750,15 +5231,18 @@ with the terms of said license. '(SETQ SETQQ OLD old SAVESETQ SAVESETQQ] (SETQ L1 NIL) (CAR LST)) - (T LST))) (* ;; "LST0 now corresponds to the beginning of the list of variables, L1 to its end. VARLST will be used to assemble the vlue.") + (T LST))) + + (* ;; "LST0 now corresponds to the beginning of the list of variables, L1 to its end. VARLST will be used to assemble the vlue.") + LP1 [COND ((EQ LST0 L1) [COND ((AND IV (NEQ (CAAR PTRS) 'BIND) (NULL I.V.)) - (SETQ FIRSTI.V. (SETQ I.V. IV] (* ; - "IV is the first variable encountered in the variable list (may be OLD vriable)") + (SETQ FIRSTI.V. (SETQ I.V. IV] (* ; + "IV is the first variable encountered in the variable list (may be OLD vriable)") (RETURN (DREVERSE VARLST))) ((FMEMB (CAR LST0) '(OLD old)) @@ -4783,7 +5267,10 @@ with the terms of said license. ((EQ (CAAR PTRS) 'AS) (FRPLACD (CDDAR PTRS) - (LIST IV] (* ;; "Marks the i.v. for this AS. used by clispfor11 when you specify an operatand which is just a functon name.") + (LIST IV] + + (* ;; "Marks the i.v. for this AS. used by clispfor11 when you specify an operatand which is just a functon name.") + )) (COND ((NULL OLDFLG) @@ -4797,8 +5284,8 @@ with the terms of said license. (LIST 'QUOTE (CADDR TEM))) T) NIL) - (SETQ MAKEPROGFLG T) (* ; - "Says the expression must translate into an open prog.") + (SETQ MAKEPROGFLG T) (* ; + "Says the expression must translate into an open prog.") (SETQ VARS (CONS (CADR TEM) VARS)) [COND @@ -4832,7 +5319,7 @@ with the terms of said license. (GO NX]) (CLISPFORVARS1 - [LAMBDA (L FLG) (* lmm "21-Jun-85 16:59") + [LAMBDA (L FLG) (* lmm "21-Jun-85 16:59") (PROG ($TAIL) (SETQ $TAIL L) LP [COND @@ -4848,7 +5335,7 @@ with the terms of said license. (GO LP]) (CLISPFOR4 - [LAMBDA (X) (* wt%: 17-DEC-76 19 8) + [LAMBDA (X) (* wt%: 17-DEC-76 19 8) (SELECTQ (CAR X) ((GO RETURN ERROR! RETFROM RETEVAL) (SETQ TERMINATEFLG T) @@ -4857,21 +5344,24 @@ with the terms of said license. (SOME X (FUNCTION (LAMBDA (X) (COND ((EQ X '$$VAL) - (SETQ MAKEPROGFLG T) (* ; "keep on looking for RETURN or GO") + (SETQ MAKEPROGFLG T) (* ; "keep on looking for RETURN or GO") NIL) ((LISTP X) (CLISPFOR4 X]) (CLISPFORF/L - [LAMBDA (EXP VAR DECLARELST) (* lmm "29-Jul-86 00:24") - (* ;; - "Build the FUNCTIONal expression to be executed as the MAPFN for the FOR loop") + [LAMBDA (EXP VAR DECLARELST) (* lmm "29-Jul-86 00:24") + + (* ;; "Build the FUNCTIONal expression to be executed as the MAPFN for the FOR loop") + (LIST 'FUNCTION (COND - (NIL (* ;; "This originally tried to elimate the dummy variable when the FOR was a unary function, but in this case, there was still a problem --- thus this is commented out") + (NIL + (* ;; "This originally tried to elimate the dummy variable when the FOR was a unary function, but in this case, there was still a problem --- thus this is commented out") + (CAAR EXP)) - (T (* ; - "Otherwise, build a LAMBDA expression that contains all the expressions to be evaluated.") + (T (* ; + "Otherwise, build a LAMBDA expression that contains all the expressions to be evaluated.") `(LAMBDA ,VAR ,@[AND DECLARELST `((DECLARE ,@(MAPCONC (DREVERSE DECLARELST) (FUNCTION (LAMBDA (X) @@ -4880,8 +5370,11 @@ with the terms of said license. ,@EXP]) (CLISPDSUBST - [LAMBDA (X) (* wt%: "21-JAN-80 20:11") - (PROG (TEM) (* ;; "goes through X and does a dsubst of I.V. for (QUOTE I.V.) and BODY for (QUOTE BODY) in X AND all of the translations in the hasharray") + [LAMBDA (X) (* wt%: "21-JAN-80 20:11") + (PROG (TEM) + + (* ;; "goes through X and does a dsubst of I.V. for (QUOTE I.V.) and BODY for (QUOTE BODY) in X AND all of the translations in the hasharray") + [MAP X (FUNCTION (LAMBDA (X) (SELECTQ (CAR X) (BODY (FRPLACA X BODY)) @@ -4893,13 +5386,16 @@ with the terms of said license. (COND ((EQ (CAR (GETP (CAR X) 'CLISPWORD)) - 'CHANGETRAN) (* ;; "these constructs have the property that translation differs depending on expression, e.g. while (fetch foo of x) is always the same regardless of what x is, (change x y) differs depending on what x is.") + 'CHANGETRAN) + + (* ;; "these constructs have the property that translation differs depending on expression, e.g. while (fetch foo of x) is always the same regardless of what x is, (change x y) differs depending on what x is.") + (PUTHASH X NIL CLISPARRAY) (DWIMIFY1 X)) (T (CLISPDSUBST TEM]) (GETDUMMYVAR - [LAMBDA (BINDITFLG) (* lmm "28-MAY-83 18:01") + [LAMBDA (BINDITFLG) (* lmm "28-MAY-83 18:01") (PROG (VAR) [SETQ VAR (CAR (SETQ DUMMYVARS (OR (CDR DUMMYVARS) (CDR (RPLACD DUMMYVARS (LIST (GENSYM] @@ -4909,8 +5405,10 @@ with the terms of said license. (RETURN VAR]) (CLISPFORINITVAR - [LAMBDA (VAR EXP) (* wt%: "21-JAN-80 20:44") - (* ;; "this function is called when is necessary to initialize a variable to an expression outside of tje scope of anyvariables bound by i.s., i.e. in the prog binding. it generates a dummy variabe, binds it to exp, and then initializes var to that expresssin") + [LAMBDA (VAR EXP) (* wt%: "21-JAN-80 20:44") + + (* ;; "this function is called when is necessary to initialize a variable to an expression outside of tje scope of anyvariables bound by i.s., i.e. in the prog binding. it generates a dummy variabe, binds it to exp, and then initializes var to that expresssin") + (SETQ PROGVARS (CONS (LIST (GETDUMMYVAR) EXP) PROGVARS)) @@ -4919,7 +5417,7 @@ with the terms of said license. (DEFINEQ (\DURATIONTRAN - [LAMBDA (FORM) (* JonL "23-Jul-84 15:39") + [LAMBDA (FORM) (* JonL "23-Jul-84 15:39") (PROG ((BODY FORM) (OLDTIMER) (EXPANSION) @@ -4927,7 +5425,10 @@ with the terms of said license. (EXPIREDFORM '(TIMEREXPIRED? \DurationLimit . TIMERUNITSLST)) USINGTIMER USINGBOX FORDURATION RESOURCENAME UNTILDATE TIMERUNITS TIMERUNITSLST TEMP) (DECLARE (SPECVARS TIMERUNITS USINGTIMER USINGBOX FORDURATION RESOURCENAME UNTILDATE) - (GLOBALVARS DURATIONCLISPWORDS LCASEFLG)) (* ;; "DURATIONCLISPWORDS is a list of lists, each one of which has the canonical word for some CLISPWORD as second element. First element is the all-caps version, so that SPECVARS communication can take place.") + (GLOBALVARS DURATIONCLISPWORDS LCASEFLG)) + + (* ;; "DURATIONCLISPWORDS is a list of lists, each one of which has the canonical word for some CLISPWORD as second element. First element is the all-caps version, so that SPECVARS communication can take place.") + (PROG ((L DURATIONCLISPWORDS) (Z BODY)) LP (AND (NLISTP L) @@ -4946,7 +5447,7 @@ with the terms of said license. )) (SETQ USINGTIMER USINGBOX))) [COND - ((NULL TIMERUNITS) (* ; "Standard case") + ((NULL TIMERUNITS) (* ; "Standard case") NIL) (UNTILDATE (ERROR "Can't specify timerUnits for 'untilDate'" FORM)) [(SETQ TEMP (CONSTANTEXPRESSIONP TIMERUNITS)) @@ -4962,23 +5463,25 @@ with the terms of said license. ((AND FORDURATION UNTILDATE) (ERROR "Both 'untilDate' and 'forDuration' specified" FORM))) [COND - (UNTILDATE (SETQ FORDURATION UNTILDATE) (* ; - "Make the 'interval' be the thing supplied for the 'date'") + (UNTILDATE (SETQ FORDURATION UNTILDATE) (* ; + "Make the 'interval' be the thing supplied for the 'date'") (SETQ SETUPFORM '(SETUPTIMER.DATE FORDURATION OLDTIMER)) (SETQ TIMERUNITSLST '('SECONDS] (COND - ([AND (PROG1 RESOURCENAME (* ; "Comment PPLossage")) + ([AND (PROG1 RESOURCENAME (* ; "Comment PPLossage")) (NOT (\TIMER.TIMERP (EVAL (LISTGET (GETDEF RESOURCENAME 'RESOURCES NIL 'NOERROR) 'NEW] (ERROR RESOURCENAME "is not a timer RESOURCE"))) - (SETQ EXPANSION (LIST [LIST 'LAMBDA '(\DurationLimit) '(DECLARE (LOCALVARS \DurationLimit)) + (SETQ EXPANSION (LIST [LIST 'LAMBDA '(\DurationLimit) + '(DECLARE (LOCALVARS \DurationLimit)) (CONS 'until (CONS EXPIREDFORM 'BODY] SETUPFORM)) [AND (LISTP (CAR TIMERUNITSLST)) (NEQ (CAAR TIMERUNITSLST) 'QUOTE) - (SETQ EXPANSION (LIST (LIST 'LAMBDA '(\TimerUnit) '(DECLARE (LOCALVARS \TimerUnit)) + (SETQ EXPANSION (LIST (LIST 'LAMBDA '(\TimerUnit) + '(DECLARE (LOCALVARS \TimerUnit)) EXPANSION) (CAR TIMERUNITSLST))) (SETQ TIMERUNITSLST '(\TimerUnit] @@ -5004,8 +5507,10 @@ with the terms of said license. (RETURN EXPANSION]) (\CLISPKEYWORDPROCESS - [LAMBDA (FORM WORDLST) (* JonL "27-APR-83 04:39") - (* ;; "Looks for the first 'keyword' in the list FORM which is mentioned in the WORDLST -- and if one is found, the the first keyword in WORDLST is presumed to be the name of a variable to be set to the keyword's value. Returns the original list with the keyword pair non-destructively spliced out.") + [LAMBDA (FORM WORDLST) (* JonL "27-APR-83 04:39") + + (* ;; "Looks for the first 'keyword' in the list FORM which is mentioned in the WORDLST -- and if one is found, the the first keyword in WORDLST is presumed to be the name of a variable to be set to the keyword's value. Returns the original list with the keyword pair non-destructively spliced out.") + (COND ((NULL FORM) NIL) @@ -5064,14 +5569,16 @@ with the terms of said license. (RETURN UNDOTEM)))) ) ) -(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY -(BLOCK%: FORBLOCK (ENTRIES CLISPFOR) - CLISPFORVARS CLISPFOR0 CLISPFOR2 CLISPFORINITVAR CLISPDSUBST \CLISPKEYWORDPROCESS CLISPFORF/L - CLISPFOR4 CLISPFORVARS1 CLISPFOR3 CLISPFOR1 CLISPFOR0A CLISPFOR \DURATIONTRAN - (SPECVARS UNDOSIDE LISPXHIST BODY I.S.TYPE1 I.S.TYPE TERMINATEFLG FIRSTI.V. I.V. PROGVARS - MAKEPROGFLG IVINITFLG INITVARS UNDOLST DWIMIFYING VARS DWIMIFYCHANGE DUMMYVARS - I.S.OPRSLST CLISPCONTEXT UNDOSIDE0 EXP)) + + +(* BLOCKS (FORBLOCK (ENTRIES CLISPFOR) CLISPFORVARS CLISPFOR0 CLISPFOR2 CLISPFORINITVAR CLISPDSUBST +\CLISPKEYWORDPROCESS CLISPFORF/L CLISPFOR4 CLISPFORVARS1 CLISPFOR3 CLISPFOR1 CLISPFOR0A CLISPFOR +\DURATIONTRAN (SPECVARS UNDOSIDE LISPXHIST BODY I.S.TYPE1 I.S.TYPE TERMINATEFLG FIRSTI.V. I.V. +PROGVARS MAKEPROGFLG IVINITFLG INITVARS UNDOLST DWIMIFYING VARS DWIMIFYCHANGE DUMMYVARS I.S.OPRSLST +CLISPCONTEXT UNDOSIDE0 EXP))) + +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: DWIMIFYBLOCK CLBINARYMINUS? CLISPANGLEBRACKETS CLISPATOM CLISPATOM0 CLISPATOM1 CLISPATOM1A CLISPATOM1B CLISPATOM2 CLISPATOM2A CLISPATOM2C CLISPATOM2D CLISPATOMARE1 CLISPATOMARE2 @@ -5118,33 +5625,32 @@ with the terms of said license. (RPAQ? DWIM.GIVE.UP.TIME ) (RPAQ? DWIM.GIVE.UP.INTERVAL 2000) -(PUTPROPS DWIMIFY COPYRIGHT ("Venue & Xerox Corporation" T 1978 1984 1985 1986 1990)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (5666 53378 (DWIMIFYFNS 5676 . 7159) (DWIMIFY 7161 . 8220) (DWIMIFY0 8222 . 14599) ( -DWIMIFY0? 14601 . 16670) (DWMFY0 16672 . 17042) (DWIMIFY1 17044 . 17119) (DWIMIFY1? 17121 . 17667) ( -DWMFY1 17669 . 27351) (DWIMIFY1A 27353 . 28288) (DWIMIFY2 28290 . 28384) (DWIMIFY2? 28386 . 28959) ( -DWMFY2 28961 . 41417) (DWIMIFY2A 41419 . 42281) (CLISPANGLEBRACKETS 42283 . 42544) (SHRIEKER 42546 . -52023) (CLISPRESPELL 52025 . 52732) (EXPRCHECK 52734 . 53376)) (53379 148618 (CLISPATOM0 53389 . 55380 -) (CLISPATOM1 55382 . 81128) (CLRPLNODE 81130 . 81914) (STOPSCAN? 81916 . 85782) (CLUNARYMINUS? 85784 - . 88030) (CLBINARYMINUS? 88032 . 89969) (CLISPATOM1A 89971 . 94956) (CLISPATOM1B 94958 . 95916) ( -CLISPATOM2 95918 . 119052) (CLISPNOEVAL 119054 . 120579) (CLISPLOOKUP 120581 . 122889) (CLISPATOM2A -122891 . 126671) (CLISPBROADSCOPE 126673 . 128023) (CLISPBROADSCOPE1 128025 . 129895) (CLISPATOM2C -129897 . 133566) (CLISPATOM2D 133568 . 135840) (CLISPCAR/CDR 135842 . 140140) (CLISPCAR/CDR1 140142 . -143701) (CLISPCAR/CDR2 143703 . 144076) (CLISPATOMIS1 144078 . 145021) (CLISPATOMARE1 145023 . 145857) - (CLISPATOMARE2 145859 . 147403) (CLISPATOMIS2 147405 . 148616)) (148619 224380 (WTFIX 148629 . 148856 -) (WTFIX0 148858 . 149479) (WTFIX1 149481 . 168902) (RETDWIM 168904 . 174471) (DWIMERRORRETURN 174473 - . 174631) (DWIMARKASCHANGED 174633 . 175889) (RETDWIM1 175891 . 181400) (FIX89TYPEIN 181402 . 182856) - (FIXLAMBDA 182858 . 183371) (FIXAPPLY 183373 . 186168) (FIXATOM 186170 . 192376) (FIXATOM1 192378 . -198795) (FIXCONTINUE 198797 . 199250) (FIXCONTINUE1 199252 . 200186) (CLISPATOM 200188 . 204070) ( -GETVARS 204072 . 205599) (GETVARS1 205601 . 205972) (FIX89 205974 . 207803) (FIXPRINTIN 207805 . -209032) (FIX89A 209034 . 209782) (CLISPFUNCTION? 209784 . 214688) (CLISPNOTVARP 214690 . 215254) ( -CLISP-SIMPLE-FUNCTION-P 215256 . 215592) (CLISPELL 215594 . 216713) (FINDFN 216715 . 223491) ( -DWIMUNSAVEDEF 223493 . 224054) (CHECKTRAN 224056 . 224378)) (224381 235346 (CLISPIF 224391 . 226056) ( -CLISPIF0 226058 . 232254) (CLISPIF1 232256 . 232881) (CLISPIF2 232883 . 233992) (CLISPIF3 233994 . -235344)) (235347 298653 (CLISPFOR 235357 . 236601) (CLISPFOR0 236603 . 270380) (CLISPFOR0A 270382 . -272367) (CLISPFOR1 272369 . 283772) (CLISPRPLNODE 283774 . 284261) (CLISPFOR2 284263 . 285295) ( -CLISPFOR3 285297 . 285847) (CLISPFORVARS 285849 . 294129) (CLISPFORVARS1 294131 . 294679) (CLISPFOR4 -294681 . 295285) (CLISPFORF/L 295287 . 296422) (CLISPDSUBST 296424 . 297615) (GETDUMMYVAR 297617 . -298027) (CLISPFORINITVAR 298029 . 298651)) (298654 304767 (\DURATIONTRAN 298664 . 303526) ( -\CLISPKEYWORDPROCESS 303528 . 304765))))) + (FILEMAP (NIL (5377 52993 (DWIMIFYFNS 5387 . 6882) (DWIMIFY 6884 . 7926) (DWIMIFY0 7928 . 14337) ( +DWIMIFY0? 14339 . 16323) (DWMFY0 16325 . 16695) (DWIMIFY1 16697 . 16772) (DWIMIFY1? 16774 . 17285) ( +DWMFY1 17287 . 26957) (DWIMIFY1A 26959 . 27902) (DWIMIFY2 27904 . 27998) (DWIMIFY2? 28000 . 28538) ( +DWMFY2 28540 . 41040) (DWIMIFY2A 41042 . 41912) (CLISPANGLEBRACKETS 41914 . 42179) (SHRIEKER 42181 . +51681) (CLISPRESPELL 51683 . 52343) (EXPRCHECK 52345 . 52991)) (52994 147675 (CLISPATOM0 53004 . 54986 +) (CLISPATOM1 54988 . 80801) (CLRPLNODE 80803 . 81589) (STOPSCAN? 81591 . 85373) (CLUNARYMINUS? 85375 + . 87574) (CLBINARYMINUS? 87576 . 89416) (CLISPATOM1A 89418 . 94399) (CLISPATOM1B 94401 . 95316) ( +CLISPATOM2 95318 . 118384) (CLISPNOEVAL 118386 . 119858) (CLISPLOOKUP 119860 . 122097) (CLISPATOM2A +122099 . 125888) (CLISPBROADSCOPE 125890 . 127244) (CLISPBROADSCOPE1 127246 . 129087) (CLISPATOM2C +129089 . 132733) (CLISPATOM2D 132735 . 134952) (CLISPCAR/CDR 134954 . 139229) (CLISPCAR/CDR1 139231 . +142871) (CLISPCAR/CDR2 142873 . 143250) (CLISPATOMIS1 143252 . 144174) (CLISPATOMARE1 144176 . 144948) + (CLISPATOMARE2 144950 . 146507) (CLISPATOMIS2 146509 . 147673)) (147676 223891 (WTFIX 147686 . 147917 +) (WTFIX0 147919 . 148551) (WTFIX1 148553 . 168713) (RETDWIM 168715 . 174323) (DWIMERRORRETURN 174325 + . 174487) (DWIMARKASCHANGED 174489 . 175706) (RETDWIM1 175708 . 181222) (FIX89TYPEIN 181224 . 182706) + (FIXLAMBDA 182708 . 183174) (FIXAPPLY 183176 . 185999) (FIXATOM 186001 . 192193) (FIXATOM1 192195 . +198563) (FIXCONTINUE 198565 . 199018) (FIXCONTINUE1 199020 . 199958) (CLISPATOM 199960 . 203822) ( +GETVARS 203824 . 205383) (GETVARS1 205385 . 205735) (FIX89 205737 . 207547) (FIXPRINTIN 207549 . +208694) (FIX89A 208696 . 209448) (CLISPFUNCTION? 209450 . 214239) (CLISPNOTVARP 214241 . 214809) ( +CLISP-SIMPLE-FUNCTION-P 214811 . 215151) (CLISPELL 215153 . 216276) (FINDFN 216278 . 222986) ( +DWIMUNSAVEDEF 222988 . 223561) (CHECKTRAN 223563 . 223889)) (223892 234842 (CLISPIF 223902 . 225520) ( +CLISPIF0 225522 . 231761) (CLISPIF1 231763 . 232363) (CLISPIF2 232365 . 233484) (CLISPIF3 233486 . +234840)) (234843 297748 (CLISPFOR 234853 . 236007) (CLISPFOR0 236009 . 269796) (CLISPFOR0A 269798 . +271728) (CLISPFOR1 271730 . 283098) (CLISPRPLNODE 283100 . 283525) (CLISPFOR2 283527 . 284596) ( +CLISPFOR3 284598 . 285101) (CLISPFORVARS 285103 . 293369) (CLISPFORVARS1 293371 . 293923) (CLISPFOR4 +293925 . 294537) (CLISPFORF/L 294539 . 295592) (CLISPDSUBST 295594 . 296753) (GETDUMMYVAR 296755 . +297169) (CLISPFORINITVAR 297171 . 297746)) (297749 303924 (\DURATIONTRAN 297759 . 302730) ( +\CLISPKEYWORDPROCESS 302732 . 303922))))) STOP diff --git a/sources/DWIMIFY.LCOM b/sources/DWIMIFY.LCOM index 4ea34731..f71619db 100644 Binary files a/sources/DWIMIFY.LCOM and b/sources/DWIMIFY.LCOM differ diff --git a/sources/EXTERNALFORMAT b/sources/EXTERNALFORMAT index d5c22103..51142e8a 100644 --- a/sources/EXTERNALFORMAT +++ b/sources/EXTERNALFORMAT @@ -1,12 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) -(FILECREATED "29-Jan-2026 21:09:02" {WMEDLEY}EXTERNALFORMAT.;92 39722 +(FILECREATED "22-Feb-2026 12:29:38" {WMEDLEY}EXTERNALFORMAT.;124 45411 :EDIT-BY rmk - :CHANGES-TO (FNS \EXTERNALFORMAT) + :CHANGES-TO (VARS EXTERNALFORMATCOMS) - :PREVIOUS-DATE "24-Apr-2025 08:43:01" {WMEDLEY}EXTERNALFORMAT.;91) + :PREVIOUS-DATE "20-Feb-2026 09:18:35" {WMEDLEY}EXTERNALFORMAT.;123) (PRETTYCOMPRINT EXTERNALFORMATCOMS) @@ -19,8 +19,7 @@ (SYSRECORDS EXTERNALFORMAT) (FNS \EXTERNALFORMAT MAKE-EXTERNALFORMAT \EXTERNALFORMAT.DEFPRINT) (FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT FIND-FORMAT) - (FNS SYSTEM-EXTERNALFORMAT) - (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*) + (EXPORT (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*)) (INITVARS (*EXTERNALFORMATS* NIL) (*DEFAULT-EXTERNALFORMAT* :MCCS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'EXTERNALFORMAT (FUNCTION @@ -30,7 +29,8 @@ (* ;; "Generic functions not compiled open (originally on LLREAD)") (FNS \OUTCHAR \INCCODE \BACKCCODE \BACKCCODE.EOLC \PEEKCCODE \PEEKCCODE.EOLC - \INCCODE.EOLC \FORMATBYTESTREAM \FORMATBYTESTRING \CHECKEOLC.CRLF) + \INCCODE.EOLC \FORMATBYTESTREAM \CHECKEOLC.CRLF) + (FNS MCCSTOFORMATBYTES FORMATBYTESTOMCCS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CHECKEOLC)) (RESOURCES \FORMATBYTESTRING.STREAM)) (INITRESOURCES \FORMATBYTESTRING.STREAM)) @@ -38,10 +38,12 @@ (FNS \NULLDEVICE \NULL.OPENFILE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\NULLDEVICE] (COMS - (* ;; "Also from FILEIO, but not clear that this is or ever has been used.") + (* ;; "Also from FILEIO.") - (FNS \CREATE.THROUGH.EXTERNALFORMAT \THROUGHIN \THROUGHBACKCCODE \THROUGHOUTCHARFN) - (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT]) + (FNS \CREATE.THROUGH.EXTERNALFORMAT \CREATE.THROUGH16.EXTERNALFORMAT \THROUGHIN + \THROUGHBACKCCODE \THROUGHOUTCHARFN) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.THROUGH.EXTERNALFORMAT) + (\CREATE.THROUGH16.EXTERNALFORMAT]) @@ -67,15 +69,18 @@ (EF1 POINTER) (* ;  "Extra fields for use of particular formats. Possibly to hold standardized translation tables") (EF2 POINTER) - (FORMATBYTESTRINGFN POINTER) (* ; "Translates an internal string into a string containing the bytes that represent that string in this format") + (MCCSTOFORMATBYTESFN POINTER) (* ; "Translates an MCCS string into a string containing the bytes that represent that string in this format") (FORMATCHARSETFN POINTER) (* ;  "If present, apply by \GENERIC.CHARSET") - )) + (FORMATBYTESTOMCCSFN POINTER)) (* ; + "Translates format bytes into a string containing the corresponding MCCS codes") + ) ) (/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2) - FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) + FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER) '((EXTERNALFORMAT 0 (FLAGBITS . 0)) (EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (FLAGBITS . 48)) @@ -88,8 +93,9 @@ (EXTERNALFORMAT 12 POINTER) (EXTERNALFORMAT 14 POINTER) (EXTERNALFORMAT 16 POINTER) - (EXTERNALFORMAT 18 POINTER)) - '20) + (EXTERNALFORMAT 18 POINTER) + (EXTERNALFORMAT 20 POINTER)) + '22) (* "END EXPORTED DEFINITIONS") @@ -97,7 +103,8 @@ (/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2) - FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) + FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER) '((EXTERNALFORMAT 0 (FLAGBITS . 0)) (EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (FLAGBITS . 48)) @@ -110,8 +117,9 @@ (EXTERNALFORMAT 12 POINTER) (EXTERNALFORMAT 14 POINTER) (EXTERNALFORMAT 16 POINTER) - (EXTERNALFORMAT 18 POINTER)) - '20) + (EXTERNALFORMAT 18 POINTER) + (EXTERNALFORMAT 20 POINTER)) + '22) (ADDTOVAR SYSTEMRECLST (DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) @@ -125,8 +133,9 @@ (FORMATBYTESTREAMFN POINTER) (EF1 POINTER) (EF2 POINTER) - (FORMATBYTESTRINGFN POINTER) - (FORMATCHARSETFN POINTER))) + (MCCSTOFORMATBYTESFN POINTER) + (FORMATCHARSETFN POINTER) + (FORMATBYTESTOMCCSFN POINTER))) ) (DEFINEQ @@ -199,7 +208,10 @@ (MAKE-EXTERNALFORMAT [LAMBDA (NAME INCCODEFN PEEKCCODEFN BACKCCODEFN OUTCHARFN FORMATBYTESTREAMFN EOL UNSTABLE - FORMATBYTESTRINGFN DEFAULT FORMATCHARSETFN) (* ; "Edited 8-Dec-2023 22:02 by rmk") + MCCSTOFORMATBYTESFN DEFAULT FORMATCHARSETFN FORMATBYTESTOMCCSFN) + (* ; "Edited 5-Feb-2026 14:26 by rmk") + (* ; "Edited 2-Feb-2026 23:04 by rmk") + (* ; "Edited 8-Dec-2023 22:02 by rmk") (* ; "Edited 3-Jul-2022 00:35 by rmk") (* ; "Edited 10-Sep-2021 19:47 by rmk:") @@ -210,17 +222,13 @@ *DEFAULT-EXTERNALFORMAT* DEFAULT)] (CL:UNLESS INCCODEFN - (SETQ INCCODEFN (FETCH (EXTERNALFORMAT INCCODEFN) - DEF))) + (SETQ INCCODEFN (FETCH (EXTERNALFORMAT INCCODEFN) OF DEF))) (CL:UNLESS PEEKCCODEFN - (SETQ PEEKCCODEFN (FETCH (EXTERNALFORMAT PEEKCCODEFN) - DEF))) + (SETQ PEEKCCODEFN (FETCH (EXTERNALFORMAT PEEKCCODEFN) OF DEF))) (CL:UNLESS BACKCCODEFN - (SETQ BACKCCODEFN (FETCH (EXTERNALFORMAT BACKCCODEFN) - DEF))) + (SETQ BACKCCODEFN (FETCH (EXTERNALFORMAT BACKCCODEFN) OF DEF))) (CL:UNLESS OUTCHARFN - (SETQ OUTCHARFN (FETCH (EXTERNALFORMAT OUTCHARFN) - DEF)))]) + (SETQ OUTCHARFN (FETCH (EXTERNALFORMAT OUTCHARFN) OF DEF)))]) (SETQ EOL (SELECTC EOL ((LIST 'LF LF.EOLC) LF.EOLC) @@ -231,17 +239,18 @@ (NIL) (SHOULDNT))) (\INSTALL.EXTERNALFORMAT (CREATE EXTERNALFORMAT - NAME _ NAME - INCCODEFN _ INCCODEFN - PEEKCCODEFN _ PEEKCCODEFN - BACKCCODEFN _ BACKCCODEFN - OUTCHARFN _ OUTCHARFN - FORMATBYTESTREAMFN _ FORMATBYTESTREAMFN - EOLVALID _ EOL - EOL _ (OR EOL LF.EOLC) - UNSTABLE _ UNSTABLE - FORMATBYTESTRINGFN _ FORMATBYTESTRINGFN - FORMATCHARSETFN _ (OR FORMATCHARSETFN (FUNCTION NILL]) + NAME ↠NAME + INCCODEFN ↠INCCODEFN + PEEKCCODEFN ↠PEEKCCODEFN + BACKCCODEFN ↠BACKCCODEFN + OUTCHARFN ↠OUTCHARFN + FORMATBYTESTREAMFN ↠FORMATBYTESTREAMFN + EOLVALID ↠EOL + EOL ↠(OR EOL LF.EOLC) + UNSTABLE ↠UNSTABLE + MCCSTOFORMATBYTESFN ↠MCCSTOFORMATBYTESFN + FORMATBYTESTOMCCSFN ↠FORMATBYTESTOMCCSFN + FORMATCHARSETFN ↠(OR FORMATCHARSETFN (FUNCTION NILL]) (\EXTERNALFORMAT.DEFPRINT [LAMBDA (EXTERNALFORMAT STREAM) (* ; "Edited 2-Jul-2022 11:40 by rmk") @@ -255,7 +264,7 @@ (DEFINEQ (\INSTALL.EXTERNALFORMAT - [LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:") + [LAMBDA (EXTFORMAT/NAME EXTERNALFORMAT) (* ; "Edited 5-Aug-2021 14:22 by rmk:") (* ;;; "Register an instance of the datatype EXTERNALFORMAT.") @@ -264,25 +273,23 @@ (LET (NAME) (IF EXTERNALFORMAT THEN + (* ;; "Backwards compatibility") - (* ;; "Backwards compatibility") - - (SETQ NAME (MKATOM EXTFORMAT/NAME)) - (IF (EQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)) - ELSEIF (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT) - THEN (ERROR "Mismatch of specified name and name of the external format") - ELSE (REPLACE (EXTERNALFORMAT NAME) OF EXTERNALFORMAT WITH - NAME)) + (SETQ NAME (MKATOM EXTFORMAT/NAME)) + (IF (EQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT)) + ELSEIF (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT) + THEN (ERROR "Mismatch of specified name and name of the external format") + ELSE (REPLACE (EXTERNALFORMAT NAME) OF EXTERNALFORMAT WITH NAME)) ELSE (SETQ EXTERNALFORMAT EXTFORMAT/NAME) - (SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT))) + (SETQ NAME (FETCH (EXTERNALFORMAT NAME) OF EXTERNALFORMAT))) (IF (type? EXTERNALFORMAT EXTERNALFORMAT) THEN (\REMOVE.EXTERNALFORMAT NAME) - (push *EXTERNALFORMATS* EXTERNALFORMAT) + (push *EXTERNALFORMATS* EXTERNALFORMAT) ELSE (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT)) EXTERNALFORMAT]) (\REMOVE.EXTERNALFORMAT - [LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:") + [LAMBDA (NAME/EXTFORMAT) (* ; "Edited 5-May-2021 15:42 by rmk:") (* ;;; "Deregisters external format EXTERNALFORMAT .") @@ -290,9 +297,8 @@ THEN (FETCH (EXTERNALFORMAT NAME) OF NAME/EXTFORMAT) ELSE (MKATOM NAME/EXTFORMAT))) (SETQ *EXTERNALFORMATS* (DREMOVE (FIND EF IN *EXTERNALFORMATS* - SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT - NAME) - OF EF))) + SUCHTHAT (EQ NAME/EXTFORMAT (FETCH (EXTERNALFORMAT NAME) + OF EF))) *EXTERNALFORMATS*]) (FIND-FORMAT @@ -306,19 +312,14 @@ OF EF))) (CL:UNLESS NOERROR (ERROR NAME "is not an external format"]) ) -(DEFINEQ - -(SYSTEM-EXTERNALFORMAT - [LAMBDA NIL (* ; "Edited 10-Oct-2022 11:55 by lmm") - (* ; "Edited 7-Jul-2022 10:41 by rmk") - (FOR X IN '("LC_CTYPE" "LC_ALL" "LANG") WHEN (STRPOS ".UTF-8" (UNIX-GETENV X)) - DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH]) -) -(DECLARE%: DOEVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *EXTERNALFORMATS* *DEFAULT-EXTERNALFORMAT*) ) +(* "END EXPORTED DEFINITIONS") + + (RPAQ? *EXTERNALFORMATS* NIL) (RPAQ? *DEFAULT-EXTERNALFORMAT* :MCCS) @@ -524,28 +525,6 @@ (freplace (STREAM ENDOFSTREAMOP) of BYTESTREAM with (FUNCTION NILL))) BYTESTREAM]) -(\FORMATBYTESTRING - [LAMBDA (STREAM STRING) (* ; "Edited 19-Mar-2024 18:24 by rmk") - (* ; "Edited 10-Jul-2022 16:39 by rmk") - (* ; "Edited 22-Jun-2022 11:07 by rmk") - (* ; "Edited 18-Jun-2022 22:04 by rmk") - (WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0) - (LET [FSTRING NBYTES (BYTESTRINGFN (FETCH (EXTERNALFORMAT FORMATBYTESTRINGFN) - OF (FETCH (STREAM EXTERNALFORMAT) OF STREAM] - (IF BYTESTRINGFN - THEN (CL:WHEN (SETQ FSTRING (APPLY* BYTESTRINGFN STREAM STRING - \FORMATBYTESTRING.STREAM)) - (MKSTRING FSTRING)) - ELSE (\FORMATBYTESTREAM STREAM \FORMATBYTESTRING.STREAM) - (FOR C INPNAME STRING DO (\OUTCHAR \FORMATBYTESTRING.STREAM C)) - (SETQ NBYTES (\GETFILEPTR \FORMATBYTESTRING.STREAM)) - (\SETFILEPTR \FORMATBYTESTRING.STREAM 0) - (SETQ FSTRING (ALLOCSTRING NBYTES)) - (FOR I FROM 1 TO NBYTES DO (RPLCHARCODE FSTRING I (\BIN - \FORMATBYTESTRING.STREAM - ))) - FSTRING]) - (\CHECKEOLC.CRLF [LAMBDA (STREAM PEEKBINFLG COUNTP EOLC) (* ; "Edited 6-Dec-2023 23:39 by rmk") (* ; "Edited 17-Oct-2023 11:56 by rmk") @@ -606,6 +585,66 @@ (CHARCODE CR] CH]) ) +(DEFINEQ + +(MCCSTOFORMATBYTES + [LAMBDA (FORMAT MSTRING) (* ; "Edited 6-Feb-2026 18:12 by rmk") + (* ; "Edited 5-Feb-2026 10:24 by rmk") + (* ; "Edited 3-Feb-2026 11:06 by rmk") + (* ; "Edited 19-Mar-2024 18:24 by rmk") + (* ; "Edited 10-Jul-2022 16:39 by rmk") + (* ; "Edited 22-Jun-2022 11:07 by rmk") + (* ; "Edited 18-Jun-2022 22:04 by rmk") + (CL:WHEN MSTRING + (CL:UNLESS (type? EXTERNALFORMAT FORMAT) + (SETQ FORMAT (OR (if (type? STREAM FORMAT) + then (fetch (STREAM EXTERNALFORMAT) of FORMAT) + else (FIND-FORMAT FORMAT)) + (\ILLEGAL.ARG FORMAT)))) + (LET (FSTRING NBYTES (TOBYTESFN (fetch (EXTERNALFORMAT MCCSTOFORMATBYTESFN) of FORMAT))) + (if TOBYTESFN + then (CL:WHEN (SETQ FSTRING (APPLY* TOBYTESFN MSTRING)) + (MKSTRING FSTRING)) + else + (* ;; + "No specific function, fake it by the outchar function. Maybe return NIL if UNSTABLE?") + + (WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0) + (STREAMPROP \FORMATBYTESTRING.STREAM :EXTERNAL-FORMAT FORMAT) + (for C inpname MSTRING do (\OUTCHAR \FORMATBYTESTRING.STREAM C)) + (SETQ NBYTES (\GETFILEPTR \FORMATBYTESTRING.STREAM)) + (\SETFILEPTR \FORMATBYTESTRING.STREAM 0) + (SETQ FSTRING (ALLOCSTRING NBYTES)) + (for I from 1 to NBYTES do (RPLCHARCODE FSTRING I (\BIN + \FORMATBYTESTRING.STREAM + ))) + FSTRING))))]) + +(FORMATBYTESTOMCCS + [LAMBDA (FORMAT FSTRING) (* ; "Edited 6-Feb-2026 18:13 by rmk") + + (* ;; "Produces an MCCS string with characters that correspond to the format bytes in FSTRING according to FORMAT.") + + (CL:WHEN FSTRING + (CL:UNLESS (type? EXTERNALFORMAT FORMAT) + (SETQ FORMAT (OR (if (type? STREAM FORMAT) + then (fetch (STREAM EXTERNALFORMAT) of FORMAT) + else (FIND-FORMAT FORMAT)) + (\ILLEGAL.ARG FORMAT)))) + (SETQ FSTRING (MKSTRING FSTRING)) (* ; "Should be thin, if bytes") + [LET ((TOMCCSFN (fetch (EXTERNALFORMAT FORMATBYTESTOMCCSFN) of FORMAT)) + MSTRING) + (if TOMCCSFN + then (APPLY* TOMCCSFN FSTRING) + else + (* ;; "No specific function, fake it by bouting the FSTRING characters and reading them with \INCCODEFN. ENDOFSTREAMOP is NILL") + + (WITH-RESOURCE \FORMATBYTESTRING.STREAM (\SETFILEPTR \FORMATBYTESTRING.STREAM 0) + (for B instring FSTRING do (\BOUT \FORMATBYTESTRING.STREAM B)) + (\SETFILEPTR \FORMATBYTESTRING.STREAM 0) + (STREAMPROP \FORMATBYTESTRING.STREAM :EXTERNAL-FORMAT FORMAT) + (RSTRING \FORMATBYTESTRING.STREAM])]) +) (DECLARE%: DOEVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE @@ -629,7 +668,9 @@ (DECLARE%: EVAL@COMPILE -[PUTDEF '\FORMATBYTESTRING.STREAM 'RESOURCES '(NEW (OPENSTREAM '{NODIRCORE} 'BOTH] +[PUTDEF '\FORMATBYTESTRING.STREAM 'RESOURCES '(NEW (OPENSTREAM '{NODIRCORE} 'BOTH) + NIL + '((ENDOFSTREAMOP NILL] ) ) @@ -647,41 +688,41 @@ (* ;; "Defines the NULL device, an infinite source or sink") (\DEFINEDEVICE 'NULL (create FDEV - DEVICENAME _ 'NULL - RANDOMACCESSP _ T - NODIRECTORIES _ T - CLOSEFILE _ (FUNCTION NILL) - DELETEFILE _ (FUNCTION NILL) - OPENFILE _ (FUNCTION \NULL.OPENFILE) - REOPENFILE _ (FUNCTION \NULL.OPENFILE) - BIN _ (FUNCTION \EOF.ACTION) - BOUT _ (FUNCTION NILL) - PEEKBIN _ [FUNCTION (LAMBDA (STREAM NOERRORFLG) + DEVICENAME ↠'NULL + RANDOMACCESSP ↠T + NODIRECTORIES ↠T + CLOSEFILE ↠(FUNCTION NILL) + DELETEFILE ↠(FUNCTION NILL) + OPENFILE ↠(FUNCTION \NULL.OPENFILE) + REOPENFILE ↠(FUNCTION \NULL.OPENFILE) + BIN ↠(FUNCTION \EOF.ACTION) + BOUT ↠(FUNCTION NILL) + PEEKBIN ↠[FUNCTION (LAMBDA (STREAM NOERRORFLG) (AND (NULL NOERRORFLG) (BIN STREAM] - READP _ (FUNCTION NILL) - BACKFILEPTR _ (FUNCTION NILL) - EOFP _ (FUNCTION TRUE) - RENAMEFILE _ (FUNCTION NILL) - GETFILENAME _ (FUNCTION NILL) - EVENTFN _ (FUNCTION NILL) - BLOCKIN _ (FUNCTION \EOF.ACTION) - BLOCKOUT _ (FUNCTION NILL) - GENERATEFILES _ (FUNCTION \NULLFILEGENERATOR) - GETFILEPTR _ (FUNCTION ZERO) - GETEOFPTR _ (FUNCTION ZERO) - SETFILEPTR _ (FUNCTION NILL) - GETFILEINFO _ (FUNCTION NILL) - SETFILEINFO _ (FUNCTION NILL) - SETEOFPTR _ (FUNCTION NILL]) + READP ↠(FUNCTION NILL) + BACKFILEPTR ↠(FUNCTION NILL) + EOFP ↠(FUNCTION TRUE) + RENAMEFILE ↠(FUNCTION NILL) + GETFILENAME ↠(FUNCTION NILL) + EVENTFN ↠(FUNCTION NILL) + BLOCKIN ↠(FUNCTION \EOF.ACTION) + BLOCKOUT ↠(FUNCTION NILL) + GENERATEFILES ↠(FUNCTION \NULLFILEGENERATOR) + GETFILEPTR ↠(FUNCTION ZERO) + GETEOFPTR ↠(FUNCTION ZERO) + SETFILEPTR ↠(FUNCTION NILL) + GETFILEINFO ↠(FUNCTION NILL) + SETFILEINFO ↠(FUNCTION NILL) + SETEOFPTR ↠(FUNCTION NILL]) (\NULL.OPENFILE [LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE OLDSTREAM) (* bvm%: "30-Jan-85 22:05") (OR OLDSTREAM (create STREAM - USERCLOSEABLE _ T - ACCESS _ ACCESS - FULLFILENAME _ NIL - DEVICE _ DEVICE]) + USERCLOSEABLE ↠T + ACCESS ↠ACCESS + FULLFILENAME ↠NIL + DEVICE ↠DEVICE]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY @@ -690,31 +731,82 @@ -(* ;; "Also from FILEIO, but not clear that this is or ever has been used.") +(* ;; "Also from FILEIO.") (DEFINEQ (\CREATE.THROUGH.EXTERNALFORMAT - [LAMBDA NIL (* ; "Edited 24-Jul-2022 08:08 by rmk") + [LAMBDA NIL (* ; "Edited 9-Feb-2026 15:43 by rmk") + (* ; "Edited 5-Feb-2026 13:12 by rmk") + (* ; "Edited 24-Jul-2022 08:08 by rmk") (* ; "Edited 23-Jun-2021 13:34 by rmk:") (* ;;; "Create the :THROUGH external format. EOL is adjusted so that the .EOLC callers will not do any conversion.") - (MAKE-EXTERNALFORMAT :THROUGH (FUNCTION \THROUGHIN) + (MAKE-EXTERNALFORMAT :THROUGH [FUNCTION (LAMBDA (STREAM COUNTP) + (DECLARE (USEDFREE *BYTECOUNTER*)) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1)) + (\BIN STREAM] (FUNCTION \PEEKBIN) - (FUNCTION \THROUGHBACKCCODE) - (FUNCTION \THROUGHOUTCHARFN) + [FUNCTION (LAMBDA (STREAM COUNTP) + (DECLARE (USEDFREE *BYTECOUNTER*)) + (CL:WHEN (\BACKFILEPTR STREAM) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1)) + T)] + [FUNCTION (LAMBDA (OUTSTREAM CHARCODE) + (CL:WHEN (> CHARCODE \MAXTHINCHAR) + (ERROR ":THROUGH external format can't represent 16 bit characters")) + (\BOUT OUTSTREAM CHARCODE] NIL (CL:IF (EQ (CHARCODE CR) (CHARCODE EOL)) CR.EOLC LF.EOLC) NIL - (FUNCTION (LAMBDA (STREAM STRING) - (MKSTRING STRING]) + (FUNCTION MKSTRING) + NIL NIL (FUNCTION MKSTRING]) + +(\CREATE.THROUGH16.EXTERNALFORMAT + [LAMBDA NIL (* ; "Edited 9-Feb-2026 15:47 by rmk") + (* ; "Edited 5-Feb-2026 13:12 by rmk") + (* ; "Edited 24-Jul-2022 08:08 by rmk") + (* ; "Edited 23-Jun-2021 13:34 by rmk:") + +(* ;;; "Create the :THROUGH external format. EOL is adjusted so that the .EOLC callers will not do any conversion.") + + (MAKE-EXTERNALFORMAT :THROUGH16 [FUNCTION (LAMBDA (STREAM COUNTP) + (DECLARE (USEDFREE *BYTECOUNTER*)) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* 2)) + (\WIN STREAM] + [FUNCTION (LAMBDA (STREAM NOERRORFLG) + (LET (BYTE1 BYTE2) + (CL:WHEN (SETQ BYTE1 (\PEEKBIN STREAM NOERRORFLG)) + (\BIN STREAM) + (SETQ BYTE2 (\PEEKBIN STREAM NOERRORFLG)) + (\BACKFILEPTR STREAM) + (CL:WHEN BYTE2 + (LOGOR (LLSH BYTE1 8) + BYTE2)))] + [FUNCTION (LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:") + (DECLARE (USEDFREE *BYTECOUNTER*)) + (CL:WHEN (\BACKFILEPTR STREAM) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1)) + (CL:WHEN (\BACKFILEPTR STREAM) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -2)) + T))] + [FUNCTION (LAMBDA (OUTSTREAM CHARCODE) + (\WOUT OUTSTREAM CHARCODE] + NIL + (CL:IF (EQ (CHARCODE CR) + (CHARCODE EOL)) + CR.EOLC + LF.EOLC) + NIL + (FUNCTION MKSTRING) + NIL NIL (FUNCTION MKSTRING]) (\THROUGHIN - [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:") + [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:13 by rmk:") (* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.") @@ -725,14 +817,14 @@ (\BIN STREAM]) (\THROUGHBACKCCODE - [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:") + [LAMBDA (STREAM COUNTP) (* ; "Edited 6-Aug-2021 16:14 by rmk:") (DECLARE (USEDFREE *BYTECOUNTER*)) (CL:WHEN (\BACKFILEPTR STREAM) (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -1)) T)]) (\THROUGHOUTCHARFN - [LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm") + [LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm") (* ;;; "Encoder for THROUGH format.") @@ -745,15 +837,18 @@ (DECLARE%: DONTEVAL@LOAD DOCOPY (\CREATE.THROUGH.EXTERNALFORMAT) + +(\CREATE.THROUGH16.EXTERNALFORMAT) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (6706 14360 (\EXTERNALFORMAT 6716 . 11315) (MAKE-EXTERNALFORMAT 11317 . 13887) ( -\EXTERNALFORMAT.DEFPRINT 13889 . 14358)) (14361 17402 (\INSTALL.EXTERNALFORMAT 14371 . 15820) ( -\REMOVE.EXTERNALFORMAT 15822 . 16653) (FIND-FORMAT 16655 . 17400)) (17403 17815 (SYSTEM-EXTERNALFORMAT - 17413 . 17813)) (18164 34141 (\OUTCHAR 18174 . 19391) (\INCCODE 19393 . 20546) (\BACKCCODE 20548 . -22227) (\BACKCCODE.EOLC 22229 . 24419) (\PEEKCCODE 24421 . 24746) (\PEEKCCODE.EOLC 24748 . 25127) ( -\INCCODE.EOLC 25129 . 26928) (\FORMATBYTESTREAM 26930 . 29374) (\FORMATBYTESTRING 29376 . 31076) ( -\CHECKEOLC.CRLF 31078 . 34139)) (35423 37659 (\NULLDEVICE 35433 . 37335) (\NULL.OPENFILE 37337 . 37657 -)) (37799 39626 (\CREATE.THROUGH.EXTERNALFORMAT 37809 . 38595) (\THROUGHIN 38597 . 39017) ( -\THROUGHBACKCCODE 39019 . 39286) (\THROUGHOUTCHARFN 39288 . 39624))))) + (FILEMAP (NIL (7168 15089 (\EXTERNALFORMAT 7178 . 11777) (MAKE-EXTERNALFORMAT 11779 . 14616) ( +\EXTERNALFORMAT.DEFPRINT 14618 . 15087)) (15090 17955 (\INSTALL.EXTERNALFORMAT 15100 . 16457) ( +\REMOVE.EXTERNALFORMAT 16459 . 17206) (FIND-FORMAT 17208 . 17953)) (18373 32648 (\OUTCHAR 18383 . +19600) (\INCCODE 19602 . 20755) (\BACKCCODE 20757 . 22436) (\BACKCCODE.EOLC 22438 . 24628) (\PEEKCCODE + 24630 . 24955) (\PEEKCCODE.EOLC 24957 . 25336) (\INCCODE.EOLC 25338 . 27137) (\FORMATBYTESTREAM 27139 + . 29583) (\CHECKEOLC.CRLF 29585 . 32646)) (32649 36565 (MCCSTOFORMATBYTES 32659 . 35058) ( +FORMATBYTESTOMCCS 35060 . 36563)) (37976 40270 (\NULLDEVICE 37986 . 39938) (\NULL.OPENFILE 39940 . +40268)) (40360 45275 (\CREATE.THROUGH.EXTERNALFORMAT 40370 . 42039) (\CREATE.THROUGH16.EXTERNALFORMAT +42041 . 44232) (\THROUGHIN 44234 . 44658) (\THROUGHBACKCCODE 44660 . 44931) (\THROUGHOUTCHARFN 44933 + . 45273))))) STOP diff --git a/sources/EXTERNALFORMAT.LCOM b/sources/EXTERNALFORMAT.LCOM index 1a705304..5a9fc5f6 100644 Binary files a/sources/EXTERNALFORMAT.LCOM and b/sources/EXTERNALFORMAT.LCOM differ diff --git a/sources/FILEIO b/sources/FILEIO index 2c5fb1ed..433ead86 100644 --- a/sources/FILEIO +++ b/sources/FILEIO @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "12-Sep-2025 08:19:06" {WMEDLEY}FILEIO.;141 166968 +(FILECREATED " 6-Feb-2026 23:22:00" {WMEDLEY}FILEIO.;142 166519 :EDIT-BY rmk - :CHANGES-TO (FNS COPYFILE COPYCHARS) + :CHANGES-TO (FNS DIRECTORYNAME) - :PREVIOUS-DATE "24-Apr-2025 22:16:47" -{DSK}kaplan>Local>medley3.5>working-medley>sources>FILEIO.;139) + :PREVIOUS-DATE "12-Sep-2025 08:19:06" {WMEDLEY}FILEIO.;141) (PRETTYCOMPRINT FILEIOCOMS) @@ -1986,68 +1985,63 @@ update the map") \CONNECTED.DIRECTORY]) (DIRECTORYNAME - [LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited 20-May-92 11:08 by jds") + [LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited 6-Feb-2026 23:19 by rmk") + (* ; "Edited 20-May-92 11:08 by jds") - (* ;; "Returns connected directory name") + (* ;; "Returns connected directory name") - (AND (CL:PATHNAMEP DIRNAME) - (SETQ DIRNAME (CL:NAMESTRING DIRNAME))) - (SELECTQ (SYSTEMTYPE) - (VAX (GETDIRNAME)) - (D (DECLARE (GLOBALVARS LOGINHOST/DIR)) - [PROG (DN FDEV) - [SELECTQ DIRNAME - (T (* ; "Connected host/dir") - (SETQ DN \CONNECTED.DIRECTORY)) - (NIL (SETQ DN (OR LOGINHOST/DIR '{DSK}))) - (COND - [(AND [SETQ FDEV - (LET [(HOST (FILENAMEFIELD DIRNAME 'HOST] - (SELCHARQ (NTHCHARCODE DIRNAME 1) - (> (* ; - "Remove leading > from a subdirectory spec.") - (SETQ DIRNAME (SUBSTRING DIRNAME 2))) - NIL) - (\GETDEVICEFROMHOSTNAME - (OR HOST (FILENAMEFIELD [SELCHARQ (NTHCHARCODE DIRNAME 1) - ((< /) - (* ; "Whole directory, use it all.") - (SETQ DIRNAME - (PACKFILENAME.STRING - 'DIRECTORY DIRNAME - 'BODY \CONNECTED.DIRECTORY))) - (SELCHARQ (NTHCHARCODE DIRNAME - (NCHARS DIRNAME)) - ((> /) - (* ; - "Remove any trailing > or / from a subdirectory spec.") - (SETQ DIRNAME - (PACKFILENAME.STRING - 'SUBDIRECTORY - (SUBSTRING DIRNAME 1 -2 - ) - 'DIRECTORY - \CONNECTED.DIRECTORY))) - (SETQ DIRNAME - (PACKFILENAME.STRING - 'SUBDIRECTORY DIRNAME - 'DIRECTORY - \CONNECTED.DIRECTORY] - 'HOST] - (SETQ DN (FDEVOP 'DIRECTORYNAMEP FDEV DIRNAME FDEV CREATE?))) - (COND - ((EQ DN T) - (SETQ DN (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME) - of FDEV) - 'DIRECTORY DIRNAME] - (T (RETURN] - (RETURN (COND - ((NOT STRPTR) - (MKSTRING DN)) - ((EQ STRPTR T) - (MKATOM DN)) - (T (MKSTRING DN]) - (HELP]) + (DECLARE (GLOBALVARS LOGINHOST/DIR)) + (CL:WHEN (CL:PATHNAMEP DIRNAME) + (SETQ DIRNAME (CL:NAMESTRING DIRNAME))) + (PROG (DN FDEV) + [SELECTQ DIRNAME + (T (* ; "Connected host/dir") + (SETQ DN \CONNECTED.DIRECTORY)) + (NIL (SETQ DN (OR LOGINHOST/DIR '{DSK}))) + (COND + [(AND [SETQ FDEV + (LET [(HOST (FILENAMEFIELD DIRNAME 'HOST] + (SELCHARQ (NTHCHARCODE DIRNAME 1) + (> (* ; + "Remove leading > from a subdirectory spec.") + (SETQ DIRNAME (SUBSTRING DIRNAME 2))) + NIL) + (\GETDEVICEFROMHOSTNAME + (OR HOST (FILENAMEFIELD [SELCHARQ (NTHCHARCODE DIRNAME 1) + ((< /) + (* ; "Whole directory, use it all.") + (SETQ DIRNAME (PACKFILENAME.STRING + 'DIRECTORY DIRNAME + 'BODY + \CONNECTED.DIRECTORY))) + (SELCHARQ (NTHCHARCODE DIRNAME + (NCHARS DIRNAME)) + ((> /) + (* ; + "Remove any trailing > or / from a subdirectory spec.") + (SETQ DIRNAME + (PACKFILENAME.STRING + 'SUBDIRECTORY + (SUBSTRING DIRNAME 1 -2) + 'DIRECTORY + \CONNECTED.DIRECTORY))) + (SETQ DIRNAME (PACKFILENAME.STRING + 'SUBDIRECTORY DIRNAME + 'DIRECTORY + \CONNECTED.DIRECTORY] + 'HOST] + (SETQ DN (FDEVOP 'DIRECTORYNAMEP FDEV DIRNAME FDEV CREATE?))) + (COND + ((EQ DN T) + (SETQ DN (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME) of FDEV) + 'DIRECTORY DIRNAME] + (T (RETURN] + (RETURN (COND + ((NOT STRPTR) + (MKSTRING DN)) + ((EQ STRPTR T) + (MKATOM DN)) + (T (MKSTRING DN]) (DIRECTORYNAMEP [LAMBDA (DIRNAME HOSTNAME) (* bvm%: "18-Oct-85 14:38") @@ -3167,39 +3161,39 @@ update the map") (ADDTOVAR LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (27752 31868 (STREAMPROP 27762 . 28196) (GETSTREAMPROP 28198 . 28947) (PUTSTREAMPROP -28949 . 31716) (STREAMP 31718 . 31866)) (31911 35290 (\DEFPRINT.BY.NAME 31921 . 33073) ( -\STREAM.DEFPRINT 33075 . 34983) (\FDEV.DEFPRINT 34985 . 35288)) (35548 40589 (\GETACCESS 35558 . 36012 -) (\SETACCESS 36014 . 40587)) (60815 66784 (\DEFINEDEVICE 60825 . 63141) (\GETDEVICEFROMNAME 63143 . -63616) (\GETDEVICEFROMHOSTNAME 63618 . 64662) (\REMOVEDEVICE 64664 . 65787) (\REMOVEDEVICE.NAMES 65789 - . 66782)) (66824 94555 (\CLOSEFILE 66834 . 67659) (\DELETEFILE 67661 . 67955) (\DEVICEEVENT 67957 . -69727) (\GENERATEFILES 69729 . 70676) (\GENERATENEXTFILE 70678 . 71329) (\GENERATEFILEINFO 71331 . -71792) (\GETFILENAME 71794 . 72183) (\GENERIC.OUTFILEP 72185 . 72655) (\OPENFILE 72657 . 75235) ( -\DO.PARAMS.AT.OPEN 75237 . 79433) (\RENAMEFILE 79435 . 80391) (\REVALIDATEFILE 80393 . 82995) ( -\PAGED.REVALIDATEFILELST 82997 . 84555) (\PAGED.REVALIDATEFILES 84557 . 86276) (\PAGED.REVALIDATEFILE -86278 . 88561) (\BUFFERED.REVALIDATEFILE 88563 . 90849) (\BUFFERED.REVALIDATEFILELST 90851 . 92035) ( -\PRINT-REVALIDATION-RESULT 92037 . 92879) (\TRUNCATEFILE 92881 . 93272) (\FILE-CONFLICT 93274 . 94553) -) (94591 99254 (\GENERATENOFILES 94601 . 96697) (\NULLFILEGENERATOR 96699 . 96943) (\NOFILESNEXTFILEFN - 96945 . 98936) (\NOFILESINFOFN 98938 . 99252)) (99373 101281 (\FILE.NOT.OPEN 99383 . 99896) ( -\FILE.WONT.OPEN 99898 . 100226) (\ILLEGAL.DEVICEOP 100228 . 100510) (\IS.NOT.RANDACCESSP 100512 . -100958) (\STREAM.NOT.OPEN 100960 . 101279)) (101416 103714 (\FDEVINSTANCE 101426 . 103712)) (104916 -112290 (CNDIR 104926 . 106231) (DIRECTORYNAME 106233 . 110416) (DIRECTORYNAMEP 110418 . 111034) ( -HOSTNAMEP 111036 . 111843) (\ADD.CONNECTED.DIR 111845 . 112288)) (112335 141282 (\BACKFILEPTR 112345 - . 112533) (\BACKPEEKBIN 112535 . 112896) (\BACKBIN 112898 . 113249) (BIN 113251 . 113468) (\BIN -113470 . 113747) (\BINS 113749 . 114035) (BOUT 114037 . 114399) (\BOUT 114401 . 114716) (\BOUTS 114718 - . 115029) (COPYBYTES 115031 . 118363) (COPYCHARS 118365 . 122163) (COPYFILE 122165 . 123525) ( -\COPYOPENFILE 123527 . 126726) (\INFER.FILE.TYPE 126728 . 127682) (EOFP 127684 . 127981) (FORCEOUTPUT -127983 . 128230) (\FLUSH.OPEN.STREAMS 128232 . 128588) (CHARSET 128590 . 129949) (ACCESS-CHARSET -129951 . 130588) (GETEOFPTR 130590 . 130840) (GETFILEINFO 130842 . 134035) (\TYPE.FROM.FILETYPE 134037 - . 134507) (\FILETYPE.FROM.TYPE 134509 . 134688) (GETFILEPTR 134690 . 134942) (SETFILEINFO 134944 . -139181) (SETFILEPTR 139183 . 140902) (BOUT16 140904 . 141089) (BIN16 141091 . 141280)) (141385 148565 -(\GENERIC.BINS 141395 . 141675) (\GENERIC.BOUTS 141677 . 141942) (\GENERIC.RENAMEFILE 141944 . 144192) - (\GENERIC.OPENP 144194 . 145509) (\GENERIC.READP 145511 . 146663) (\GENERIC.CHARSET 146665 . 148563)) - (148566 148905 (\MAP-OPEN-STREAMS 148576 . 148903)) (150760 152840 (\EOF.ACTION 150770 . 151021) ( -\EOSERROR 151023 . 151216) (\GETEOFPTR 151218 . 151400) (\INCFILEPTR 151402 . 151752) (\PEEKBIN 151754 - . 151945) (\SETCLOSEDFILELENGTH 151947 . 152281) (\SETEOFPTR 152283 . 152471) (\SETFILEPTR 152473 . -152838)) (152841 153383 (\FIXPOUT 152851 . 153151) (\FIXPIN 153153 . 153381)) (153384 153950 (\BOUTEOL - 153394 . 153948)) (156846 166710 (\BUFFERED.BIN 156856 . 157708) (\BUFFERED.PEEKBIN 157710 . 158492) -(\BUFFERED.BOUT 158494 . 159354) (\BUFFERED.BINS 159356 . 163041) (\BUFFERED.BOUTS 163043 . 164844) ( -\BUFFERED.COPYBYTES 164846 . 166708))))) + (FILEMAP (NIL (27706 31822 (STREAMPROP 27716 . 28150) (GETSTREAMPROP 28152 . 28901) (PUTSTREAMPROP +28903 . 31670) (STREAMP 31672 . 31820)) (31865 35244 (\DEFPRINT.BY.NAME 31875 . 33027) ( +\STREAM.DEFPRINT 33029 . 34937) (\FDEV.DEFPRINT 34939 . 35242)) (35502 40543 (\GETACCESS 35512 . 35966 +) (\SETACCESS 35968 . 40541)) (60769 66738 (\DEFINEDEVICE 60779 . 63095) (\GETDEVICEFROMNAME 63097 . +63570) (\GETDEVICEFROMHOSTNAME 63572 . 64616) (\REMOVEDEVICE 64618 . 65741) (\REMOVEDEVICE.NAMES 65743 + . 66736)) (66778 94509 (\CLOSEFILE 66788 . 67613) (\DELETEFILE 67615 . 67909) (\DEVICEEVENT 67911 . +69681) (\GENERATEFILES 69683 . 70630) (\GENERATENEXTFILE 70632 . 71283) (\GENERATEFILEINFO 71285 . +71746) (\GETFILENAME 71748 . 72137) (\GENERIC.OUTFILEP 72139 . 72609) (\OPENFILE 72611 . 75189) ( +\DO.PARAMS.AT.OPEN 75191 . 79387) (\RENAMEFILE 79389 . 80345) (\REVALIDATEFILE 80347 . 82949) ( +\PAGED.REVALIDATEFILELST 82951 . 84509) (\PAGED.REVALIDATEFILES 84511 . 86230) (\PAGED.REVALIDATEFILE +86232 . 88515) (\BUFFERED.REVALIDATEFILE 88517 . 90803) (\BUFFERED.REVALIDATEFILELST 90805 . 91989) ( +\PRINT-REVALIDATION-RESULT 91991 . 92833) (\TRUNCATEFILE 92835 . 93226) (\FILE-CONFLICT 93228 . 94507) +) (94545 99208 (\GENERATENOFILES 94555 . 96651) (\NULLFILEGENERATOR 96653 . 96897) (\NOFILESNEXTFILEFN + 96899 . 98890) (\NOFILESINFOFN 98892 . 99206)) (99327 101235 (\FILE.NOT.OPEN 99337 . 99850) ( +\FILE.WONT.OPEN 99852 . 100180) (\ILLEGAL.DEVICEOP 100182 . 100464) (\IS.NOT.RANDACCESSP 100466 . +100912) (\STREAM.NOT.OPEN 100914 . 101233)) (101370 103668 (\FDEVINSTANCE 101380 . 103666)) (104870 +111841 (CNDIR 104880 . 106185) (DIRECTORYNAME 106187 . 109967) (DIRECTORYNAMEP 109969 . 110585) ( +HOSTNAMEP 110587 . 111394) (\ADD.CONNECTED.DIR 111396 . 111839)) (111886 140833 (\BACKFILEPTR 111896 + . 112084) (\BACKPEEKBIN 112086 . 112447) (\BACKBIN 112449 . 112800) (BIN 112802 . 113019) (\BIN +113021 . 113298) (\BINS 113300 . 113586) (BOUT 113588 . 113950) (\BOUT 113952 . 114267) (\BOUTS 114269 + . 114580) (COPYBYTES 114582 . 117914) (COPYCHARS 117916 . 121714) (COPYFILE 121716 . 123076) ( +\COPYOPENFILE 123078 . 126277) (\INFER.FILE.TYPE 126279 . 127233) (EOFP 127235 . 127532) (FORCEOUTPUT +127534 . 127781) (\FLUSH.OPEN.STREAMS 127783 . 128139) (CHARSET 128141 . 129500) (ACCESS-CHARSET +129502 . 130139) (GETEOFPTR 130141 . 130391) (GETFILEINFO 130393 . 133586) (\TYPE.FROM.FILETYPE 133588 + . 134058) (\FILETYPE.FROM.TYPE 134060 . 134239) (GETFILEPTR 134241 . 134493) (SETFILEINFO 134495 . +138732) (SETFILEPTR 138734 . 140453) (BOUT16 140455 . 140640) (BIN16 140642 . 140831)) (140936 148116 +(\GENERIC.BINS 140946 . 141226) (\GENERIC.BOUTS 141228 . 141493) (\GENERIC.RENAMEFILE 141495 . 143743) + (\GENERIC.OPENP 143745 . 145060) (\GENERIC.READP 145062 . 146214) (\GENERIC.CHARSET 146216 . 148114)) + (148117 148456 (\MAP-OPEN-STREAMS 148127 . 148454)) (150311 152391 (\EOF.ACTION 150321 . 150572) ( +\EOSERROR 150574 . 150767) (\GETEOFPTR 150769 . 150951) (\INCFILEPTR 150953 . 151303) (\PEEKBIN 151305 + . 151496) (\SETCLOSEDFILELENGTH 151498 . 151832) (\SETEOFPTR 151834 . 152022) (\SETFILEPTR 152024 . +152389)) (152392 152934 (\FIXPOUT 152402 . 152702) (\FIXPIN 152704 . 152932)) (152935 153501 (\BOUTEOL + 152945 . 153499)) (156397 166261 (\BUFFERED.BIN 156407 . 157259) (\BUFFERED.PEEKBIN 157261 . 158043) +(\BUFFERED.BOUT 158045 . 158905) (\BUFFERED.BINS 158907 . 162592) (\BUFFERED.BOUTS 162594 . 164395) ( +\BUFFERED.COPYBYTES 164397 . 166259))))) STOP diff --git a/sources/FILEIO.LCOM b/sources/FILEIO.LCOM index 2b24260f..d120ea24 100644 Binary files a/sources/FILEIO.LCOM and b/sources/FILEIO.LCOM differ diff --git a/sources/FILEPKG b/sources/FILEPKG index c71bd967..46d6906b 100644 --- a/sources/FILEPKG +++ b/sources/FILEPKG @@ -1,14 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "27-Sep-2025 19:56:28"  -{DSK}kaplan>Local>medley3.5>working-medley>sources>FILEPKG.;53 274937 +(FILECREATED "25-Feb-2026 10:07:03" {WMEDLEY}FILEPKG.;61 275774 :EDIT-BY rmk - :CHANGES-TO (FNS COMPILE-FILE?) + :CHANGES-TO (FNS FILEGETDEF.FNS) - :PREVIOUS-DATE "24-Apr-2025 11:18:44" -{DSK}kaplan>Local>medley3.5>working-medley>sources>FILEPKG.;52) + :PREVIOUS-DATE "23-Feb-2026 00:54:21" {WMEDLEY}FILEPKG.;59) (PRETTYCOMPRINT FILEPKGCOMS) @@ -2910,18 +2908,20 @@ compiling " T) NIL) finally (RETURN 'NOBIND]) (FILEGETDEF.FNS - [LAMBDA (NAME TYPE SOURCE OPTIONS) (* bvm%: "29-Aug-86 22:30") + [LAMBDA (NAME TYPE SOURCE OPTIONS) (* ; "Edited 25-Feb-2026 10:06 by rmk") + (* ; "Edited 23-Feb-2026 00:37 by rmk") + (* bvm%: "29-Aug-86 22:30") (LET (MAP ENV) (COND [(AND (EQMEMB 'FAST OPTIONS) (PROGN (CL:MULTIPLE-VALUE-SETQ (ENV MAP) (GET-ENVIRONMENT-AND-FILEMAP SOURCE)) MAP)) + (CL:UNLESS (OPENP SOURCE) + [RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT 'OLD]) + (\EXTERNALFORMAT SOURCE ENV) (for PAIR MAPLOC in (CDR MAP) when [SETQ MAPLOC (CADR (ASSOC NAME (CDDR PAIR] - do [OR (OPENP SOURCE) - (RESETSAVE NIL (LIST 'CLOSEF? (SETQ SOURCE (OPENSTREAM SOURCE 'INPUT - 'OLD] - (SETFILEPTR SOURCE MAPLOC) + do (SETFILEPTR SOURCE MAPLOC) (RETURN (WITH-READER-ENVIRONMENT ENV [COND ((EQMEMB 'ARGLIST OPTIONS) @@ -2931,7 +2931,12 @@ compiling " T) (LIST (READ SOURCE) (READ SOURCE))) (T (CADR (READ SOURCE])] - (T (CADR (FASSOC NAME (LOADEFS NAME SOURCE]) + (T + (* ;; "RMK: The NLSETQ is because LOADFNS for FNS seems to disregard NOERROR and crash out when the target is FUNCTIONS, like WITH-READER-ENVIRONMENT") + + (CADR (FASSOC NAME (CL:IF (EQMEMB 'NOERROR OPTIONS) + [CAR (NLSETQ (LOADFNS NAME SOURCE 'GETDEF] + (LOADFNS NAME SOURCE 'GETDEF))]) (FILEPKGCOMS.PUTDEF [LAMBDA (NAME TYPE DEFINITION REASON) (* lmm "15-Jul-85 11:29") @@ -3335,7 +3340,8 @@ compiling " T) (RETFROM 'GETDEFCOM]) (GETDEFCURRENT - [LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 2-May-87 19:00 by Pavel") + [LAMBDA (NAME TYPE OPTIONS) (* ; "Edited 23-Feb-2026 00:27 by rmk") + (* ; "Edited 2-May-87 19:00 by Pavel") (* ;  "Gets the current definition--source=0") (LET @@ -3422,6 +3428,7 @@ compiling " T) (RESETSAVE PRETTYFLG) (RESETSAVE FONTCHANGEFLG) [RESETSAVE (OUTPUT (SETQ FILE (OPENSTREAM '{NODIRCORE} 'BOTH] + (\EXTERNALFORMAT FILE *OLD-INTERLISP-READ-ENVIRONMENT*) (PRETTYDEFCOMS COMS) (SETFILEPTR FILE 0) [SETQ DEF @@ -4689,11 +4696,14 @@ compiling " T) (AND RETURNFLG (LIST FORM]) (IMPORTFILESCAN - [LAMBDA (FILE RETURNFLG) (* bvm%: "24-Oct-86 19:31") - (WITH-READER-ENVIRONMENT (GET-ENVIRONMENT-AND-FILEMAP FILE) - (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF - join (until (EQUAL (SETQ DEF (READ FILE)) - ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))]) + [LAMBDA (FILE RETURNFLG) (* ; "Edited 22-Feb-2026 18:20 by rmk") + (* bvm%: "24-Oct-86 19:31") + (LET ((ENV (GET-ENVIRONMENT-AND-FILEMAP FILE))) + (WITH-READER-ENVIRONMENT ENV + (\EXTERNALFORMAT FILE ENV) + (while (FFILEPOS BEGINEXPORTDEFSTRING FILE NIL NIL NIL T) bind DEF + join (until (EQUAL (SETQ DEF (READ FILE)) + ENDEXPORTDEFFORM) join (IMPORTEVAL DEF RETURNFLG))))]) (CHECKIMPORTS [LAMBDA (FILES NOASKFLG) (* rmk%: "19-FEB-83 16:31") @@ -4868,46 +4878,46 @@ compiling " T) (ADDTOVAR LAMA FILEPKGTYPE FILEPKGCOM FILEPKGCHANGES) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (18974 20647 (SEARCHPRETTYTYPELST 18984 . 19953) (PRETTYDEFMACROS 19955 . 20391) ( -FILEPKGCOMPROPS 20393 . 20645)) (21460 55859 (CLEANUP 21470 . 22860) (COMPILEFILES 22862 . 23138) ( -COMPILEFILES0 23140 . 23953) (CONTINUEDIT 23955 . 25332) (MAKEFILE 25334 . 37060) (FILECHANGES 37062 - . 39826) (FILEPKG.MERGECHANGES 39828 . 40463) (FILEPKG.CHANGEDFNS 40465 . 40777) (MAKEFILE1 40779 . -44991) (COMPILE-FILE? 44993 . 46687) (MAKEFILES 46689 . 48217) (ADDFILE 48219 . 50762) (ADDFILE0 50764 - . 54888) (LISTFILES 54890 . 55857)) (56531 90330 (FILEPKGCHANGES 56541 . 57720) (GETFILEPKGTYPE 57722 - . 60672) (MARKASCHANGED 60674 . 62305) (FILECOMS 62307 . 62691) (WHEREIS 62693 . 64435) ( -SMASHFILECOMS 64437 . 64665) (FILEFNSLST 64667 . 64833) (FILECOMSLST 64835 . 65321) (UPDATEFILES 65323 - . 69821) (INFILECOMS? 69823 . 71666) (INFILECOMTAIL 71668 . 72786) (INFILECOMS 72788 . 72949) ( -INFILECOM 72951 . 82969) (INFILECOMSVALS 82971 . 83278) (INFILECOMSVAL 83280 . 84288) (INFILECOMSPROP -84290 . 85083) (IFCPROPS 85085 . 86165) (IFCEXPRTYPE 86167 . 86783) (IFCPROPSCAN 86785 . 87746) ( -IFCDECLARE 87748 . 89007) (INFILEPAIRS 89009 . 89308) (INFILECOMSMACRO 89310 . 90328)) (90365 121051 ( -FILES? 90375 . 92486) (FILES?1 92488 . 93190) (FILES?PRINTLST 93192 . 93974) (ADDTOFILES? 93976 . -104519) (ADDTOFILE 104521 . 105437) (WHATIS 105439 . 107415) (ADDTOCOMS 107417 . 108955) (ADDTOCOM -108957 . 115444) (ADDTOCOM1 115446 . 116617) (ADDNEWCOM 116619 . 117669) (MAKENEWCOM 117671 . 119518) -(DEFAULTMAKENEWCOM 119520 . 121049)) (121121 123938 (MERGEINSERT 121131 . 123474) (MERGEINSERT1 123476 - . 123936)) (124092 125453 (ADDTOFILEKEYLST 124102 . 125451)) (125570 136371 (DELFROMFILES 125580 . -126410) (DELFROMCOMS 126412 . 128091) (DELFROMCOM 128093 . 133858) (DELFROMCOM1 133860 . 134659) ( -REMOVEITEM 134661 . 135537) (MOVETOFILE 135539 . 136369)) (136585 138956 (SAVEPUT 136595 . 138954)) ( -139081 147324 (UNMARKASCHANGED 139091 . 140575) (PREEDITFN 140577 . 143058) (POSTEDITPROPS 143060 . -145354) (POSTEDITALISTS 145356 . 147322)) (147469 166939 (ALISTS.GETDEF 147479 . 147858) ( -ALISTS.WHENCHANGED 147860 . 148506) (CLEARCLISPARRAY 148508 . 149686) (EXPRESSIONS.WHENCHANGED 149688 - . 150066) (MAKEALISTCOMS 150068 . 151083) (MAKEFILESCOMS 151085 . 152415) (MAKELISPXMACROSCOMS 152417 - . 154435) (MAKEPROPSCOMS 154437 . 155063) (MAKEUSERMACROSCOMS 155065 . 156882) (PROPS.WHENCHANGED -156884 . 157505) (FILEGETDEF.LISPXMACROS 157507 . 158806) (FILEGETDEF.ALISTS 158808 . 159399) ( -FILEGETDEF.RECORDS 159401 . 160328) (FILEGETDEF.PROPS 160330 . 161125) (FILEGETDEF.MACROS 161127 . -162009) (FILEGETDEF.VARS 162011 . 162614) (FILEGETDEF.FNS 162616 . 163856) (FILEPKGCOMS.PUTDEF 163858 - . 165800) (FILES.PUTDEF 165802 . 166670) (VARS.PUTDEF 166672 . 166815) (FILES.WHENCHANGED 166817 . -166937)) (168961 176192 (RENAME 168971 . 170416) (CHANGECALLERS 170418 . 176190)) (176193 224102 ( -SHOWDEF 176203 . 177400) (COPYDEF 177402 . 180150) (GETDEF 180152 . 182695) (GETDEFCOM 182697 . 183663 -) (GETDEFCOM0 183665 . 184858) (GETDEFCURRENT 184860 . 191172) (GETDEFERR 191174 . 192444) ( -GETDEFFROMFILE 192446 . 196675) (GETDEFSAVED 196677 . 197765) (PUTDEF 197767 . 198474) (EDITDEF 198476 - . 199459) (DEFAULT.EDITDEF 199461 . 202299) (EDITDEF.FILES 202301 . 202506) (LOADDEF 202508 . 202684) - (DWIMDEF 202686 . 203540) (DELDEF 203542 . 206436) (DELFROMLIST 206438 . 206942) (HASDEF 206944 . -213181) (GETFILEDEF 213183 . 213695) (SAVEDEF 213697 . 215385) (UNSAVEDEF 215387 . 216283) ( -COMPAREDEFS 216285 . 220091) (COMPARE 220093 . 220797) (TYPESOF 220799 . 224100)) (224252 232500 ( -FILEPKGCOM 224262 . 229038) (FILEPKGTYPE 229040 . 232498)) (244533 262222 (FINDCALLERS 244543 . 245173 -) (EDITCALLERS 245175 . 256106) (EDITFROMFILE 256108 . 261537) (FINDATS 261539 . 261811) (LOOKIN -261813 . 262220)) (262223 263894 (SEPRCASE 262233 . 263892)) (264411 269414 (IMPORTFILE 264421 . -265391) (IMPORTEVAL 265393 . 266279) (IMPORTFILESCAN 266281 . 266694) (CHECKIMPORTS 266696 . 267952) ( -GATHEREXPORTS 267954 . 268822) (\DUMPEXPORTS 268824 . 269412)) (269752 271822 (CLEARFILEPKG 269762 . -271820))))) + (FILEMAP (NIL (18893 20566 (SEARCHPRETTYTYPELST 18903 . 19872) (PRETTYDEFMACROS 19874 . 20310) ( +FILEPKGCOMPROPS 20312 . 20564)) (21379 55778 (CLEANUP 21389 . 22779) (COMPILEFILES 22781 . 23057) ( +COMPILEFILES0 23059 . 23872) (CONTINUEDIT 23874 . 25251) (MAKEFILE 25253 . 36979) (FILECHANGES 36981 + . 39745) (FILEPKG.MERGECHANGES 39747 . 40382) (FILEPKG.CHANGEDFNS 40384 . 40696) (MAKEFILE1 40698 . +44910) (COMPILE-FILE? 44912 . 46606) (MAKEFILES 46608 . 48136) (ADDFILE 48138 . 50681) (ADDFILE0 50683 + . 54807) (LISTFILES 54809 . 55776)) (56450 90249 (FILEPKGCHANGES 56460 . 57639) (GETFILEPKGTYPE 57641 + . 60591) (MARKASCHANGED 60593 . 62224) (FILECOMS 62226 . 62610) (WHEREIS 62612 . 64354) ( +SMASHFILECOMS 64356 . 64584) (FILEFNSLST 64586 . 64752) (FILECOMSLST 64754 . 65240) (UPDATEFILES 65242 + . 69740) (INFILECOMS? 69742 . 71585) (INFILECOMTAIL 71587 . 72705) (INFILECOMS 72707 . 72868) ( +INFILECOM 72870 . 82888) (INFILECOMSVALS 82890 . 83197) (INFILECOMSVAL 83199 . 84207) (INFILECOMSPROP +84209 . 85002) (IFCPROPS 85004 . 86084) (IFCEXPRTYPE 86086 . 86702) (IFCPROPSCAN 86704 . 87665) ( +IFCDECLARE 87667 . 88926) (INFILEPAIRS 88928 . 89227) (INFILECOMSMACRO 89229 . 90247)) (90284 120970 ( +FILES? 90294 . 92405) (FILES?1 92407 . 93109) (FILES?PRINTLST 93111 . 93893) (ADDTOFILES? 93895 . +104438) (ADDTOFILE 104440 . 105356) (WHATIS 105358 . 107334) (ADDTOCOMS 107336 . 108874) (ADDTOCOM +108876 . 115363) (ADDTOCOM1 115365 . 116536) (ADDNEWCOM 116538 . 117588) (MAKENEWCOM 117590 . 119437) +(DEFAULTMAKENEWCOM 119439 . 120968)) (121040 123857 (MERGEINSERT 121050 . 123393) (MERGEINSERT1 123395 + . 123855)) (124011 125372 (ADDTOFILEKEYLST 124021 . 125370)) (125489 136290 (DELFROMFILES 125499 . +126329) (DELFROMCOMS 126331 . 128010) (DELFROMCOM 128012 . 133777) (DELFROMCOM1 133779 . 134578) ( +REMOVEITEM 134580 . 135456) (MOVETOFILE 135458 . 136288)) (136504 138875 (SAVEPUT 136514 . 138873)) ( +139000 147243 (UNMARKASCHANGED 139010 . 140494) (PREEDITFN 140496 . 142977) (POSTEDITPROPS 142979 . +145273) (POSTEDITALISTS 145275 . 147241)) (147388 167392 (ALISTS.GETDEF 147398 . 147777) ( +ALISTS.WHENCHANGED 147779 . 148425) (CLEARCLISPARRAY 148427 . 149605) (EXPRESSIONS.WHENCHANGED 149607 + . 149985) (MAKEALISTCOMS 149987 . 151002) (MAKEFILESCOMS 151004 . 152334) (MAKELISPXMACROSCOMS 152336 + . 154354) (MAKEPROPSCOMS 154356 . 154982) (MAKEUSERMACROSCOMS 154984 . 156801) (PROPS.WHENCHANGED +156803 . 157424) (FILEGETDEF.LISPXMACROS 157426 . 158725) (FILEGETDEF.ALISTS 158727 . 159318) ( +FILEGETDEF.RECORDS 159320 . 160247) (FILEGETDEF.PROPS 160249 . 161044) (FILEGETDEF.MACROS 161046 . +161928) (FILEGETDEF.VARS 161930 . 162533) (FILEGETDEF.FNS 162535 . 164309) (FILEPKGCOMS.PUTDEF 164311 + . 166253) (FILES.PUTDEF 166255 . 167123) (VARS.PUTDEF 167125 . 167268) (FILES.WHENCHANGED 167270 . +167390)) (169414 176645 (RENAME 169424 . 170869) (CHANGECALLERS 170871 . 176643)) (176646 224749 ( +SHOWDEF 176656 . 177853) (COPYDEF 177855 . 180603) (GETDEF 180605 . 183148) (GETDEFCOM 183150 . 184116 +) (GETDEFCOM0 184118 . 185311) (GETDEFCURRENT 185313 . 191819) (GETDEFERR 191821 . 193091) ( +GETDEFFROMFILE 193093 . 197322) (GETDEFSAVED 197324 . 198412) (PUTDEF 198414 . 199121) (EDITDEF 199123 + . 200106) (DEFAULT.EDITDEF 200108 . 202946) (EDITDEF.FILES 202948 . 203153) (LOADDEF 203155 . 203331) + (DWIMDEF 203333 . 204187) (DELDEF 204189 . 207083) (DELFROMLIST 207085 . 207589) (HASDEF 207591 . +213828) (GETFILEDEF 213830 . 214342) (SAVEDEF 214344 . 216032) (UNSAVEDEF 216034 . 216930) ( +COMPAREDEFS 216932 . 220738) (COMPARE 220740 . 221444) (TYPESOF 221446 . 224747)) (224899 233147 ( +FILEPKGCOM 224909 . 229685) (FILEPKGTYPE 229687 . 233145)) (245180 262869 (FINDCALLERS 245190 . 245820 +) (EDITCALLERS 245822 . 256753) (EDITFROMFILE 256755 . 262184) (FINDATS 262186 . 262458) (LOOKIN +262460 . 262867)) (262870 264541 (SEPRCASE 262880 . 264539)) (265058 270251 (IMPORTFILE 265068 . +266038) (IMPORTEVAL 266040 . 266926) (IMPORTFILESCAN 266928 . 267531) (CHECKIMPORTS 267533 . 268789) ( +GATHEREXPORTS 268791 . 269659) (\DUMPEXPORTS 269661 . 270249)) (270589 272659 (CLEARFILEPKG 270599 . +272657))))) STOP diff --git a/sources/FILEPKG.LCOM b/sources/FILEPKG.LCOM index 85ae095b..5becfbc7 100644 Binary files a/sources/FILEPKG.LCOM and b/sources/FILEPKG.LCOM differ diff --git a/sources/FILESETS b/sources/FILESETS index 0cc75efb..15ac01f1 100644 --- a/sources/FILESETS +++ b/sources/FILESETS @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 7-Aug-2025 10:11:01" {WMEDLEY}FILESETS.;24 6210 +(FILECREATED "23-Feb-2026 10:32:36" {WMEDLEY}FILESETS.;32 6226 :EDIT-BY rmk :CHANGES-TO (VARS 0LISPSET) - :PREVIOUS-DATE "10-Jun-2025 18:00:09" {WMEDLEY}FILESETS.;23) + :PREVIOUS-DATE "23-Feb-2026 09:36:51" {WMEDLEY}FILESETS.;31) (PRETTYCOMPRINT FILESETSCOMS) @@ -48,10 +48,10 @@ (RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET)) -(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO EXTERNALFORMAT IMAGEIO - LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME - CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD IOCHAR MCCS LLCHAR LLSTK - LLDATATYPE LLKEY LLTIMER)) +(RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO LLARRAYELT + EXTERNALFORMAT IOCHAR UNICODE-FORMATS IMAGEIO LLBASIC LLGC LLINTERP LLMVS + DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD + MCCS LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) (RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK ATERM APRINT ABASIC diff --git a/sources/FONT b/sources/FONT index f80a67e4..1a92ec84 100644 --- a/sources/FONT +++ b/sources/FONT @@ -1,13 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8) -(FILECREATED "26-Jan-2026 16:37:58" {WMEDLEY}FONT.;664 276319 +(FILECREATED "26-Feb-2026 17:01:47" {WMEDLEY}FONT.;677 278005 :EDIT-BY rmk - :CHANGES-TO (VARS FONTCOMS) - (FNS \CREATEFONT FONTPROP) + :CHANGES-TO (FNS MOVEFONTCHARS) - :PREVIOUS-DATE "22-Jan-2026 14:25:36" {WMEDLEY}FONT.;659) + :PREVIOUS-DATE "20-Feb-2026 12:54:44" {WMEDLEY}FONT.;675) (PRETTYCOMPRINT FONTCOMS) @@ -204,9 +203,9 @@ (DEFINEQ (CHARWIDTH - [LAMBDA (CHARCODE FONT) (* rmk%: "12-Apr-85 09:46") + [LAMBDA (CHARCODE FONT) (* rmk%: "12-Apr-85 09:46") (* ; - "gets the width of a character code in a font/stream") + "gets the width of a character code in a font/stream") (OR (\CHARCODEP CHARCODE) (\ILLEGAL.ARG CHARCODE)) (LET (TEMP) @@ -214,7 +213,7 @@ ((type? FONTDESCRIPTOR FONT) (\FGETCHARWIDTH FONT CHARCODE)) ((SETQ TEMP (\OUTSTREAMARG FONT T)) (* ; - "NIL font goes thru here--primary output file") + "NIL font goes thru here--primary output file") (IMAGEOP 'IMCHARWIDTH TEMP TEMP CHARCODE)) (T (\FGETCHARWIDTH (FONTCREATE FONT) CHARCODE]) @@ -247,7 +246,7 @@ (T 0]) (STRINGWIDTH - [LAMBDA (STR FONT FLG RDTBL) (* ; "Edited 8-Jan-88 14:41 by Snow") + [LAMBDA (STR FONT FLG RDTBL) (* ; "Edited 8-Jan-88 14:41 by Snow") (* ;; "Returns the width of STR according to FONT") @@ -260,22 +259,21 @@ (\STRINGWIDTH.GENERIC STR FONT (AND FLG (\GTREADTABLE RDTBL)) (\FGETCHARWIDTH FONT (CHARCODE SPACE] [(AND FONT (SETQ TEMP (\OUTSTREAMARG FONT T))) (* ; - "if you gave something for FONT, coerce it to a stream, and call the stringwidth function of it.") + "if you gave something for FONT, coerce it to a stream, and call the stringwidth function of it.") (IMAGEOP 'IMSTRINGWIDTH TEMP TEMP STR (AND FLG (\GTREADTABLE RDTBL] - (T (SETQ TEMP (FONTCREATE (OR FONT DEFAULTFONT))) - (* ; "NIL font will pass thru here. ie, defaultfont is used to do the stringwidth instead of the font of *standard-output*") + (T (SETQ TEMP (FONTCREATE (OR FONT DEFAULTFONT)))(* ; "NIL font will pass thru here. ie, defaultfont is used to do the stringwidth instead of the font of *standard-output*") (\STRINGWIDTH.GENERIC STR TEMP (AND FLG (\GTREADTABLE RDTBL)) (\FGETCHARWIDTH TEMP (CHARCODE SPACE]) (\CHARWIDTH.DISPLAY - [LAMBDA (STREAM CHARCODE) (* rmk%: "12-Apr-85 09:42") + [LAMBDA (STREAM CHARCODE) (* rmk%: "12-Apr-85 09:42") (* ; - "gets the width of a character code in a display stream. Need to fix up for spacefactor.") + "gets the width of a character code in a display stream. Need to fix up for spacefactor.") (\FGETCHARWIDTH (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM)) CHARCODE]) (\STRINGWIDTH.DISPLAY - [LAMBDA (STREAM STR RDTBL) (* ; "Edited 3-Apr-87 12:07 by jop") + [LAMBDA (STREAM STR RDTBL) (* ; "Edited 3-Apr-87 12:07 by jop") (* ;; "Returns the width of for the current font/spacefactor in STREAM.") @@ -384,7 +382,7 @@ (FONTCREATE DEFAULTFONT NIL NIL NIL DEVICE NOERRORFLG))]) (FONTCLASS - [LAMBDA (NAME FONTLIST CREATEFORDEVICES) (* jds " 9-Sep-86 18:49") + [LAMBDA (NAME FONTLIST CREATEFORDEVICES) (* jds " 9-Sep-86 18:49") (* ;; "This builds D style font classes, which are datatypes containing entries for the various known devices.") @@ -393,30 +391,30 @@ (PROG (F FC FL) (SETQ FL FONTLIST) [SETQ FC (create FONTCLASS - FONTCLASSNAME _ NAME - PRETTYFONT# _ (OR (FIXP (pop FL)) + FONTCLASSNAME ↠NAME + PRETTYFONT# ↠(OR (FIXP (pop FL)) 1) - DISPLAYFD _ (AND (SETQ F (pop FL)) + DISPLAYFD ↠(AND (SETQ F (pop FL)) (FONTCREATE F NIL NIL NIL 'DISPLAY)) - PRESSFD _ (pop FL) - INTERPRESSFD _ (pop FL) - OTHERFDS _ (for FSPEC in FL - collect (OR (AND (LISTP FSPEC) - (ATOM (CAR FSPEC)) - (CAR FSPEC)) - (ERROR "illegal font class specification" - (LIST NAME FONTLIST))) + PRESSFD ↠(pop FL) + INTERPRESSFD ↠(pop FL) + OTHERFDS ↠(for FSPEC in FL collect (OR (AND (LISTP FSPEC) + (ATOM (CAR FSPEC)) + (CAR FSPEC)) + (ERROR + "illegal font class specification" + (LIST NAME FONTLIST))) (* ; - "Copy the alist entry so it can be smashed in \COERCEFONTDESC") - (CONS (CAR FSPEC) - (CAR (LISTP (CDR FSPEC] + "Copy the alist entry so it can be smashed in \COERCEFONTDESC") + (CONS (CAR FSPEC) + (CAR (LISTP (CDR FSPEC] (for D inside CREATEFORDEVICES do (FONTCREATE FC NIL NIL NIL D)) (RETURN FC]) (FONTCLASSUNPARSE - [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* jds "24-Jan-86 11:58") + [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* jds "24-Jan-86 11:58") (* ; - "Given a font class, unparse it to a form that might be reparsable") + "Given a font class, unparse it to a form that might be reparsable") (APPEND (LIST (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS) (fetch (FONTCLASS PRETTYFONT#) of FONTCLASS) (FONTUNPARSE (ffetch (FONTCLASS DISPLAYFD) of FONTCLASS)) @@ -424,7 +422,7 @@ (FONTUNPARSE (ffetch (FONTCLASS INTERPRESSFD) of FONTCLASS))) (for X in (fetch (FONTCLASS OTHERFDS) of FONTCLASS) collect (LIST (CAR X) - (FONTUNPARSE (CDR X]) + (FONTUNPARSE (CDR X]) (FONTCLASSCOMPONENT [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* ; "Edited 4-Jul-2025 10:32 by rmk") @@ -591,17 +589,17 @@ (* ;; "For the REMEMBER case, dummy font descriptor completely fillled with a slug charsetinfo") (LET* ([FONTDESC (create FONTDESCRIPTOR - FONTDEVICE _ DEVICE - FONTFAMILY _ FAMILY - FONTSIZE _ SIZE - FONTFACE _ FACE - \SFAscent _ SIZE - \SFDescent _ 0 - \SFHeight _ SIZE - ROTATION _ ROTATION - FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE) - FONTCHARENCODING _ 'MCCS - FONTAVGCHARWIDTH _ (FIXR (FTIMES SIZE 0.75] + FONTDEVICE ↠DEVICE + FONTFAMILY ↠FAMILY + FONTSIZE ↠SIZE + FONTFACE ↠FACE + \SFAscent ↠SIZE + \SFDescent ↠0 + \SFHeight ↠SIZE + ROTATION ↠ROTATION + FONTDEVICESPEC ↠(LIST FAMILY SIZE FACE ROTATION DEVICE) + FONTCHARENCODING ↠'MCCS + FONTAVGCHARWIDTH ↠(FIXR (FTIMES SIZE 0.75] (SLUGCSINFO (\BUILDSLUGCSINFO FONTDESC))) (if CHARSET then (\SETCHARSETINFO FONTDESC CHARSET SLUGCSINFO) @@ -609,7 +607,8 @@ FONTDESC]) (\FONT.CHECKARGS1 - [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 22-Jul-2025 18:47 by rmk") + [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 19-Feb-2026 00:03 by rmk") + (* ; "Edited 22-Jul-2025 18:47 by rmk") (* ; "Edited 14-Jul-2025 19:40 by rmk") (* ; "Edited 5-Jul-2025 14:16 by rmk") (* ; "Edited 29-Aug-91 12:19 by jds") @@ -621,6 +620,8 @@ (* ;; "STREAM denotes a device: NIL means DISPLAY, another atom is a device name itself, an IMAGESTREAM means its IMAGESTREAMTYPE. Anything else here maps to DISPLAY, but maybe that should be an illegal arg error, even of NOERRORFLG.") (DECLARE (GLOBALVARS DEFAULTFONT \GUARANTEEDDISPLAYFONT)) + (CL:WHEN (IMAGESTREAMP SPEC) + (SETQ SPEC (DSPFONT NIL SPEC))) (LET (FONT DEVICE TEMP) (CL:UNLESS SPEC (if DEFAULTFONT @@ -704,7 +705,9 @@ (CLOSEF? STRM))))]) (\READCHARSET - [LAMBDA (FONTSPEC CHARSET FONT) (* ; "Edited 11-Nov-2025 14:30 by rmk") + [LAMBDA (FONTSPEC CHARSET FONT) (* ; "Edited 14-Feb-2026 09:47 by rmk") + (* ; "Edited 6-Feb-2026 00:03 by rmk") + (* ; "Edited 11-Nov-2025 14:30 by rmk") (* ; "Edited 2-Sep-2025 23:57 by rmk") (* ; "Edited 28-Aug-2025 23:17 by rmk") (* ; "Edited 25-Aug-2025 12:03 by rmk") @@ -717,13 +720,14 @@ (* ;; "This finds the first file in the directories/extensions order that contains information about charset, determines its format, and reads it in. The assumption is that the first such existing file is the one we want. ") - (CL:WHEN (EQ 0 (fetch (FONTSPEC FSROTATION) of FONTSPEC)) + (CL:WHEN (AND FONTSPEC (EQ 0 (fetch (FONTSPEC FSROTATION) of FONTSPEC))) (RESETLST (for FILE STRM CSINFO in (FONTFILES FONTSPEC CHARSET) do (* ;; "We know that FILE exists and is the best source of information about charset--maybe none. We assume FILE is one of the valid formats, we open it separately for each format-type, and ensure it is closed on exit. We can't used CL:WITHOPEN-FILE because that doesn't exist in the loadup when the first font is created.") - (for FNS FAMILY in (FONTDEVICEPROP FONTSPEC 'CHARSETFNS) + (for FNS FAMILY in [OR (FONTDEVICEPROP FONTSPEC 'CHARSETFNS) + '((MEDLEYFONT MEDLEYFONT.FILEP MEDLEYFONT.GETCHARSET] do [RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT)) `(PROGN (CLOSEF? OLDVALUE] (CL:WHEN (CAR (NLSETQ (APPLY* (CADR FNS) @@ -1028,11 +1032,11 @@ (CL:WHEN (FONTP BASE) (SETQ BASE (FONTPROP BASE 'SPEC))) (create FONTSPEC - FSFAMILY _ (OR FAMILY (fetch (FONTSPEC FSFAMILY) of BASE)) - FSSIZE _ (OR SIZE (fetch (FONTSPEC FSSIZE) of BASE)) - FSFACE _ (OR FACE (fetch (FONTSPEC FSFACE) of BASE)) - FSROTATION _ (OR ROTATION (fetch (FONTSPEC FSROTATION) of BASE)) - FSDEVICE _ (OR DEVICE (fetch (FONTSPEC FSDEVICE) of BASE]) + FSFAMILY ↠(OR FAMILY (fetch (FONTSPEC FSFAMILY) of BASE)) + FSSIZE ↠(OR SIZE (fetch (FONTSPEC FSSIZE) of BASE)) + FSFACE ↠(OR FACE (fetch (FONTSPEC FSFACE) of BASE)) + FSROTATION ↠(OR ROTATION (fetch (FONTSPEC FSROTATION) of BASE)) + FSDEVICE ↠(OR DEVICE (fetch (FONTSPEC FSDEVICE) of BASE]) ) (DEFINEQ @@ -1213,11 +1217,11 @@ then 'MCCS else (fetch (FONTDESCRIPTOR FONTFAMILY) of FONT]) (SPEC (create FONTSPEC - FSFAMILY _ (ffetch FONTFAMILY of FONT) - FSSIZE _ (ffetch FONTSIZE of FONT) - FSFACE _ (COPY (ffetch FONTFACE of FONT)) - FSROTATION _ (ffetch ROTATION of FONT) - FSDEVICE _ (ffetch FONTDEVICE of FONT))) + FSFAMILY ↠(ffetch FONTFAMILY of FONT) + FSSIZE ↠(ffetch FONTSIZE of FONT) + FSFACE ↠(COPY (ffetch FONTFACE of FONT)) + FSROTATION ↠(ffetch ROTATION of FONT) + FSDEVICE ↠(ffetch FONTDEVICE of FONT))) (DEVICESPEC (* ;  "DEVICE fields are for communicating coercions to the particular printing device") (CL:IF (ffetch FONTDEVICESPEC of FONT) @@ -1245,7 +1249,7 @@ (fetch (FONTSPEC FSFACE) of (ffetch FONTDEVICESPEC of FONT)) (ffetch FONTFACE of FONT)))) (SCALE (ffetch FONTSCALE of FONT)) - (CHARSETS (for CS CSINFO (CSVECTOR _ (ffetch FONTCHARSETVECTOR of FONT)) from 0 to + (CHARSETS (for CS CSINFO (CSVECTOR ↠(ffetch FONTCHARSETVECTOR of FONT)) from 0 to \MAXCHARSET eachtime (SETQ CSINFO (\GETBASEPTR CSVECTOR (UNFOLD CS 2))) when CSINFO unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CS)) @@ -1546,7 +1550,8 @@ NEWDESCENT]) (MOVEFONTCHARS - [LAMBDA (PAIRS DESTFONT DEFAULTSOURCEFONT) (* ; "Edited 4-Sep-2025 11:07 by rmk") + [LAMBDA (PAIRS DESTFONT DEFAULTSOURCEFONT) (* ; "Edited 26-Feb-2026 16:59 by rmk") + (* ; "Edited 4-Sep-2025 11:07 by rmk") (* ; "Edited 30-Aug-2025 23:20 by rmk") (* ; "Edited 26-Aug-2025 23:10 by rmk") (* ; "Edited 25-Aug-2025 09:12 by rmk") @@ -1573,27 +1578,37 @@ (FONTCREATE DEFAULTSOURCEFONT NIL NIL NIL (FONTPROP DESTFONT 'DEVICE)) DESTFONT)) - (LET (PAIRINFO) + [if (HARRAYP PAIRS) + then + (* ;; "E.g. *UNICODETOMCCS*") - (* ;; "Fix/check arguments, and expand out the information for all the source characters, so there is no toe-stepping if there are overlaps.") + [MAPHASH PAIRS (FUNCTION (LAMBDA (VAL KEY) + (CL:UNLESS (EQ VAL KEY) + (\MOVEFONTCHAR (\MOVEFONTCHARS.SOURCEDATA KEY + DEFAULTSOURCEFONT) + VAL DESTFONT))] + else (LET (PAIRINFO) - (SETQ PAIRINFO (for P S DCODE in PAIRS collect (CL:WHEN (SMALLP P) - (SETQ P (LIST P P))) - (SETQ DCODE (CADR P)) - (CL:UNLESS (CHARCODEP DCODE) - (SETQ DCODE (CHARCODE.DECODE DCODE))) - (\INSURECHARSETINFO DESTFONT (\CHARSET - DCODE)) - (LIST (\MOVEFONTCHARS.SOURCEDATA - (CAR P) - DEFAULTSOURCEFONT) - DCODE))) + (* ;; "Fix/check arguments, and expand out the information for all the source characters, so there is no toe-stepping if there are overlaps.") - (* ;; "Install source character information into the destination font. ") + (SETQ PAIRINFO (for P S DCODE in PAIRS collect (CL:WHEN (SMALLP P) + (SETQ P (LIST P P))) + (SETQ DCODE (CADR P)) + (CL:UNLESS (CHARCODEP DCODE) + (SETQ DCODE (CHARCODE.DECODE + DCODE))) + (\INSURECHARSETINFO DESTFONT + (\CHARSET DCODE)) + (LIST (\MOVEFONTCHARS.SOURCEDATA + (CAR P) + DEFAULTSOURCEFONT) + DCODE))) - (for P in PAIRINFO do (\MOVEFONTCHAR (CAR P) - (CADR P) - DESTFONT)))) + (* ;; "Install source character information into the destination font. ") + + (for P in PAIRINFO do (\MOVEFONTCHAR (CAR P) + (CADR P) + DESTFONT]) DESTFONT]) (\MOVEFONTCHAR @@ -1634,7 +1649,7 @@ then (\MAKESLUGCHAR DTHINCODE DCSINFO) else (CL:WHEN (fetch (CHARSETINFO CSSLUGP) of DCSINFO) (* ; "No longer a slug csinfo") - (SETQ DCSINFO (create CHARSETINFO copying DCSINFO CSSLUGP _ NIL CSCOMPLETEP _ NIL + (SETQ DCSINFO (create CHARSETINFO copying DCSINFO CSSLUGP ↠NIL CSCOMPLETEP ↠NIL )) (\SETCHARSETINFO DFONT (\CHARSET DCODE) DCSINFO)) @@ -1691,23 +1706,23 @@ then (SETQ SFONT (MKLIST SFONT)) (* ;  "Make it look like a fontspec, then fill in defaults") [SETQ SFONT (FONTCREATE (create FONTSPEC - FSFAMILY _ (OR (fetch (FONTSPEC FSFAMILY) + FSFAMILY ↠(OR (fetch (FONTSPEC FSFAMILY) of SFONT) (FONTPROP DEFAULTSOURCEFONT 'FAMILY)) - FSSIZE _ (OR (fetch (FONTSPEC FSSIZE) + FSSIZE ↠(OR (fetch (FONTSPEC FSSIZE) of SFONT) (FONTPROP DEFAULTSOURCEFONT 'SIZE)) - FSFACE _ (OR (fetch (FONTSPEC FSFACE) + FSFACE ↠(OR (fetch (FONTSPEC FSFACE) of SFONT) (FONTPROP DEFAULTSOURCEFONT 'FACE)) - FSROTATION _ (OR (fetch (FONTSPEC FSROTATION) + FSROTATION ↠(OR (fetch (FONTSPEC FSROTATION) of SFONT) (FONTPROP DEFAULTSOURCEFONT 'ROTATION)) - FSDEVICE _ (OR (fetch (FONTSPEC FSDEVICE) + FSDEVICE ↠(OR (fetch (FONTSPEC FSDEVICE) of SFONT) (FONTPROP DEFAULTSOURCEFONT 'DEVICE] @@ -1840,6 +1855,7 @@ (\FINDFONTFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST) + (* ; "Edited 6-Feb-2026 23:44 by rmk") (* ; "Edited 22-Jan-2026 08:54 by rmk") (* ; "Edited 3-Dec-2025 23:38 by rmk") (* ; "Edited 9-Jun-2025 09:40 by rmk") @@ -1985,7 +2001,7 @@ ((STREAMP DEVICE) (IMAGESTREAMTYPE DEVICE)) [(NULL DEVICE) - (CAR (find I DEXTS (EXT _ (LISTGET FILENAMELIST 'EXTENSION)) in + (CAR (find I DEXTS (EXT ↠(LISTGET FILENAMELIST 'EXTENSION)) in IMAGESTREAMTYPES suchthat (thereis E inside (FONTDEVICEPROP (CAR I) 'FONTEXTENSIONS) @@ -1995,11 +2011,11 @@ (T DEVICE))) (CL:WHEN (AND FAMILY SIZE FACE DEVICE) (create FONTSPEC - FSFAMILY _ FAMILY - FSSIZE _ SIZE - FSFACE _ FACE - FSROTATION _ 0 - FSDEVICE _ DEVICE]) + FSFAMILY ↠FAMILY + FSSIZE ↠SIZE + FSFACE ↠FACE + FSROTATION ↠0 + FSDEVICE ↠DEVICE]) ) (DEFINEQ @@ -2040,11 +2056,11 @@ (FAMILY (SETQ FAMILY VAL)) (SIZE (SETQ SIZE VAL)) (FACE (SETQ FACE (\FONTFACE VAL))) - (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL))) - (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL))) - (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL))) - (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL))) - (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL))) + (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT ↠VAL))) + (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE ↠VAL))) + (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION ↠VAL))) + (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR ↠VAL))) + (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR ↠VAL))) (ROTATION (SETQ ROTATION VAL)) (DEVICE (SETQ DEVICE VAL)) (NOERROR (SETQ NOERROR VAL)) @@ -2058,11 +2074,11 @@ (FAMILY (SETQ FAMILY VAL)) (SIZE (SETQ SIZE VAL)) (FACE (SETQ FACE (\FONTFACE VAL))) - (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL))) - (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL))) - (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL))) - (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL))) - (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL))) + (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT ↠VAL))) + (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE ↠VAL))) + (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION ↠VAL))) + (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR ↠VAL))) + (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR ↠VAL))) (ROTATION (SETQ ROTATION VAL)) (DEVICE (SETQ DEVICE VAL)) (NOERROR (SETQ NOERROR VAL)) @@ -2082,7 +2098,7 @@ else (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR]) (FONTP - [LAMBDA (X) (* rmk%: "13-Sep-84 09:04") + [LAMBDA (X) (* rmk%: "13-Sep-84 09:04") (* ; "is X a FONTDESCRIPTOR?") (COND ((OR (type? FONTDESCRIPTOR X) @@ -2111,7 +2127,7 @@ (* ;; "Seems harmless to include a 0 rotation--any caller would have expected that something might appear there.") (* (create FONTSPEC using SPEC FSFACE - _ FACE FSDEVICE _ NIL)) + ↠FACE FSDEVICE ↠NIL)) (LIST (fetch (FONTSPEC FSFAMILY) of SPEC) (fetch (FONTSPEC FSSIZE) of SPEC) FACE @@ -2136,34 +2152,33 @@ DEVICE]) (\STREAMCHARWIDTH - [LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:31") + [LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:31") (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the various escape sequences. Used by \ECHOCHAR") (SETQ CHARCODE (LOGAND CHARCODE \CHARMASK)) ((LAMBDA (WIDTHSVECTOR) - (* ;; "Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean that the character's glyph simply isn't loaded; e.g., it may want #^A") + (* ;; "Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean that the character's glyph simply isn't loaded; e.g., it may want #↑A") (SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM) (SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM)) (ffetch DDWIDTHSCACHE of WIDTHSVECTOR)) \UNITWIDTHSVECTOR)) - (SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA) - of (OR (TERMTABLEP TTBL) - \PRIMTERMTABLE)) - CHARCODE)) + (SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA) of (OR (TERMTABLEP TTBL) + \PRIMTERMTABLE)) + CHARCODE)) (INDICATE.CCE ([LAMBDA (CC) - (IPLUS (if (IGEQ CHARCODE (CHARCODE %#^@)) - then (* ; - "A META charcode -- implies that the 8th bit is non-zero") - (SETQ CC (LOADBYTE CHARCODE 0 7)) - (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#)) + (IPLUS (if (IGEQ CHARCODE (CHARCODE %#↑@)) + then (* ; + "A META charcode -- implies that the 8th bit is non-zero") + (SETQ CC (LOADBYTE CHARCODE 0 7)) + (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#)) else 0) (if (ILESSP CC (CHARCODE SPACE)) - then (* ; "A CONTROL charcode") - (add CC (CONSTANT (LLSH 1 6))) - (\FGETWIDTH WIDTHSVECTOR (CHARCODE ^)) + then (* ; "A CONTROL charcode") + (add CC (CONSTANT (LLSH 1 6))) + (\FGETWIDTH WIDTHSVECTOR (CHARCODE ↑)) else 0) (\FGETWIDTH WIDTHSVECTOR CC] CHARCODE)) @@ -2176,18 +2191,16 @@ TABWIDTH) (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) [add NEWXPOSITON (SETQ TABWIDTH - (IDIFFERENCE - TABWIDTH - (IMOD (IDIFFERENCE NEWXPOSITON - (DSPLEFTMARGIN NIL - STREAM)) - TABWIDTH] - (RETURN (if (IGREATERP NEWXPOSITON (DSPRIGHTMARGIN - NIL STREAM)) - then - (* ; - "tab was past rightmargin, force cr.") - NIL + (IDIFFERENCE TABWIDTH + (IMOD (IDIFFERENCE NEWXPOSITON + (DSPLEFTMARGIN NIL + STREAM)) + TABWIDTH] + (RETURN (if (IGREATERP NEWXPOSITON (DSPRIGHTMARGIN NIL + STREAM)) + then (* ; + "tab was past rightmargin, force cr.") + NIL else TABWIDTH)))) (\FGETWIDTH WIDTHSVECTOR CHARCODE))) (REAL.CCE (SELECTC CHARCODE @@ -2276,10 +2289,10 @@ (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT))) (replace (FONTDESCRIPTOR FONTSLUGWIDTH) of FONT with SLUGWIDTH)) (SETQ CSINFO (create CHARSETINFO - CHARSETASCENT _ (IDIFFERENCE SLUGHEIGHT DESCENT) - CHARSETDESCENT _ DESCENT - CSSLUGP _ T - CSCOMPLETEP _ T)) + CHARSETASCENT ↠(IDIFFERENCE SLUGHEIGHT DESCENT) + CHARSETDESCENT ↠DESCENT + CSSLUGP ↠T + CSCOMPLETEP ↠T)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I SLUGWIDTH)) (replace IMAGEWIDTHS OF CSINFO with WIDTHS) @@ -2294,7 +2307,7 @@ CSINFO]) (\FONTSYMBOL - [LAMBDA (X ElseReturnXFlg) (* ; "Edited 28-Jul-88 11:59 by rmk:") + [LAMBDA (X ElseReturnXFlg) (* ; "Edited 28-Jul-88 11:59 by rmk:") (* ; "Edited 24-Mar-87 14:32 by FS") (* ;; "Return a symbol in IL package and is in uppercase. Currently the function IL:U-CASE is believed to do this, but if it changes, this is the font hook. ElseReturnXFlg is if you want an IL symbol if X is a symbol or string, otherwise just X.") @@ -2308,7 +2321,7 @@ (T (ERROR "Want an IL symbol"]) (\DEVICESYMBOL - [LAMBDA (X ElseReturnXFlg) (* ; "Edited 7-Oct-88 20:07 by rmk:") + [LAMBDA (X ElseReturnXFlg) (* ; "Edited 7-Oct-88 20:07 by rmk:") (* ; "Edited 28-Jul-88 14:43 by rmk:") (* ; "Edited 24-Mar-87 14:33 by FS") @@ -2316,8 +2329,7 @@ (LET ((STRM (\GETSTREAM X 'OUTPUT T))) (COND - (STRM (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of - STRM))) + (STRM (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of STRM))) ((NULL X) 'DISPLAY) (T (* ; "because its used in ASSOC.") @@ -2445,26 +2457,26 @@ (EQ SLOPE 'REGULAR) (EQ EXPANSION 'REGULAR)) (* ; "BRR") (CONSTANT (create FONTFACE - WEIGHT _ 'BOLD] + WEIGHT ↠'BOLD] [(AND (EQ WEIGHT 'MEDIUM) (EQ SLOPE 'ITALIC) (EQ EXPANSION 'REGULAR)) (* ; "MIR") (CONSTANT (create FONTFACE - SLOPE _ 'ITALIC] + SLOPE ↠'ITALIC] [(AND (EQ WEIGHT 'BOLD) (EQ SLOPE 'ITALIC) (EQ EXPANSION 'REGULAR)) (* ; "BIR") (CONSTANT (create FONTFACE - WEIGHT _ 'BOLD - SLOPE _ 'ITALIC] + WEIGHT ↠'BOLD + SLOPE ↠'ITALIC] (T (* ; "Otherwise, cons up") (create FONTFACE - WEIGHT _ WEIGHT - SLOPE _ SLOPE - EXPANSION _ EXPANSION]) + WEIGHT ↠WEIGHT + SLOPE ↠SLOPE + EXPANSION ↠EXPANSION]) (\FONTFACE.COLOR - [LAMBDA (FACE NOERRORFLG DEV) (* ; "Edited 28-Jul-88 14:51 by rmk:") + [LAMBDA (FACE NOERRORFLG DEV) (* ; "Edited 28-Jul-88 14:51 by rmk:") (* ; "Edited 28-Jul-88 13:09 by rmk:") (* ; "Edited 24-Mar-87 17:03 by FS") @@ -2495,32 +2507,32 @@ [SETQ ANSWER (SELECTQ BWFACE ((* ***) (CONSTANT (create FONTFACE - WEIGHT _ '* - SLOPE _ '* - EXPANSION _ '*))) + WEIGHT ↠'* + SLOPE ↠'* + EXPANSION ↠'*))) ((NIL MRR STANDARD NNN) (CONSTANT (create FONTFACE))) ((ITALIC MIR) (CONSTANT (create FONTFACE - SLOPE _ 'ITALIC))) + SLOPE ↠'ITALIC))) ((BOLD BRR) (CONSTANT (create FONTFACE - WEIGHT _ 'BOLD))) + WEIGHT ↠'BOLD))) ((BOLDITALIC BIR) (CONSTANT (create FONTFACE - WEIGHT _ 'BOLD - SLOPE _ 'ITALIC))) + WEIGHT ↠'BOLD + SLOPE ↠'ITALIC))) (create FONTFACE - WEIGHT _ (SELCHARQ (NTHCHARCODE FACE 1) + WEIGHT ↠(SELCHARQ (NTHCHARCODE FACE 1) (M 'MEDIUM) (B 'BOLD) (L 'LIGHT) (GO ERROR)) - SLOPE _ (SELCHARQ (NTHCHARCODE FACE 2) + SLOPE ↠(SELCHARQ (NTHCHARCODE FACE 2) (R 'REGULAR) (I 'ITALIC) (GO ERROR)) - EXPANSION _ (SELCHARQ (NTHCHARCODE FACE 3) + EXPANSION ↠(SELCHARQ (NTHCHARCODE FACE 3) (R 'REGULAR) (C 'COMPRESSED) (E 'EXPANDED) @@ -2541,12 +2553,10 @@ -1) BITSPERPIXEL)) (* ; - "COPY ANSWER to avoid smashing constants.") + "COPY ANSWER to avoid smashing constants.") (SETQ ANSWER (COPY ANSWER)) - (replace (FONTFACE BACKCOLOR) of ANSWER with BACKCOLOR - ) - (replace (FONTFACE FORECOLOR) of ANSWER with FORECOLOR - ))) + (replace (FONTFACE BACKCOLOR) of ANSWER with BACKCOLOR) + (replace (FONTFACE FORECOLOR) of ANSWER with FORECOLOR))) ANSWER) (T (GO ERROR] @@ -2562,10 +2572,9 @@ (NULL (fetch (FONTFACE COLOR) of ANSWER))) (SETQ FACE (COPY FACE)) (replace (FONTFACE BACKCOLOR) of ANSWER with 0) - (replace (FONTFACE FORECOLOR) of ANSWER with - (MAXIMUMCOLOR ( + (replace (FONTFACE FORECOLOR) of ANSWER with (MAXIMUMCOLOR ( \DISPLAYSTREAMTYPEBPP - DEV))) + DEV))) ANSWER) (T ANSWER))) (RETURN ANSWER) @@ -2639,11 +2648,11 @@ (EQ DEVICE '*] (push $$COLLECT (create FONTSPEC - FSFAMILY _ FM - FSSIZE _ S - FSFACE _ FC - FSROTATION _ R - FSDEVICE _ D)))]) + FSFAMILY ↠FM + FSSIZE ↠S + FSFACE ↠FC + FSROTATION ↠R + FSDEVICE ↠D)))]) (CL:WHEN CHECKFILESTOO? (* ;  "apply the device font lookup function.") (SETQ FILEFONTS (SGETMULTI \FONTSAVAILABLEFILECACHE FAMILY SIZE FACE ROTATION @@ -2700,7 +2709,7 @@ (SETQ DEVICE (fetch (FONTSPEC FSDEVICE) of FONTSPEC)) (SETQ VAL (OR (CAR (FONTFILES (CL:IF (MEMB (fetch (FONTSPEC FSROTATION) of FONTSPEC) '(90 270)) - (create FONTSPEC using FONTSPEC FSROTATION _ 0) + (create FONTSPEC using FONTSPEC FSROTATION ↠0) FONTSPEC))) (APPLY* (OR (CAR (GETMULTI IMAGESTREAMTYPES DEVICE 'FONTEXISTS?)) (CAR (GETMULTI IMAGESTREAMTYPES DEVICE 'FONTSAVAILABLE)) @@ -2734,7 +2743,7 @@ (LET (FAMILY SIZE FACE ROTATION DEVICE) (SPREADFONTSPEC FONTSPEC) - (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH _ 1) + (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH ↠1) in [\FONTFILENAMES FAMILY SIZE FACE DEVICE (MKLIST (FONTDEVICEPROP DEVICE 'FONTEXTENSIONS] do (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY)) @@ -2823,7 +2832,7 @@ [SETQ DIRLST (MKLIST (FONTDEVICEPROP DEVICE 'FONTDIRECTORIES]) (CL:UNLESS EXTLST [SETQ EXTLST (MKLIST (FONTDEVICEPROP DEVICE 'FONTEXTENSIONS]) - (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH _ 1) + (for FILEPATTERN FILEDIR FONTSFOUND (FILING.ENUMERATION.DEPTH ↠1) IN (\FONTFILENAMES FAMILY SIZE FACE DEVICE EXTLST) do (SETQ FILEDIR (FILENAMEFIELD FILEPATTERN 'DIRECTORY)) (SETQ FILEDIR (CL:IF FILEDIR @@ -2924,10 +2933,10 @@ (CL:UNLESS COLOR (SETQ COLOR (COPY (fetch (FONTFACE COLOR) of BASE)))) (create FONTFACE - WEIGHT _ WEIGHT - SLOPE _ SLOPE - EXPANSION _ EXPANSION - COLOR _ COLOR]) + WEIGHT ↠WEIGHT + SLOPE ↠SLOPE + EXPANSION ↠EXPANSION + COLOR ↠COLOR]) (FONTFACETOATOM [LAMBDA (FACE NOERROR) (* ; "Edited 22-Jan-2026 08:13 by rmk") @@ -3037,7 +3046,7 @@ (FONTHASLEFTKERNS FLAG) (* ;  "T if at least one character set has an entry for left kerns") (FONTEXTRAFIELD2 POINTER)) - FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR) + FONTCHARSETVECTOR ↠(\CREATEFONTCHARSETVECTOR) (INIT (DEFPRINT 'FONTDESCRIPTOR (FUNCTION FONTDESCRIPTOR.DEFPRINT)))) (RECORD FONTFACE (WEIGHT SLOPE EXPANSION) @@ -3062,7 +3071,7 @@ (LIST NIL NIL] (RPLACA (CDR (CDDDR DATUM)) NEWVALUE] - WEIGHT _ 'MEDIUM SLOPE _ 'REGULAR EXPANSION _ 'REGULAR (TYPE? LISTP)) + WEIGHT ↠'MEDIUM SLOPE ↠'REGULAR EXPANSION ↠'REGULAR (TYPE? LISTP)) (DATATYPE CHARSETINFO (WIDTHS (* ; "The advance-width of each character, an array indexed by charcode. Usually the same as the imagewidth, but can differ for accents, kerns kerns. This is what should be used for stringwidth calculations.") (CSSLUGP FLAG) (* ; "True if this is a slug charset") @@ -3081,9 +3090,9 @@ LEFTKERN CSINFOPROPS (* ; "Alist of extra properties") (CHARSETNO WORD)) (* ;  "The number of this CSINFO in its font--MAX.SMALLP if not initialized") - WIDTHS _ (\CREATECSINFOELEMENT) - OFFSETS _ (\CREATECSINFOELEMENT) - CHARSETNO _ MAX.SMALLP) + WIDTHS ↠(\CREATECSINFOELEMENT) + OFFSETS ↠(\CREATECSINFOELEMENT) + CHARSETNO ↠MAX.SMALLP) (RECORD FONTSPEC (FSFAMILY FSSIZE FSFACE FSROTATION FSDEVICE) (TYPE? LISTP)) @@ -3483,19 +3492,20 @@ then (APPLY* FN FONTSPEC) else (APPLY FN FONTSPEC))))) else (SETQ FONT (create FONTDESCRIPTOR - FONTFAMILY _ (fetch (FONTSPEC FSFAMILY) of FONTSPEC) - FONTSIZE _ (fetch (FONTSPEC FSSIZE) of FONTSPEC) - FONTFACE _ (fetch (FONTSPEC FSFACE) of FONTSPEC) - ROTATION _ (fetch (FONTSPEC FSROTATION) of FONTSPEC) - FONTDEVICE _ (fetch (FONTSPEC FSDEVICE) of FONTSPEC) - \SFAscent _ 0 - \SFDescent _ 0 - \SFHeight _ 0 - FONTDEVICESPEC _ (create FONTSPEC using FONTSPEC] + FONTFAMILY ↠(fetch (FONTSPEC FSFAMILY) of FONTSPEC) + FONTSIZE ↠(fetch (FONTSPEC FSSIZE) of FONTSPEC) + FONTFACE ↠(fetch (FONTSPEC FSFACE) of FONTSPEC) + ROTATION ↠(fetch (FONTSPEC FSROTATION) of FONTSPEC) + FONTDEVICE ↠(fetch (FONTSPEC FSDEVICE) of FONTSPEC) + \SFAscent ↠0 + \SFDescent ↠0 + \SFHeight ↠0 + FONTDEVICESPEC ↠(create FONTSPEC using FONTSPEC] FONT]) (\CREATECHARSET - [LAMBDA (CHARSET FONT) (* ; "Edited 25-Sep-2025 21:24 by rmk") + [LAMBDA (CHARSET FONT) (* ; "Edited 14-Feb-2026 13:12 by rmk") + (* ; "Edited 25-Sep-2025 21:24 by rmk") (* ; "Edited 2-Sep-2025 22:59 by rmk") (* ; "Edited 31-Aug-2025 14:36 by rmk") (* ; "Edited 28-Aug-2025 14:31 by rmk") @@ -3524,11 +3534,16 @@ (\ILLEGAL.ARG CHARSET)) (LET [(CSINFO (if (fetch (FONTDESCRIPTOR FONTCOMPLETEP) of FONT) then (\GETCHARSETINFO FONT CHARSET) - else (APPLY* (OR (CAR (GETMULTI IMAGESTREAMTYPES (fetch (FONTDESCRIPTOR + else (APPLY* [OR (CAR (GETMULTI IMAGESTREAMTYPES (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT) 'CREATECHARSET)) - (FUNCTION \READCHARSET)) + (FUNCTION (LAMBDA (FONTSPEC FONT CHARSET) + (* ; + "No function: read or read-coerced-font") + (OR (\READCHARSET FONTSPEC CHARSET FONT) + (\READCHARSET (COERCEFONTSPEC FONTSPEC) + CHARSET FONT] (create FONTSPEC using (FONTPROP FONT 'DEVICESPEC)) FONT CHARSET] @@ -3614,9 +3629,9 @@ [LAMBDA (CSINFO FIRSTCHAR LASTCHAR) (* ; "Edited 3-Aug-2025 20:59 by rmk") (* ; "Edited 1-Aug-2025 23:50 by rmk") (* AJB " 6-Dec-85 14:42") - (for CHARCODE LEFT RIGHT SLUGCHAROFFSET SLUGCHARWIDTH (OFFSETS _ (fetch (CHARSETINFO OFFSETS) + (for CHARCODE LEFT RIGHT SLUGCHAROFFSET SLUGCHARWIDTH (OFFSETS ↠(fetch (CHARSETINFO OFFSETS) of CSINFO)) - (WIDTHS _ (fetch (CHARSETINFO WIDTHS) of CSINFO)) from 0 to SLUGCHARINDEX + (WIDTHS ↠(fetch (CHARSETINFO WIDTHS) of CSINFO)) from 0 to SLUGCHARINDEX first (SETQ SLUGCHAROFFSET (\FGETOFFSET OFFSETS SLUGCHARINDEX)) (SETQ SLUGCHARWIDTH (IDIFFERENCE (\FGETOFFSET OFFSETS (ADD1 SLUGCHARINDEX)) SLUGCHAROFFSET)) @@ -3675,15 +3690,15 @@ (* ;; "FONTEXISTS? has determined that there is at least one source file for this font, so the font exists in at least some character sets, d FONTCREATED1 tells us that the font descriptor is not yet availabe.") (create FONTDESCRIPTOR - FONTFAMILY _ (fetch (FONTSPEC FSFAMILY) of FONTSPEC) - FONTSIZE _ (fetch (FONTSPEC FSSIZE) of FONTSPEC) - FONTFACE _ (fetch (FONTSPEC FSFACE) of FONTSPEC) - ROTATION _ (fetch (FONTSPEC FSROTATION) of FONTSPEC) - FONTDEVICE _ (fetch (FONTSPEC FSDEVICE) of FONTSPEC) - \SFAscent _ 0 - \SFDescent _ 0 - \SFHeight _ 0 - FONTDEVICESPEC _ (create FONTSPEC using FONTSPEC]) + FONTFAMILY ↠(fetch (FONTSPEC FSFAMILY) of FONTSPEC) + FONTSIZE ↠(fetch (FONTSPEC FSSIZE) of FONTSPEC) + FONTFACE ↠(fetch (FONTSPEC FSFACE) of FONTSPEC) + ROTATION ↠(fetch (FONTSPEC FSROTATION) of FONTSPEC) + FONTDEVICE ↠(fetch (FONTSPEC FSDEVICE) of FONTSPEC) + \SFAscent ↠0 + \SFDescent ↠0 + \SFHeight ↠0 + FONTDEVICESPEC ↠(create FONTSPEC using FONTSPEC]) (\CREATECHARSET.DISPLAY [LAMBDA (FONTSPEC FONT CHARSET) (* ; "Edited 7-Oct-2025 17:05 by rmk") @@ -3736,14 +3751,14 @@ )) (CL:WHEN (SETQ CSINFO (\CREATECHARSET.DISPLAY (create FONTSPEC using FONTSPEC - FSROTATION _ 0) + FSROTATION ↠0) FONT CHARSET)) (\SFROTATECSINFO CSINFO ROTATION)) elseif (OR (KANJICHARSETP CHARSET) (CHINESECHARSETP CHARSET)) then (CL:UNLESS (EQUAL FACE '(MEDIUM REGULAR REGULAR)) (\CREATECHARSET.DISPLAY (create FONTSPEC - using FONTSPEC FSFACE _ + using FONTSPEC FSFACE ↠'(MEDIUM REGULAR REGULAR)) FONT CHARSET)) elseif (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE)) @@ -3752,7 +3767,7 @@ then (MAKEITALIC.CHARSET FONTSPEC CHARSET FONT) elseif (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE)) then (\CREATECHARSET.DISPLAY (create FONTSPEC - using FONTSPEC FSFACE _ + using FONTSPEC FSFACE ↠'(MEDIUM REGULAR REGULAR)) FONT CHARSET))) CSINFO]) @@ -3773,16 +3788,16 @@ (LET ((FACE (fetch (FONTSPEC FSFACE) of FONTSPEC))) (OR [AND (EQ 'BOLD (fetch (FONTFACE WEIGHT) of FACE)) - (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE _ - (create FONTFACE using FACE WEIGHT _ + (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE ↠+ (create FONTFACE using FACE WEIGHT ↠'MEDIUM] [AND (EQ 'ITALIC (fetch (FONTFACE SLOPE) of FACE)) - (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE _ - (create FONTFACE using FACE SLOPE _ + (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE ↠+ (create FONTFACE using FACE SLOPE ↠'REGULAR] [AND (EQ 'COMPRESSED (fetch (FONTFACE EXPANSION) of FACE)) - (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE _ - (create FONTFACE using FACE EXPANSION _ + (FONTEXISTS? (create FONTSPEC using FONTSPEC FSFACE ↠+ (create FONTFACE using FACE EXPANSION ↠'REGULAR] (COERCEFONTSPEC FONTSPEC (APPEND (FONTDEVICEPROP 'DISPLAY 'FONTCOERCIONS) (FONTDEVICEPROP 'DISPLAY 'CHARCOERCIONS]) @@ -3869,7 +3884,7 @@  "J starts at 1 because we know that the offset of J=0 is 0 ?") (\FSETOFFSET OFFSETS I (\WIN STRM))) - (for I (SLUGOFFSET _ (\WIN STRM)) from 0 to \MAXTHINCHAR + (for I (SLUGOFFSET ↠(\WIN STRM)) from 0 to \MAXTHINCHAR when (EQ 0 (\FGETOFFSET OFFSETS I)) unless (EQ I FIRSTCHAR) do (\FSETOFFSET OFFSETS I SLUGOFFSET) finally (\FSETOFFSET OFFSETS SLUGCHARINDEX SLUGOFFSET) @@ -3943,7 +3958,7 @@ (ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO] (* ; "Offsets. ") - [for I (OFFSET _ 0) from FIRSTCHAR to LASTCHAR first (\WOUT STREAM OFFSET) + [for I (OFFSET ↠0) from FIRSTCHAR to LASTCHAR first (\WOUT STREAM OFFSET) (* ; "Offset of the first char") do (CL:UNLESS (EQ SLUGOFFSET (\FGETOFFSET OFFSETS I)) (* ; @@ -3956,7 +3971,7 @@ (CLOSEF STREAM]) (STRIKECSINFO - [LAMBDA (CSINFO) (* ; "Edited 27-Apr-89 13:39 by atm") + [LAMBDA (CSINFO) (* ; "Edited 27-Apr-89 13:39 by atm") (* ;; "Returns a STRIKE type font descriptor (EQ WIDTHS IMAGEWIDTHS), cause we know how to write those guys out (they read quicker but display slower). If (EQ WIDTHS IMAGEWIDTHS), just return original.") @@ -3972,9 +3987,9 @@ (SETQ BMHEIGHT (BITMAPHEIGHT OLDBM)) [SETQ BMWIDTH (for I from 0 to \MAXTHINCHAR sum (if (IEQP DUMMYOFFSET (\FGETOFFSET OFFSETS I)) - then 0 - else (IMAX (\FGETIMAGEWIDTH IMWIDTHS I) - (\FGETWIDTH WIDTHS I] + then 0 + else (IMAX (\FGETIMAGEWIDTH IMWIDTHS I) + (\FGETWIDTH WIDTHS I] (* ;; "") @@ -3995,17 +4010,17 @@ (SETQ NEWBM (BITMAPCREATE BMWIDTH BMHEIGHT 1)) (SETQ NEWOFFSET 0) - [for I from 0 to 255 - do (SETQ OLDOFFSET (\FGETOFFSET OFFSETS I)) - (if (IEQP DUMMYOFFSET OLDOFFSET) - then (\FSETOFFSET NEWOFFSETS I BMWIDTH) - else (\FSETOFFSET NEWOFFSETS I NEWOFFSET) - (SETQ NEWWIDTH (IMAX (\FGETIMAGEWIDTH IMWIDTHS I) - (\FGETWIDTH WIDTHS I))) - (BITBLT OLDBM OLDOFFSET 0 NEWBM NEWOFFSET 0 (\FGETWIDTH IMWIDTHS I) - BMHEIGHT - 'REPLACE) - (SETQ NEWOFFSET (IPLUS NEWOFFSET NEWWIDTH] + [for I from 0 to 255 do (SETQ OLDOFFSET (\FGETOFFSET OFFSETS I)) + (if (IEQP DUMMYOFFSET OLDOFFSET) + then (\FSETOFFSET NEWOFFSETS I BMWIDTH) + else (\FSETOFFSET NEWOFFSETS I NEWOFFSET) + (SETQ NEWWIDTH (IMAX (\FGETIMAGEWIDTH IMWIDTHS I) + (\FGETWIDTH WIDTHS I))) + (BITBLT OLDBM OLDOFFSET 0 NEWBM NEWOFFSET 0 (\FGETWIDTH + IMWIDTHS I) + BMHEIGHT + 'REPLACE) + (SETQ NEWOFFSET (IPLUS NEWOFFSET NEWWIDTH] (* ;; "") @@ -4014,17 +4029,16 @@ (* ;; "") (SETQ WIDTHS (COPYALL WIDTHS)) - [for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I - (IMAX (\FGETWIDTH WIDTHS I) - (\FGETIMAGEWIDTH IMWIDTHS I] + [for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I (IMAX (\FGETWIDTH WIDTHS I) + (\FGETIMAGEWIDTH IMWIDTHS I] (RETURN (create CHARSETINFO - WIDTHS _ WIDTHS - OFFSETS _ NEWOFFSETS - IMAGEWIDTHS _ WIDTHS - CHARSETBITMAP _ NEWBM - YWIDTHS _ (fetch (CHARSETINFO YWIDTHS) of CSINFO) - CHARSETASCENT _ (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) - CHARSETDESCENT _ (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]) + WIDTHS ↠WIDTHS + OFFSETS ↠NEWOFFSETS + IMAGEWIDTHS ↠WIDTHS + CHARSETBITMAP ↠NEWBM + YWIDTHS ↠(fetch (CHARSETINFO YWIDTHS) of CSINFO) + CHARSETASCENT ↠(fetch (CHARSETINFO CHARSETASCENT) of CSINFO) + CHARSETDESCENT ↠(fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]) ) @@ -4044,11 +4058,11 @@ (* ;; "BOLD is requested in FACE, so we look for an MRR or MIR that we can bold. If we find one, we presume that it is complete for all characters in its face. But there may be other fonts in the coercion chain that have true information about the bold face that we are after. We look for those before we try to adjust the characters in the non-bold CSINFO that we found.") - (LET ([MFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSFACE _ (create FONTFACE + (LET ([MFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSFACE ↠(create FONTFACE using (fetch (FONTSPEC FSFACE) of FONTSPEC) - WEIGHT _ 'MEDIUM] + WEIGHT ↠'MEDIUM] CSINFO) (* ;; "MFONT is the corresponding Medium font.") @@ -4062,7 +4076,7 @@ of MFONT)) (SETQ CSINFO (COPYALL CSINFO)) (* ; "CSINFO is now the CS to be bolded") (\SETCHARSETINFO FONT CHARSET CSINFO) - (for CODE SOURCEFONT (CHARCOERCIONS _ (FONTDEVICEPROP FONT 'CHARCOERCIONS)) + (for CODE SOURCEFONT (CHARCOERCIONS ↠(FONTDEVICEPROP FONT 'CHARCOERCIONS)) from (FIRSTCHARSETCODE CHARSET) to (LASTCHARSETCODE CHARSET) do (if (SLUGCHARP.DISPLAY CODE FONT) then @@ -4115,11 +4129,11 @@ (* ;; "ITALIC is requested, so we look for an MRR or MIR that we can italicize. If we find one, we presume that it is complete for all characters in its face. But there may be other fonts in the coercion chain that have true information about the italic face that we are after. We look for those before we try to adjust the characters in non-italic CSINFO that we found.") - (LET ([RFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSFACE _ (create FONTFACE + (LET ([RFONT (FONTCREATE1 (create FONTSPEC using FONTSPEC FSFACE ↠(create FONTFACE using (fetch (FONTSPEC FSFACE) of FONTSPEC) - SLOPE _ 'REGULAR] + SLOPE ↠'REGULAR] CSINFO) (* ;; "RFONT is the corresponding Regular font.") @@ -4134,7 +4148,7 @@ (SETQ CSINFO (COPYALL CSINFO)) (* ;  "CSINFO is now the CS to be italicized") (\SETCHARSETINFO FONT CHARSET CSINFO) - (for CODE SOURCEFONT (CHARCOERCIONS _ (FONTDEVICEPROP FONT 'CHARCOERCIONS)) + (for CODE SOURCEFONT (CHARCOERCIONS ↠(FONTDEVICEPROP FONT 'CHARCOERCIONS)) from (FIRSTCHARSETCODE CHARSET) to (LASTCHARSETCODE CHARSET) do (if (SLUGCHARP.DISPLAY CODE FONT) then @@ -4217,7 +4231,7 @@  "fill in the slug for the magic charcode") (BITBLT OLDCHARBITMAP SLUGOFFSET 0 NEWCHARBITMAP SLUGOFFSET 0 SLUGWIDTH HEIGHT 'INPUT 'REPLACE) - (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWCHARBITMAP]) + (create CHARSETINFO using CSINFO CHARSETBITMAP ↠NEWCHARBITMAP]) (\SFMAKEITALIC [LAMBDA (CSINFO) (* ; "Edited 16-Jun-2025 23:20 by rmk") @@ -4255,12 +4269,12 @@ 'INPUT 'REPLACE))] (BITBLT OLDBITMAP SLUGOFFSET 0 NEWBITMAP SLUGOFFSET 0 SLUGWIDTH HEIGHT 'INPUT 'REPLACE) - (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWBITMAP]) + (create CHARSETINFO using CSINFO CHARSETBITMAP ↠NEWBITMAP]) ) (DEFINEQ (\SFMAKEROTATEDFONT - [LAMBDA (FONTDESC ROTATION) (* ; "Edited 30-Mar-87 20:35 by FS") + [LAMBDA (FONTDESC ROTATION) (* ; "Edited 30-Mar-87 20:35 by FS") (* ;; "takes a fontdecriptor and rotates it.") @@ -4268,33 +4282,31 @@ (HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields") (* (create FONTDESCRIPTOR using - FONTDESC (SETQ CHARACTERBITMAP - (\SFROTATEFONTCHARACTERS - (fetch (FONTDESCRIPTOR - CHARACTERBITMAP) of FONTDESC) - ROTATION)) (SETQ ROTATION ROTATION) - (SETQ \SFOffsets ( - \SFFIXOFFSETSAFTERROTATION FONTDESC - ROTATION)) (SETQ FONTCHARSETVECTOR - (\ALLOCBLOCK (ADD1 \MAXCHARSET) T)))) + FONTDESC (SETQ CHARACTERBITMAP + (\SFROTATEFONTCHARACTERS + (fetch (FONTDESCRIPTOR CHARACTERBITMAP) + of FONTDESC) ROTATION)) (SETQ ROTATION ROTATION) (SETQ \SFOffsets (\SFFIXOFFSETSAFTERROTATION + FONTDESC ROTATION)) (SETQ + FONTCHARSETVECTOR (\ALLOCBLOCK + (ADD1 \MAXCHARSET) T)))) (* ;; "If you uncomment out the code above, remove this comment and the NIL below") NIL]) (\SFROTATECSINFO - [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38") + [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38") (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.") - (create CHARSETINFO using CSINFO CHARSETBITMAP _ (\SFROTATEFONTCHARACTERS - (fetch (CHARSETINFO CHARSETBITMAP) - of CSINFO) - ROTATION) - OFFSETS _ (\SFROTATECSINFOOFFSETS CSINFO ROTATION]) + (create CHARSETINFO using CSINFO CHARSETBITMAP ↠(\SFROTATEFONTCHARACTERS (fetch (CHARSETINFO + CHARSETBITMAP) + of CSINFO) + ROTATION) + OFFSETS ↠(\SFROTATECSINFOOFFSETS CSINFO ROTATION]) (\SFROTATEFONTCHARACTERS - [LAMBDA (CHARBITMAP ROTATION) (* ; "Edited 22-Sep-87 10:38 by Snow") + [LAMBDA (CHARBITMAP ROTATION) (* ; "Edited 22-Sep-87 10:38 by Snow") (* ;;; "rotate a bitmap either 90 or 270 for fonts.") @@ -4331,7 +4343,7 @@ (DEFINEQ (\SFMAKECOLOR - [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL) (* kbr%: " 6-Feb-86 18:17") + [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL) (* kbr%: " 6-Feb-86 18:17") (* ;; "makes a csinfo that has a character bitmap that is colorized.") @@ -4347,12 +4359,9 @@ (T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL] (SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL)) (SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL)) - (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of - BWCSINFO - ) + (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of BWCSINFO) BACKCOLOR FORECOLOR BITSPERPIXEL)) - (SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP _ - CHARACTERBITMAP)) + (SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP ↠CHARACTERBITMAP)) (RETURN COLORCSINFO]) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -4484,43 +4493,43 @@ (ADDTOVAR LAMA FONTCOPY) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (11455 21168 (CHARWIDTH 11465 . 12250) (CHARWIDTHY 12252 . 13769) (STRINGWIDTH 13771 . -14864) (\CHARWIDTH.DISPLAY 14866 . 15279) (\STRINGWIDTH.DISPLAY 15281 . 15705) (\STRINGWIDTH.GENERIC -15707 . 21166)) (21169 27689 (DEFAULTFONT 21179 . 22464) (FONTCLASS 22466 . 24628) (FONTCLASSUNPARSE -24630 . 25529) (FONTCLASSCOMPONENT 25531 . 26119) (SETFONTCLASSCOMPONENT 26121 . 26563) ( -GETFONTCLASSCOMPONENT 26565 . 27687)) (29402 46906 (FONTCREATE 29412 . 32657) (FONTCREATE1 32659 . -35274) (FONTCREATE.SLUGFD 35276 . 36758) (\FONT.CHECKARGS1 36760 . 41283) (\FONTCREATE1.NOFN 41285 . -41499) (FONTFILEP 41501 . 42389) (\READCHARSET 42391 . 46904)) (46907 53983 (\FONT.CHECKARGS 46917 . -53666) (\CHARSET.CHECK 53668 . 53981)) (53984 60595 (COERCEFONTSPEC 53994 . 59906) ( -COERCEFONTSPEC.TARGETFACE 59908 . 60593)) (62790 64129 (MAKEFONTSPEC 62800 . 64127)) (64130 72307 ( -COMPLETE.FONT 64140 . 66663) (COMPLETEFONTP 66665 . 67288) (COMPLETE.CHARSET 67290 . 69975) ( -PRUNESLUGCSINFOS 69977 . 70902) (MONOSPACEFONTP 70904 . 72305)) (72346 80792 (FONTASCENT 72356 . 72740 -) (FONTDESCENT 72742 . 73227) (FONTHEIGHT 73229 . 73631) (FONTPROP 73633 . 80069) (\AVGCHARWIDTH 80071 - . 80790)) (81449 82357 (FONTDEVICEPROP 81459 . 82355)) (82403 83257 (EDITCHAR 82413 . 83255)) (83303 -95493 (GETCHARBITMAP 83313 . 84437) (PUTCHARBITMAP 84439 . 86597) (\GETCHARBITMAP.CSINFO 86599 . 88615 -) (\PUTCHARBITMAP.CSINFO 88617 . 95491)) (95494 115974 (MOVECHARBITMAP 95504 . 97398) (MOVEFONTCHARS -97400 . 101360) (\MOVEFONTCHAR 101362 . 106205) (\MOVEFONTCHARS.SOURCEDATA 106207 . 112312) ( -\MAKESLUGCHAR 112314 . 114849) (SLUGCHARP.DISPLAY 114851 . 115972)) (116632 128360 (FONTFILES 116642 - . 118475) (\FINDFONTFILE 118477 . 120345) (\FONTFILENAMES 120347 . 120907) (\FONTFILENAME 120909 . -123820) (FONTSPECFROMFILENAME 123822 . 128358)) (128361 164936 (FONTCOPY 128371 . 133434) (FONTP -133436 . 133735) (FONTUNPARSE 133737 . 135456) (SETFONTDESCRIPTOR 135458 . 136922) (\STREAMCHARWIDTH -136924 . 141088) (\COERCECHARSET 141090 . 144457) (\BUILDSLUGCSINFO 144459 . 148082) (\FONTSYMBOL -148084 . 148734) (\DEVICESYMBOL 148736 . 149605) (\FONTFACE 149607 . 156797) (\FONTFACE.COLOR 156799 - . 163719) (SETFONTCHARENCODING 163721 . 164934)) (164937 184598 (FONTSAVAILABLE 164947 . 170301) ( -FONTEXISTS? 170303 . 173842) (\SEARCHFONTFILES 173844 . 176929) (FLUSHFONTCACHE 176931 . 179154) ( -FINDFONTFILES 179156 . 182370) (SORTFONTSPECS 182372 . 184596)) (184599 188706 (MATCHFONTFACE 184609 - . 185424) (MAKEFONTFACE 185426 . 186452) (FONTFACETOATOM 186454 . 188704)) (189337 189829 ( -\UNITWIDTHSVECTOR 189347 . 189827)) (204458 206525 (FONTDESCRIPTOR.DEFPRINT 204468 . 206047) ( -FONTCLASS.DEFPRINT 206049 . 206523)) (210354 213144 (\CREATEKERNELEMENT 210364 . 210722) ( -\FSETLEFTKERN 210724 . 211215) (\FGETLEFTKERN 211217 . 213142)) (213145 224220 (\CREATEFONT 213155 . -216033) (\CREATECHARSET 216035 . 219971) (\INSTALLCHARSETINFO 219973 . 223307) ( -\INSTALLCHARSETINFO.CHARENCODING 223309 . 224218)) (224542 225906 (\FONTRESETCHARWIDTHS 224552 . -225904)) (226536 236577 (\CREATEDISPLAYFONT 226546 . 228395) (\CREATECHARSET.DISPLAY 228397 . 234106) -(\FONTEXISTS?.DISPLAY 234108 . 236575)) (236578 251443 (STRIKEFONT.FILEP 236588 . 237476) ( -STRIKEFONT.GETCHARSET 237478 . 243070) (WRITESTRIKEFONTFILE 243072 . 247983) (STRIKECSINFO 247985 . -251441)) (251474 267791 (MAKEBOLD.CHARSET 251484 . 255133) (MAKEBOLD.CHAR 255135 . 256887) ( -MAKEITALIC.CHARSET 256889 . 260562) (MAKEITALIC.CHAR 260564 . 262910) (\SFMAKEBOLD 262912 . 265136) ( -\SFMAKEITALIC 265138 . 267789)) (267792 271941 (\SFMAKEROTATEDFONT 267802 . 269203) (\SFROTATECSINFO -269205 . 269842) (\SFROTATEFONTCHARACTERS 269844 . 270224) (\SFROTATECSINFOOFFSETS 270226 . 271939)) ( -271942 273323 (\SFMAKECOLOR 271952 . 273321))))) + (FILEMAP (NIL (11429 21096 (CHARWIDTH 11439 . 12228) (CHARWIDTHY 12230 . 13747) (STRINGWIDTH 13749 . +14786) (\CHARWIDTH.DISPLAY 14788 . 15203) (\STRINGWIDTH.DISPLAY 15205 . 15633) (\STRINGWIDTH.GENERIC +15635 . 21094)) (21097 27729 (DEFAULTFONT 21107 . 22392) (FONTCLASS 22394 . 24666) (FONTCLASSUNPARSE +24668 . 25569) (FONTCLASSCOMPONENT 25571 . 26159) (SETFONTCLASSCOMPONENT 26161 . 26603) ( +GETFONTCLASSCOMPONENT 26605 . 27727)) (29442 47482 (FONTCREATE 29452 . 32697) (FONTCREATE1 32699 . +35314) (FONTCREATE.SLUGFD 35316 . 36820) (\FONT.CHECKARGS1 36822 . 41527) (\FONTCREATE1.NOFN 41529 . +41743) (FONTFILEP 41745 . 42633) (\READCHARSET 42635 . 47480)) (47483 54559 (\FONT.CHECKARGS 47493 . +54242) (\CHARSET.CHECK 54244 . 54557)) (54560 61171 (COERCEFONTSPEC 54570 . 60482) ( +COERCEFONTSPEC.TARGETFACE 60484 . 61169)) (63366 64715 (MAKEFONTSPEC 63376 . 64713)) (64716 72893 ( +COMPLETE.FONT 64726 . 67249) (COMPLETEFONTP 67251 . 67874) (COMPLETE.CHARSET 67876 . 70561) ( +PRUNESLUGCSINFOS 70563 . 71488) (MONOSPACEFONTP 71490 . 72891)) (72932 81390 (FONTASCENT 72942 . 73326 +) (FONTDESCENT 73328 . 73813) (FONTHEIGHT 73815 . 74217) (FONTPROP 74219 . 80667) (\AVGCHARWIDTH 80669 + . 81388)) (82047 82955 (FONTDEVICEPROP 82057 . 82953)) (83001 83855 (EDITCHAR 83011 . 83853)) (83901 +96091 (GETCHARBITMAP 83911 . 85035) (PUTCHARBITMAP 85037 . 87195) (\GETCHARBITMAP.CSINFO 87197 . 89213 +) (\PUTCHARBITMAP.CSINFO 89215 . 96089)) (96092 117372 (MOVECHARBITMAP 96102 . 97996) (MOVEFONTCHARS +97998 . 102744) (\MOVEFONTCHAR 102746 . 107593) (\MOVEFONTCHARS.SOURCEDATA 107595 . 113710) ( +\MAKESLUGCHAR 113712 . 116247) (SLUGCHARP.DISPLAY 116249 . 117370)) (118030 129879 (FONTFILES 118040 + . 119873) (\FINDFONTFILE 119875 . 121852) (\FONTFILENAMES 121854 . 122414) (\FONTFILENAME 122416 . +125327) (FONTSPECFROMFILENAME 125329 . 129877)) (129880 166129 (FONTCOPY 129890 . 134973) (FONTP +134975 . 135274) (FONTUNPARSE 135276 . 136999) (SETFONTDESCRIPTOR 137001 . 138465) (\STREAMCHARWIDTH +138467 . 142478) (\COERCECHARSET 142480 . 145847) (\BUILDSLUGCSINFO 145849 . 149480) (\FONTSYMBOL +149482 . 150136) (\DEVICESYMBOL 150138 . 150922) (\FONTFACE 150924 . 158128) (\FONTFACE.COLOR 158130 + . 164912) (SETFONTCHARENCODING 164914 . 166127)) (166130 185807 (FONTSAVAILABLE 166140 . 171504) ( +FONTEXISTS? 171506 . 175047) (\SEARCHFONTFILES 175049 . 178136) (FLUSHFONTCACHE 178138 . 180361) ( +FINDFONTFILES 180363 . 183579) (SORTFONTSPECS 183581 . 185805)) (185808 189923 (MATCHFONTFACE 185818 + . 186633) (MAKEFONTFACE 186635 . 187669) (FONTFACETOATOM 187671 . 189921)) (190554 191046 ( +\UNITWIDTHSVECTOR 190564 . 191044)) (205689 207756 (FONTDESCRIPTOR.DEFPRINT 205699 . 207278) ( +FONTCLASS.DEFPRINT 207280 . 207754)) (211585 214375 (\CREATEKERNELEMENT 211595 . 211953) ( +\FSETLEFTKERN 211955 . 212446) (\FGETLEFTKERN 212448 . 214373)) (214376 226042 (\CREATEFONT 214386 . +217282) (\CREATECHARSET 217284 . 221793) (\INSTALLCHARSETINFO 221795 . 225129) ( +\INSTALLCHARSETINFO.CHARENCODING 225131 . 226040)) (226364 227732 (\FONTRESETCHARWIDTHS 226374 . +227730)) (228362 238439 (\CREATEDISPLAYFONT 228372 . 230239) (\CREATECHARSET.DISPLAY 230241 . 235956) +(\FONTEXISTS?.DISPLAY 235958 . 238437)) (238440 253445 (STRIKEFONT.FILEP 238450 . 239338) ( +STRIKEFONT.GETCHARSET 239340 . 244934) (WRITESTRIKEFONTFILE 244936 . 249849) (STRIKECSINFO 249851 . +253443)) (253476 269809 (MAKEBOLD.CHARSET 253486 . 257141) (MAKEBOLD.CHAR 257143 . 258895) ( +MAKEITALIC.CHARSET 258897 . 262576) (MAKEITALIC.CHAR 262578 . 264924) (\SFMAKEBOLD 264926 . 267152) ( +\SFMAKEITALIC 267154 . 269807)) (269810 273834 (\SFMAKEROTATEDFONT 269820 . 271054) (\SFROTATECSINFO +271056 . 271731) (\SFROTATEFONTCHARACTERS 271733 . 272117) (\SFROTATECSINFOOFFSETS 272119 . 273832)) ( +273835 275009 (\SFMAKECOLOR 273845 . 275007))))) STOP diff --git a/sources/FONT.LCOM b/sources/FONT.LCOM index ff23fcfb..a5dd6584 100644 Binary files a/sources/FONT.LCOM and b/sources/FONT.LCOM differ diff --git a/sources/IOCHAR b/sources/IOCHAR index ac4b8fe8..1458efc7 100644 --- a/sources/IOCHAR +++ b/sources/IOCHAR @@ -1,15 +1,14 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "24-Aug-2025 11:45:37"  -{DSK}kaplan>Local>medley3.5>working-medley>sources>IOCHAR.;49 100320 +(FILECREATED " 5-Feb-2026 10:06:08" {WMEDLEY}IOCHAR.;56 113942 :EDIT-BY rmk - :CHANGES-TO (RESOURCES \FFDELTA1) - (FNS MAKEBITTABLE \SETUP.FFILEPOS) + :CHANGES-TO (FNS FILEPOS FFILEPOS) + (MACROS \CATRANSLATE) + (VARS IOCHARCOMS) - :PREVIOUS-DATE "24-Apr-2025 22:08:18" -{DSK}kaplan>Local>medley3.5>working-medley>sources>IOCHAR.;48) + :PREVIOUS-DATE " 3-Feb-2026 10:00:18" {WMEDLEY}IOCHAR.;51) (PRETTYCOMPRINT IOCHARCOMS) @@ -74,96 +73,468 @@ (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))) -) + [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))) -) + [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))))) -) + [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))))) -) + [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))) + [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))))))) -) + [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) + '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) + 'EQUAL) + (T '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 '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))) -) + [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))) -) + [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") + [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.") + (* ;; "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") + (* ;; "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.") + (* ;; " 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.") + (* ;; "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.") + (* ;; "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 ") + (* ;; "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 + (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") - (* ;; - "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") - (\PUTBASEFAT PBASE N C) - ELSEIF (ILEQ C \MAXTHINCHAR) - THEN + (\PUTBASETHIN PBASE N C) + ELSE + (* ;; "First fat, perhaps there are previous thins to convert. Go backwards so we don't smash the early ones") - (* ;; "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]) + (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)))) -) + [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)))) -) + [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)) -) + [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"))))) -) + [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*)) @@ -200,8 +571,59 @@ (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)))) -) + [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 24-Aug-2025 11:45 by rmk") @@ -229,12 +651,21 @@ (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))))) -) + [LAMBDA (OLDAR) (* lmm "20-MAR-81 10:21") + (COND + (OLDAR (COPYARRAY OLDAR)) + (T (PROG ((AR (ARRAY 256 '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)))) -) + [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) @@ -260,6 +691,10 @@ DONTCOPY (FILEPOS [LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) + (* ;; "Edited 5-Feb-2026 10:02 by rmk") + + (* ;; "Edited 3-Feb-2026 10:59 by rmk") + (* ;; "Edited 24-Apr-2025 22:08 by rmk") (* ;; "Edited 10-Jul-2022 16:51 by rmk") @@ -268,7 +703,7 @@ DONTCOPY (* ;; "Edited 25-Jun-2022 22:51 by rmk: The original version was a byte-level searcher, this upgrades to character searching as determined by the external format of the stream. (It is also a bit faster than the original).") - (* ;; "This provides accurate results if the stream's external format is stable, wherein each character code has a unique byte representation. If the stream's format is unstable (i.e. MCCS runcoding), then the result is accurate if the stream's initial charset (or other contextual information) is correct for the START byte position.") + (* ;; "This provides accurate results if the stream's external format is stable, wherein each character code has a unique byte representation. If the stream's format is unstable (i.e. XCCS runcoding vs 2-byte codes), then the result is accurate if the stream's initial charset (or other contextual information) is correct for the START byte position.") (* ;; "Otherwise, there may be some bad matches and some missing matches. The slow case will be accurate in those cases (and a NIL return for the format's \FORMATBYTESTRING function will kick it into the slow case (about 10 times slower). This always defers to the slow case if SKIP or CASEARRAY are non-NIL.") @@ -317,8 +752,12 @@ DONTCOPY (* ;; "Empty string: succed. Already positioned at STARTBYTEPOS") (RETURN STARTBYTEPOS)) - (CL:WHEN [OR CASEARRAY (AND SKIP (STRPOS SKIP PATTERN)) - (NOT (SETQ PATSTR (\FORMATBYTESTRING STREAM PATTERN] + (CL:WHEN [OR CASEARRAY (fetch (EXTERNALFORMAT UNSTABLE) of (FIND-FORMAT (STREAMPROP STREAM + + :EXTERNAL-FORMAT + ))) + (AND SKIP (STRPOS SKIP PATTERN)) + (NOT (SETQ PATSTR (MCCSTOFORMATBYTES STREAM PATTERN] (RETURN (OR (\SLOWFILEPOS PATTERN STREAM STARTBYTEPOS ENDBYTEPOS SKIP TAIL CASEARRAY) (GO FAILED)))) @@ -382,16 +821,11 @@ DONTCOPY FOUNDIT - (* ;; "The stream's charset should be set to the charset corresponding to the return byte-position. We haven't been tracking it, but if we are returning the tail pointer, then the stream's character set must be the same as the character set of the last character o fPATTERN.") - - (* ;; "Getting the character set for the start of the match is a little trickier. We know the character set at the byte that starts the beginning of the match (= character set of PATTERN's first character. If we set the stream to that charset, then back up one character, that should get it right. ") - - (* ;; "This should only be necessary for an unstable format, maybe don't bother if it isn't XCCS. There is another special case here for MCCS: if the charset is 255 at the start (=2 byte encoding), then we assume that it didn't change, and nothing to worry about.") + (* ;; "The stream's charset should be set to the charset corresponding to the return byte-position. We haven't been tracking it, but if we are returning the tail pointer, then the stream's character set must be the same as the character set of the last character of PATTERN. If returning the start, then the stream's charset must be the charset of the first character.") (RETURN (IF TAIL - THEN (CL:UNLESS (EQ NSCHARSETSHIFT (ffetch (STREAM CHARSET) of STREAM)) - (freplace (STREAM CHARSET) of STREAM with (\CHARSET (NTHCHARCODE - PATTERN -1)))) + THEN (freplace (STREAM CHARSET) of STREAM with (\CHARSET (NTHCHARCODE PATTERN + -1))) (CL:IF (EQ TAIL 'BOTH) (CONS (IDIFFERENCE (\GETFILEPTR STREAM) PATLEN) @@ -403,10 +837,8 @@ DONTCOPY (\INCFILEPTR STREAM (IMINUS PATLEN)) (SETQ STARTBYTEPOS (\GETFILEPTR STREAM)) - (CL:UNLESS (EQ NSCHARSETSHIFT (ffetch (STREAM CHARSET) of STREAM)) - (freplace (STREAM CHARSET) of STREAM with (\CHARSET (CHCON1 PATTERN))) - (\BACKCCODE STREAM) (* ; "Should fix the charset") - (\SETFILEPTR STREAM STARTBYTEPOS)) + (\SETFILEPTR STREAM STARTBYTEPOS) + (freplace (STREAM CHARSET) of STREAM with (\CHARSET (CHCON1 PATTERN))) STARTBYTEPOS)) FAILED (\SETFILEPTR STREAM ORGFILEPTR) (* ; @@ -416,6 +848,10 @@ DONTCOPY (FFILEPOS [LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) + (* ;; "Edited 5-Feb-2026 10:02 by rmk") + + (* ;; "Edited 3-Feb-2026 09:55 by rmk") + (* ;; "Edited 24-Apr-2025 22:07 by rmk") (* ;; "Edited 10-Jul-2022 10:17 by rmk") @@ -431,8 +867,13 @@ DONTCOPY (PROG ((STREAM (\GETSTREAM FILE 'INPUT)) BYTEPATTERN BPATBASE BPATOFFSET BPATLEN ORGFILEPTR STARTBYTEPOS ENDBYTEPOS BIGENDOFFSET STARTSEG ENDSEG EOF) - (CL:WHEN [OR SKIP CASEARRAY (NOT (fetch PAGEMAPPED of (fetch (STREAM DEVICE) of STREAM))) - (NULL (SETQ BYTEPATTERN (\FORMATBYTESTRING STREAM PATTERN] + (CL:WHEN [OR CASEARRAY (fetch (EXTERNALFORMAT UNSTABLE) of (FIND-FORMAT (STREAMPROP STREAM + + :EXTERNAL-FORMAT + ))) + (AND SKIP (STRPOS SKIP PATTERN)) + (NOT (fetch PAGEMAPPED of (fetch (STREAM DEVICE) of STREAM))) + (NULL (SETQ BYTEPATTERN (MCCSTOFORMATBYTES STREAM PATTERN] (* ; "Slow case--use FILEPOS") (GO TRYFILEPOS)) (* ;  "calculate start addr and set file ptr.") @@ -827,19 +1268,24 @@ DONTCOPY (DEFINEQ (DATE -(LAMBDA (FORMAT) (* raf "16-Oct-86 17:16") (\OUTDATE (\UNPACKDATE) FORMAT))) + [LAMBDA (FORMAT) (* raf "16-Oct-86 17:16") + (\OUTDATE (\UNPACKDATE) + FORMAT]) (DATEFORMAT -(NLAMBDA FORMAT (* raf "16-Oct-86 17:17") (CONS (QUOTE DATEFORMAT) FORMAT))) + [NLAMBDA FORMAT (* raf "16-Oct-86 17:17") + (CONS 'DATEFORMAT FORMAT]) (GDATE -(LAMBDA (DATE FORMAT STRPTR) (* raf "16-Oct-86 17:17") (\OUTDATE (\UNPACKDATE DATE) FORMAT STRPTR))) + [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") + [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") + (* ;; "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) @@ -851,16 +1297,16 @@ DONTCOPY TOP (OR (SETQ N1 (\IDATESCANTOKEN)) (RETURN NIL)) (SELCHARQ (NTHCHARCODE *STR* *POS*) - ((/ - SPACE) (* ; "Okay to put inside date") + ((/ - 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))) + 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))) + then (* ; "Abbreviated month?") + (add *POS* 1))) NIL) (OR (SETQ N2 (\IDATESCANTOKEN)) (RETURN NIL)) @@ -868,52 +1314,52 @@ DONTCOPY ((/ - SPACE %,) (add *POS* 1)) ("." (if (LISTP N2) - then (* ; "Abbreviated month?") - (add *POS* 1))) + 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)) + 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") + (> 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) + then (* ; "Must be month-day") + (SETQ DAY N2) + (SETQ MONTH N1) elseif (FIXP (SETQ DAY N1)) - then (* ; "day-month") - (SETQ MONTH N2) + then (* ; "day-month") + (SETQ MONTH N2) else (RETURN NIL)) (if (FIXP MONTH) then (if (OR (< MONTH 1) - (> MONTH 12)) - then (* ; "invalid month") - (RETURN NIL)) + (> 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))) + (> 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)) + (CHARCODE SPACE)) do (* ; "Skip spaces") + (add *POS* 1)) (SELCHARQ (NTHCHARCODE *STR* *POS*) - ("," (* ; "Ok to terminate date with comma") + ("," (* ; "Ok to terminate date with comma") (add *POS* 1)) - (NIL (* ; - "No time. Ok if DEFAULTTIME passed in") + (NIL (* ; + "No time. Ok if DEFAULTTIME passed in") (if (NULL DEFAULTTIME) then (RETURN NIL)) (SETQ SECONDS (IREMAINDER DEFAULTTIME 60)) @@ -923,63 +1369,60 @@ DONTCOPY (GO DONE)) NIL) - (* ;; "Now scan time") + (* ;; "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))) + (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] + 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] + (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") + (* ;; "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] + (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") + ((+ -) (* ; "Explicit offset +-hhmm from GMT") (add *POS* 1) (if [NOT (FIXP (SETQ TIMEZONE (\IDATESCANTOKEN] then (RETURN NIL)) @@ -987,40 +1430,39 @@ DONTCOPY (CL:TRUNCATE TIMEZONE 100) (SETQ TIMEZONE (if (EQ M 0) then H - else (* ; "Non-hour timezone. Use ratios.") - (+ H (/ M 60] + 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)))) + 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*))) + 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)) + then (add *POS* 1) + (GO LP)) + else (* ; "Non-alphabetic in timezone") + (RETURN NIL)) - (* ;; "Potential time zone from START to before POS") + (* ;; "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") + (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) @@ -1032,7 +1474,7 @@ DONTCOPY TIMEZONE]) (\IDATESCANTOKEN - [LAMBDA NIL (* ; "Edited 4-May-89 15:20 by bvm") + [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") @@ -1048,16 +1490,16 @@ DONTCOPY ((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] + (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]) + (ALPHACHARP CH)) collect (UCASECODE CH]) (\IDATE-PARSE-MONTH - [LAMBDA (MONTH) (* ; "Edited 4-May-89 14:54 by bvm") + [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") @@ -1068,28 +1510,26 @@ DONTCOPY (* ;; "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 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] + 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.") @@ -1097,18 +1537,18 @@ DONTCOPY (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] + ,(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_)") + "This LET is solely to allow more compact code (PVAR_ is one byte less than IVARX_)") (DISCRIMINATE '(("JANUARY" 1) ("FEBRUARY" 2) ("MARCH" 3) @@ -1123,7 +1563,7 @@ DONTCOPY ("DECEMBER" 12]) (\OUTDATE - [LAMBDA (UD FORMAT STRING) (* ; "Edited 3-May-2018 00:02 by rmk:") + [LAMBDA (UD FORMAT STRING) (* ; "Edited 3-May-2018 00:02 by rmk:") (DESTRUCTURING-BIND (YEAR MONTH DAY HOUR MINUTE SECOND DST WDAY) UD @@ -1136,223 +1576,224 @@ DONTCOPY (if (NOT FORMAT) then NIL elseif (NEQ (CAR (LISTP FORMAT)) - 'DATEFORMAT) + '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") + 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)) + 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] + 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 ")"] + 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] + 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") + [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))) + 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]) + 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))))) -) + [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") + [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.") @@ -1363,7 +1804,7 @@ DONTCOPY 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.") + "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)) @@ -1372,73 +1813,70 @@ DONTCOPY [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))) + 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] + 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)) + 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") + "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") + (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") + "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)") + "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") - (* ;; "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") - (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 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") + (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) @@ -1446,9 +1884,9 @@ DONTCOPY 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.") + [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 @@ -1473,8 +1911,8 @@ DONTCOPY (IQUOTIENT YR 4))) [COND ((> MONTH 1) (* ; "After February 28") - (add YDAY 1) (* ; - "Day-of-year for dst is based on 366-day year") + (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") @@ -1482,37 +1920,67 @@ DONTCOPY (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") + (COND + (TIMEZONE) + ((AND \DayLightSavings (\ISDST? YDAY HR (IREMAINDER (+ DAYSSINCEDAY0 1) + 7))) - (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") + (* ;; "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") + (* ;; "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)))) -) + [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)))) -) + [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))))) -) + [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) @@ -1566,7 +2034,7 @@ DONTCOPY (LOCALVARS . T) ) -(PUTPROPS IOCHAR FILETYPE CL:COMPILE-FILE) +(PUTPROPS IOCHAR FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DATEFORMAT) @@ -1576,15 +2044,16 @@ DONTCOPY (ADDTOVAR LAMA PACK* CONCAT) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3501 7295 (CHCON 3511 . 4361) (UNPACK 4363 . 5257) (DCHCON 5259 . 6526) (DUNPACK 6528 - . 7293)) (7296 18811 (UALPHORDER 7306 . 7402) (ALPHORDER 7404 . 9207) (CONCAT 9209 . 9854) ( -CONCATCODES 9856 . 10042) (PACKC 10044 . 12647) (PACK 12649 . 13228) (PACK* 13230 . 14952) (\PACK.ITEM - 14954 . 15409) (STRPOS 15411 . 18809)) (18813 19102 (XCL:PACK 18813 . 19102)) (19104 19354 (XCL:PACK* - 19104 . 19354)) (20061 22561 (STRPOSL 20071 . 21697) (MAKEBITTABLE 21699 . 22559)) (22723 23200 ( -CASEARRAY 22733 . 22923) (UPPERCASEARRAY 22925 . 23198)) (23522 57053 (FILEPOS 23532 . 32823) ( -FFILEPOS 32825 . 45096) (\SETUP.FFILEPOS 45098 . 48935) (\SLOWFILEPOS 48937 . 57051)) (57845 99092 ( -DATE 57855 . 57941) (DATEFORMAT 57943 . 58035) (GDATE 58037 . 58148) (IDATE 58150 . 69821) ( -\IDATESCANTOKEN 69823 . 71102) (\IDATE-PARSE-MONTH 71104 . 74800) (\OUTDATE 74802 . 87550) ( -\OUTDATE-STRING 87552 . 88167) (\RPLRIGHT 88169 . 88407) (\UNPACKDATE 88409 . 94200) (\PACKDATE 94202 - . 97522) (\DTSCAN 97524 . 97666) (\ISDST? 97668 . 98175) (\CHECKDSTCHANGE 98177 . 99090))))) + (FILEMAP (NIL (3443 10789 (CHCON 3453 . 4838) (UNPACK 4840 . 6439) (DCHCON 6441 . 8956) (DUNPACK 8958 + . 10787)) (10790 30299 (UALPHORDER 10800 . 10951) (ALPHORDER 10953 . 14398) (CONCAT 14400 . 15424) ( +CONCATCODES 15426 . 15695) (PACKC 15697 . 18346) (PACK 18348 . 19539) (PACK* 19541 . 22841) ( +\PACK.ITEM 22843 . 23570) (STRPOS 23572 . 30297)) (30301 30590 (XCL:PACK 30301 . 30590)) (30592 30842 +(XCL:PACK* 30592 . 30842)) (31549 36610 (STRPOSL 31559 . 35746) (MAKEBITTABLE 35748 . 36608)) (36772 +37540 (CASEARRAY 36782 . 37075) (UPPERCASEARRAY 37077 . 37538)) (37862 71625 (FILEPOS 37872 . 46856) ( +FFILEPOS 46858 . 59668) (\SETUP.FFILEPOS 59670 . 63507) (\SLOWFILEPOS 63509 . 71623)) (72417 112711 ( +DATE 72427 . 72583) (DATEFORMAT 72585 . 72722) (GDATE 72724 . 72897) (IDATE 72899 . 84343) ( +\IDATESCANTOKEN 84345 . 85612) (\IDATE-PARSE-MONTH 85614 . 89168) (\OUTDATE 89170 . 100775) ( +\OUTDATE-STRING 100777 . 101378) (\RPLRIGHT 101380 . 101749) (\UNPACKDATE 101751 . 107433) (\PACKDATE +107435 . 110601) (\DTSCAN 110603 . 110875) (\ISDST? 110877 . 111484) (\CHECKDSTCHANGE 111486 . 112709) +)))) STOP diff --git a/sources/IOCHAR.LCOM b/sources/IOCHAR.LCOM index ec92917b..c10737ad 100644 Binary files a/sources/IOCHAR.LCOM and b/sources/IOCHAR.LCOM differ diff --git a/sources/LLARRAYELT b/sources/LLARRAYELT index f546409a..1ad5146d 100644 --- a/sources/LLARRAYELT +++ b/sources/LLARRAYELT @@ -1,20 +1,19 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "15-Sep-94 11:08:59" {DSK}sources>LLARRAYELT.;7 155360 - changes to%: (RECORDS ARRAYP) +(FILECREATED "22-Feb-2026 13:54:48" {WMEDLEY}LLARRAYELT.;2 169614 - previous date%: "28-Jul-94 13:41:50" {DSK}sources>LLARRAYELT.;6) + :EDIT-BY rmk + :CHANGES-TO (VARS LLARRAYELTCOMS) + + :PREVIOUS-DATE "15-Sep-94 11:08:59" {WMEDLEY}LLARRAYELT.;1) -(* ; " -Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. -") (PRETTYCOMPRINT LLARRAYELTCOMS) -(RPAQQ LLARRAYELTCOMS +(RPAQQ LLARRAYELTCOMS [(COMS (* ; - "Because we use the UNLESSINEW macro in this file, we need it when compiling.") + "Because we use the UNLESSINEW macro in this file, we need it when compiling.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) RENAMEMACROS))) (PROPS (LLARRAYELT FILETYPE)) @@ -26,6 +25,10 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH CL::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP \HASHTABLE.DEFPRINT) + (COMS (* ; "Originally on MACHINEINDEPENDENT") + (FNS DMPHASH HASHOVERFLOW) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST + HASHOVERFLOW.UPDATEARRAY))) (FNS STRINGHASHBITS STRING-EQUAL-HASHBITS) (FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN) (DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP) @@ -44,7 +47,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N) (CONSTANTS \MAXBUCKETINDEX) (* ; - "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing") + "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing") (EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA \WORDELT) (CONSTANTS * BLOCKGCTYPECONSTANTS) @@ -77,7 +80,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (FNS \ALLOCHUNK) (VARS \HUNK.PTRSIZES) (* ; - "Compiler needs \HUNK.PTRSIZES for creating closure environments") + "Compiler needs \HUNK.PTRSIZES for creating closure environments") (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER)) (CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES) (GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE @@ -152,7 +155,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, RENAMEMACROS) ) -(PUTPROPS LLARRAYELT FILETYPE :BCOMPL) +(PUTPROPS LLARRAYELT FILETYPE :BCOMPL) @@ -407,8 +410,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE -[PUTPROPS ARRAYSIZE DMACRO ((A) - (ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP] +(PUTPROPS ARRAYSIZE DMACRO [(A) + (ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP]) ) ) (DEFINEQ @@ -996,6 +999,108 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992,  "Return T to say we printed it ourselves") T]) ) + + + +(* ; "Originally on MACHINEINDEPENDENT") + +(DEFINEQ + +(DMPHASH + [NLAMBDA L (* rmk%: " 6-Apr-84 14:30") + (MAPC L (FUNCTION (LAMBDA (ARRAYNAME) + (DECLARE (SPECVARS ARRAYNAME)) + (ERSETQ (PROG ((A (EVALV ARRAYNAME 'DMPHASH)) + AP) + [PRINT (LIST 'RPAQ ARRAYNAME + (COND + [(LISTP A) + (SETQ AP (CAR A)) + (LIST 'CONS [LIST 'HARRAY (HARRAYSIZE AP) + (KWOTE (HARRAYPROP + AP + 'OVERFLOW] + (KWOTE (CDR A] + (T (LIST 'HASHARRAY (HARRAYSIZE A) + (KWOTE (HARRAYPROP AP 'OVERFLOW] + (MAPHASH (OR AP A) + (FUNCTION (LAMBDA (VAL ITEM) + (PRINT (LIST 'PUTHASH (KWOTE ITEM) + (KWOTE VAL) + ARRAYNAME]) + +(HASHOVERFLOW + [LAMBDA (HARRAY) (* ; "Edited 26-Feb-91 13:16 by jds") + + (* ;; "Should be called from PUTHASH on hash overflow, but for implementations where PUTHASH calls ERRORX directly, may be called from ERRORX2 when the offender is a listp. HARRAY is guaranteed to be either HARRAYP or (LIST HARRAYP)") + + (PROG ((OLDARRAY (HASHOVERFLOW.ARRAYTEST HARRAY)) + NEWARRAY NEWSIZE OLDNUMKEYS OVACTION NEWOVFLW) + [COND + ((LISTP HARRAY) + (SETQ OVACTION (CDR HARRAY)) + + (* ;; "Get OVERFLOW method from original HARRAY since it would erroneously be ERROR if we got the method from the coerced OLDARRAY") + + (SETQ NEWOVFLW 'ERROR)) + (T (SETQ OVACTION (SETQ NEWOVFLW (HARRAYPROP OLDARRAY 'OVERFLOW] + (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS)) + + (* ;; "Compute the new array size:") + + [SETQ NEWSIZE (SELECTQ OVACTION + (NIL + (* ;; "SIZE*1.5 --- favor to bbn, since pdp-11 doesnt have floatng point, and LRSH on other systems might be faster than IQUOTIENT") + + (* ;; + "[32749 IS THE BIGGEST PRIME < 32765, THE LIMIT ON ARRAY SIZES]") + + [IMAX (+ OLDNUMKEYS 3) + (IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS) + 1]) + (ERROR (do (ERRORX (LIST 26 HARRAY)))) + (if (FLOATP OVACTION) + then [IMAX (+ OLDNUMKEYS 3) + (IMIN 32760 (FIXR (FTIMES OLDNUMKEYS OVACTION] + elseif (FIXP OVACTION) + then (IMAX (+ OLDNUMKEYS 3) + (IMIN 32749 (+ OLDNUMKEYS OVACTION))) + elseif [AND (FNTYP OVACTION) + (NUMBERP (SETQ OVACTION (APPLY* OVACTION HARRAY] + then (if (FLOATP OVACTION) + then (* ; + "recompute NUMKEYS since OVACTION might have removed keys") + [IMAX (+ (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY + 'NUMKEYS)) + 3) + (IMIN 32749 (FIXR (FTIMES OLDNUMKEYS OVACTION] + else OVACTION) + else (* ; "Default: multiply by 1.5") + (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS)) + (IMAX (+ OLDNUMKEYS 3) + (IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS) + 1] + [SETQ NEWARRAY (REHASH OLDARRAY (HASHARRAY NEWSIZE NEWOVFLW (HARRAYPROP OLDARRAY + 'HASHBITSFN) + (HARRAYPROP OLDARRAY 'EQUIVFN] + (HASHOVERFLOW.UPDATEARRAY HARRAY NEWARRAY OLDARRAY) + (RETURN HARRAY]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PROGN (PUTPROPS HASHOVERFLOW.ARRAYTEST MACRO [(HARRAY) + (CAR (OR (LISTP HARRAY) + (ERRORX (LIST 27 HARRAY]) + (PUTPROPS HASHOVERFLOW.ARRAYTEST DMACRO ((HARRAY) + (\DTEST HARRAY 'HARRAYP)))] + +[PROGN (PUTPROPS HASHOVERFLOW.UPDATEARRAY MACRO ((HARRAY NEWARRAY OLDARRAY) + (FRPLACA HARRAY NEWARRAY))) + (PUTPROPS HASHOVERFLOW.UPDATEARRAY DMACRO ((HARRAY NEWARRAY OLDARRAY) + (\COPYHARRAYP NEWARRAY OLDARRAY)))] +) +) (DEFINEQ (STRINGHASHBITS @@ -1048,20 +1153,20 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE -(DATATYPE HARRAYP ((NULLSLOTS WORD) (* ; - "Number of NIL-NIL slots, which break chains") - (LASTINDEX WORD) (* ; "Slot offset of last slot. Used in probe computations computations. Microcode support for \ADDBASE4 would help") - (HARRAYPBASE POINTER) - (RECLAIMABLE FLAG) (* ; - "True if keys can go away when no other refs") - (OVERFLOWACTION POINTER) - (NUMSLOTS WORD) (* ; - "The maximum number of logical slots--returned by HARRAYSIZE") - (NUMKEYS WORD) (* ; - "The number of distinct keys in the array") - (HASHBITSFN POINTER) - (EQUIVFN POINTER) - (HASHUSERDATA POINTER))) +(DATATYPE HARRAYP ((NULLSLOTS WORD) (* ; + "Number of NIL-NIL slots, which break chains") + (LASTINDEX WORD) (* ; "Slot offset of last slot. Used in probe computations computations. Microcode support for \ADDBASE4 would help") + (HARRAYPBASE POINTER) + (RECLAIMABLE FLAG) (* ; + "True if keys can go away when no other refs") + (OVERFLOWACTION POINTER) + (NUMSLOTS WORD) (* ; + "The maximum number of logical slots--returned by HARRAYSIZE") + (NUMKEYS WORD) (* ; + "The number of distinct keys in the array") + (HASHBITSFN POINTER) + (EQUIVFN POINTER) + (HASHUSERDATA POINTER))) ) (/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER) @@ -1078,14 +1183,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, '14) (DECLARE%: EVAL@COMPILE -[PUTPROPS \EQHASHINGBITS MACRO (OPENLAMBDA (X) (* ; - "Spread out objects whose low bits are in small arithmetic progression, esp atoms") - (LOGXOR (\HILOC X) - (LOGXOR (LLSH (LOGAND (\LOLOC X) - 8191) - 3) - (LRSH (\LOLOC X) - 9] +(PUTPROPS \EQHASHINGBITS MACRO [OPENLAMBDA (X) (* ; + "Spread out objects whose low bits are in small arithmetic progression, esp atoms") + (LOGXOR (\HILOC X) + (LOGXOR (LLSH (LOGAND (\LOLOC X) + 8191) + 3) + (LRSH (\LOLOC X) + 9]) ) (* "END EXPORTED DEFINITIONS") @@ -1094,21 +1199,20 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: EVAL@COMPILE (BLOCKRECORD HASHSLOT ((KEY POINTER) - (VALUE POINTER)) - [ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT]) + (VALUE POINTER)) + [ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT]) ) (DECLARE%: EVAL@COMPILE -[PUTPROPS \FIRSTINDEX MACRO ((BITS APTR1) - (IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1] +(PUTPROPS \FIRSTINDEX MACRO [(BITS APTR1) + (IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1]) -(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4)) +(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4)) -(PUTPROPS \REPROBE MACRO ((BITS HA) +(PUTPROPS \REPROBE MACRO ((BITS HA) (LOGOR [IREMAINDER (LOGXOR BITS (LRSH BITS 8)) - (IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX) - of HA] + (IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX) of HA] 1))) ) @@ -1145,15 +1249,15 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (ADDTOVAR SYSTEMRECLST (DATATYPE HARRAYP ((NULLSLOTS WORD) - (LASTINDEX WORD) - (HARRAYPBASE POINTER) - (RECLAIMABLE FLAG) - (OVERFLOWACTION POINTER) - (NUMSLOTS WORD) - (NUMKEYS WORD) - (HASHBITSFN POINTER) - (EQUIVFN POINTER) - (HASHUSERDATA POINTER))) + (LASTINDEX WORD) + (HARRAYPBASE POINTER) + (RECLAIMABLE FLAG) + (OVERFLOWACTION POINTER) + (NUMSLOTS WORD) + (NUMKEYS WORD) + (HASHBITSFN POINTER) + (EQUIVFN POINTER) + (HASHUSERDATA POINTER))) ) (RPAQQ \HASH.NULL.VALUE \Hash\Null\Value\) @@ -1277,14 +1381,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE -(PUTPROPS EQPTR DMACRO (= . EQ)) +(PUTPROPS EQPTR DMACRO (= . EQ)) -(PUTPROPS BUCKETINDEX MACRO ((N) +(PUTPROPS BUCKETINDEX MACRO ((N) (IMIN (INTEGERLENGTH N) \MAXBUCKETINDEX))) -[PUTPROPS FREEBLOCKCHAIN.N MACRO ((N) - (\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N] +(PUTPROPS FREEBLOCKCHAIN.N MACRO ((N) + (\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N)))) ) (DECLARE%: EVAL@COMPILE @@ -1297,43 +1401,43 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE -(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N) - (\ADDBASE (\ADDBASE BASE N) - N))) +(PUTPROPS \ADDBASE2 MACRO (OPENLAMBDA (BASE N) + (\ADDBASE (\ADDBASE BASE N) + N))) -(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N) - (\ADDBASE2 (\ADDBASE2 BASE N) - N))) +(PUTPROPS \ADDBASE4 MACRO (OPENLAMBDA (BASE N) + (\ADDBASE2 (\ADDBASE2 BASE N) + N))) -(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) +(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX)) WORDSPERCELL))) -[PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J) - (\GETBASEBYTE (fetch (ARRAYP BASE) of A) - (IPLUS (fetch (ARRAYP OFFST) of A) - J] +(PUTPROPS \BYTELT DMACRO (OPENLAMBDA (A J) + (\GETBASEBYTE (fetch (ARRAYP BASE) of A) + (IPLUS (fetch (ARRAYP OFFST) of A) + J)))) -(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V) - (\PUTBASEBYTE (fetch (ARRAYP BASE) of A) - (IPLUS (fetch (ARRAYP OFFST) of A) - J) - V))) +(PUTPROPS \BYTESETA DMACRO (OPENLAMBDA (A J V) + (\PUTBASEBYTE (fetch (ARRAYP BASE) of A) + (IPLUS (fetch (ARRAYP OFFST) of A) + J) + V))) -[PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J) - [CHECK (AND (ARRAYP A) - (EQ 0 (fetch (ARRAYP ORIG) of A)) - (EQ \ST.POS16 (fetch (ARRAYP TYP) of A] - (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A) - J)) - (\GETBASE (fetch (ARRAYP BASE) of A) - (IPLUS (fetch (ARRAYP OFFST) of A) - J] +(PUTPROPS \WORDELT DMACRO (OPENLAMBDA (A J) + [CHECK (AND (ARRAYP A) + (EQ 0 (fetch (ARRAYP ORIG) of A)) + (EQ \ST.POS16 (fetch (ARRAYP TYP) of A] + (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A) + J)) + (\GETBASE (fetch (ARRAYP BASE) of A) + (IPLUS (fetch (ARRAYP OFFST) of A) + J)))) ) (RPAQQ BLOCKGCTYPECONSTANTS ((CODEBLOCK.GCT 2) - (PTRBLOCK.GCT 1) - (UNBOXEDBLOCK.GCT 0))) + (PTRBLOCK.GCT 1) + (UNBOXEDBLOCK.GCT 0))) (DECLARE%: EVAL@COMPILE (RPAQQ CODEBLOCK.GCT 2) @@ -1348,33 +1452,24 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (UNBOXEDBLOCK.GCT 0)) ) -(RPAQQ ARRAYCONSTANTS (\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells - \ArrayBlockTrailerWords (\ArrayBlockOverheadCells (IPLUS - \ArrayBlockHeaderCells - - \ArrayBlockTrailerCells - )) - (\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords - \ArrayBlockTrailerWords)) - \ArrayBlockLinkingCells - (\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells - \ArrayBlockLinkingCells)) - (\MaxArrayBlockSize 65535) - (\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize - \ArrayBlockOverheadCells)) - \MaxArrayLen - (\ABPASSWORDSHIFT 3) - (\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT)) - (\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword - \ABPASSWORDSHIFT) - (LLSH UNBOXEDBLOCK.GCT 1))) - (\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword - \ABPASSWORDSHIFT) - 1)) - (\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword - \ABPASSWORDSHIFT) - (LLSH CODEBLOCK.GCT 1) - 1)))) +(RPAQQ ARRAYCONSTANTS + (\ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells \ArrayBlockTrailerWords + (\ArrayBlockOverheadCells (IPLUS \ArrayBlockHeaderCells \ArrayBlockTrailerCells)) + (\ArrayBlockOverheadWords (IPLUS \ArrayBlockHeaderWords \ArrayBlockTrailerWords)) + \ArrayBlockLinkingCells + (\MinArrayBlockSize (IPLUS \ArrayBlockOverheadCells \ArrayBlockLinkingCells)) + (\MaxArrayBlockSize 65535) + (\MaxArrayNCells (IDIFFERENCE \MaxArrayBlockSize \ArrayBlockOverheadCells)) + \MaxArrayLen + (\ABPASSWORDSHIFT 3) + (\ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT)) + (\FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) + (LLSH UNBOXEDBLOCK.GCT 1))) + (\UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) + 1)) + (\CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) + (LLSH CODEBLOCK.GCT 1) + 1)))) (DECLARE%: EVAL@COMPILE (RPAQQ \ArrayBlockHeaderCells 1) @@ -1404,14 +1499,14 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (RPAQ \ArrayBlockPassword (LRSH 43690 \ABPASSWORDSHIFT)) (RPAQ \FreeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) - (LLSH UNBOXEDBLOCK.GCT 1))) + (LLSH UNBOXEDBLOCK.GCT 1))) (RPAQ \UsedArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) - 1)) + 1)) (RPAQ \CodeArrayFlagWord (LOGOR (LLSH \ArrayBlockPassword \ABPASSWORDSHIFT) - (LLSH CODEBLOCK.GCT 1) - 1)) + (LLSH CODEBLOCK.GCT 1) + 1)) (CONSTANTS \ArrayBlockHeaderCells \ArrayBlockHeaderWords \ArrayBlockTrailerCells @@ -1435,13 +1530,13 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, ) (RPAQQ ARRAYTYPES ((\ST.BYTE 0) - (\ST.POS16 1) - (\ST.INT32 2) - (\ST.CODE 4) - (\ST.PTR 6) - (\ST.FLOAT 7) - (\ST.BIT 8) - (\ST.PTR2 11))) + (\ST.POS16 1) + (\ST.INT32 2) + (\ST.CODE 4) + (\ST.PTR 6) + (\ST.FLOAT 7) + (\ST.BIT 8) + (\ST.PTR2 11))) (DECLARE%: EVAL@COMPILE (RPAQQ \ST.BYTE 0) @@ -1487,52 +1582,51 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: EVAL@COMPILE (BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1) - (NIL BITS 1) - (READONLY FLAG) - (NIL BITS 1) - (BASE POINTER) - (TYP BITS 4) - (NIL BITS 4) - (LENGTH BITS 24) - (OFFST FIXP))) + (NIL BITS 1) + (READONLY FLAG) + (NIL BITS 1) + (BASE POINTER) + (TYP BITS 4) + (NIL BITS 4) + (LENGTH BITS 24) + (OFFST FIXP))) (DATATYPE ARRAYP ( - (* ;; "Describes an INTERLISP ARRAYP, as opposed to a CL array.") + (* ;; "Describes an INTERLISP ARRAYP, as opposed to a CL array.") - (ORIG BITS 1) (* ; "Origin, 0 or 1") - (NIL BITS 1) - (READONLY FLAG) (* ; "probably no READONLY arrays now") - (NIL BITS 1) - (BASE POINTER) - (TYP BITS 4) (* ; "Type of the contents") - (NIL BITS 4) - (LENGTH BITS 24) (* ; "Array's length") - (OFFST FIXP) (* ; - "Offset from BASE where the data really starts.") - ) + (ORIG BITS 1) (* ; "Origin, 0 or 1") + (NIL BITS 1) + (READONLY FLAG) (* ; "probably no READONLY arrays now") + (NIL BITS 1) + (BASE POINTER) + (TYP BITS 4) (* ; "Type of the contents") + (NIL BITS 4) + (LENGTH BITS 24) (* ; "Array's length") + (OFFST FIXP) (* ; + "Offset from BASE where the data really starts.") + ) - (* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}") + (* ;; "note that while ARRAYP is a DATATYPE, the allocation of it actually happens at MAKEINIT time under INITDATATYPE{NAMES}") - ) + ) (BLOCKRECORD ARRAYBLOCK ((PASSWORD BITS 13) - (GCTYPE BITS 2) (* ; "Unboxed, Pointers, or Code") - (INUSE FLAG) - (ARLEN WORD) - (FWD FULLXPOINTER) (* ; "Only when on free list") - (BKWD FULLXPOINTER)) - (BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD) + (GCTYPE BITS 2) (* ; "Unboxed, Pointers, or Code") + (INUSE FLAG) + (ARLEN WORD) + (FWD FULLXPOINTER) (* ; "Only when on free list") + (BKWD FULLXPOINTER)) + (BLOCKRECORD ARRAYBLOCK ((ABFLAGS WORD) (* ; "Used for header and trailer") - )) - [ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords)) - (TRAILER (\ADDBASE2 DATUM - (IDIFFERENCE (fetch - (ARRAYBLOCK ARLEN) - of DATUM) + )) + [ACCESSFNS ARRAYBLOCK ((DAT (\ADDBASE DATUM \ArrayBlockHeaderWords)) + (TRAILER (\ADDBASE2 DATUM (IDIFFERENCE + (fetch (ARRAYBLOCK ARLEN) + of DATUM) \ArrayBlockTrailerCells] - (TYPE? (AND (EQ 0 (NTYPX DATUM)) - (IGEQ (\HILOC DATUM) - \FirstArraySegment)))) + (TYPE? (AND (EQ 0 (NTYPX DATUM)) + (IGEQ (\HILOC DATUM) + \FirstArraySegment)))) ) (/DECLAREDATATYPE 'ARRAYP '((BITS 1) @@ -2273,8 +2367,8 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: EVAL@COMPILE (BLOCKRECORD SAFTABLE ((SAFITEMS WORD) - (NIL WORD) - (SAFCELLS FIXP))) + (NIL WORD) + (SAFCELLS FIXP))) ) ) @@ -2484,7 +2578,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE -(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) +(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX)) WORDSPERCELL))) ) @@ -2494,8 +2588,7 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: EVAL@COMPILE -(RPAQQ \HUNK.UNBOXEDSIZES - (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) +(RPAQQ \HUNK.UNBOXEDSIZES (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) (RPAQQ \HUNK.CODESIZES (12 16 20 24 28 32 36 42 50 64)) @@ -2721,49 +2814,49 @@ Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, (DECLARE%: DONTCOPY (ADDTOVAR INITVALUES (\NxtArrayPage) - (\HUNKING?)) + (\HUNKING?)) (ADDTOVAR INITPTRS (\FREEBLOCKBUCKETS) - (\ArrayFrLst) - (\ArrayFrLst2) - (\UNBOXEDHUNK.TYPENUM.TABLE) - (\CODEHUNK.TYPENUM.TABLE) - (\PTRHUNK.TYPENUM.TABLE)) + (\ArrayFrLst) + (\ArrayFrLst2) + (\UNBOXEDHUNK.TYPENUM.TABLE) + (\CODEHUNK.TYPENUM.TABLE) + (\PTRHUNK.TYPENUM.TABLE)) (ADDTOVAR INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? \ALLOCBLOCK \MAIKO.ALLOCBLOCK - \ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK) - (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK - FILEPATCHBLOCK) - (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING - \SETUP.TYPENUM.TABLE)) + \ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK) + (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK + FILEPATCHBLOCK) + (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING + \SETUP.TYPENUM.TABLE)) (ADDTOVAR MKI.SUBFNS (\IN.MAKEINIT . T) - (\ALLOCBLOCK.OLD . NILL) - (\MERGEFORWARD . NILL) - (\FIXCODENUM . I.FIXUPNUM) - (\FIXCODESYM . I.FIXUPSYM) - (\FIXCODEPTR . I.FIXUPPTR) - (\CHECKARRAYBLOCK . NILL) - (\ARRAYMERGING PROGN NIL)) + (\ALLOCBLOCK.OLD . NILL) + (\MERGEFORWARD . NILL) + (\FIXCODENUM . I.FIXUPNUM) + (\FIXCODESYM . I.FIXUPSYM) + (\FIXCODEPTR . I.FIXUPPTR) + (\CHECKARRAYBLOCK . NILL) + (\ARRAYMERGING PROGN NIL)) (ADDTOVAR EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER BUCKETINDEX FREEBLOCKCHAIN.N) (ADDTOVAR RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1)) (ADDTOVAR RD.SUBFNS (EQPTR . EQUAL) - (ARRAYBLOCKCHECKING . T)) + (ARRAYBLOCKCHECKING . T)) (ADDTOVAR RDPTRS (\FREEBLOCKBUCKETS)) (ADDTOVAR RDVALS (\ArrayFrLst) - (\ArrayFrLst2)) + (\ArrayFrLst2)) EVAL@COMPILE -(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER - FILECODEBLOCK FILEPATCHBLOCK) +(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK + FILEPATCHBLOCK) (ADDTOVAR DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING - \SETUP.TYPENUM.TABLE) + \SETUP.TYPENUM.TABLE) ) @@ -2937,32 +3030,174 @@ EVAL@COMPILE (ADDTOVAR LAMA CL::PUTHASH HARRAYPROP) ) -(PUTPROPS LLARRAYELT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 -1990 1991 1992 1993 1994)) +(PRETTYCOMPRINT LLARRAYELTCOMS) + +(RPAQQ LLARRAYELTCOMS + [(COMS (* ; + "Because we use the UNLESSINEW macro in this file, we need it when compiling.") + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) + RENAMEMACROS))) + (PROPS (LLARRAYELT FILETYPE)) + (COMS (* ; "ARRAY entries") + (FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY) + (DECLARE%: DONTCOPY (MACROS ARRAYSIZE)) + (FNS ELT ELTD SETA SETD SUBARRAY)) + [COMS (* ; "HASHARRAY entries") + (FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH + CL::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP + \HASHTABLE.DEFPRINT) + (COMS (* ; "Originally on MACHINEINDEPENDENT") + (FNS DMPHASH HASHOVERFLOW) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST + HASHOVERFLOW.UPDATEARRAY))) + (FNS STRINGHASHBITS STRING-EQUAL-HASHBITS) + (FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN) + (DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP) + (MACROS \EQHASHINGBITS)) + (RECORDS HASHSLOT) + (MACROS \FIRSTINDEX \HASHSLOT \REPROBE) + (CONSTANTS (CELLSPERSLOT 2)) + (GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY)) + [DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT] + (INITRECORDS HARRAYP) + (SYSRECORDS HARRAYP) + (VARS (\HASH.NULL.VALUE '\Hash\Null\Value\] + (COMS (* ; "System entries for CODE") + (FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR \FIXCODESYM)) + (COMS (* ; "Internal") + (DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N) + (CONSTANTS \MAXBUCKETINDEX) + (* ; + "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing") + (EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA + \WORDELT) + (CONSTANTS * BLOCKGCTYPECONSTANTS) + (CONSTANTS * ARRAYCONSTANTS) + (CONSTANTS * ARRAYTYPES) + (CONSTANTS \MAX.CELLSPERHUNK) + (CONSTANTS (\IN.MAKEINIT)) + (RECORDS SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK) + (GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?)) + (GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN)) + (FNS \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.OLD \ALLOCBLOCK.NEW \PREFIXALIGNMENT? + \MAKEFREEARRAYBLOCK \DELETEBLOCK? \LINKBLOCK \MERGEBACKWARD \MERGEFORWARD + \ARRAYBLOCKMERGER \#BLOCKDATACELLS \COPYARRAYBLOCK \RECLAIMARRAYBLOCK + \ADVANCE.ARRAY.SEGMENTS) + (ADDVARS (\MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK))) + (FNS \BYTELT \BYTESETA \WORDELT) + (FNS \ARRAYTYPENAME) + (VARS (\ARRAYMERGING T)) + (GLOBALVARS \ARRAYMERGING) + (COMS (* ; "for STORAGE") + (FNS \SHOW.ARRAY.FREELISTS) + (INITVARS (\ABSTORAGETABLE NIL)) + (GLOBALVARS \ABSTORAGETABLE) + (DECLARE%: DONTCOPY (RECORDS SAFTABLE))) + (COMS (* ; "Debugging and RDSYS") + (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1) + (INITVARS (ARRAYBLOCKCHECKING)) + (GLOBALVARS ARRAYBLOCKCHECKING))) + (COMS (* ; "Basic hunking") + (FNS \ALLOCHUNK) + (VARS \HUNK.PTRSIZES) + (* ; + "Compiler needs \HUNK.PTRSIZES for creating closure environments") + (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER)) + (CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES) + (GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE + \PTRHUNK.TYPENUM.TABLE)) + (COMS + (* ;; "Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage") + + (VARS (\HUNKREJECTS)) + (GLOBALVARS \HUNKREJECTS))) + [COMS (* ; "for MAKEINIT") + (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK + FILEPATCHBLOCK) + (COMS (* ; "Hunk Initialization") + (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING + \SETUP.TYPENUM.TABLE)) + (DECLARE%: DONTCOPY (ADDVARS (INITVALUES (\NxtArrayPage) + (\HUNKING?)) + (INITPTRS (\FREEBLOCKBUCKETS) + (\ArrayFrLst) + (\ArrayFrLst2) + (\UNBOXEDHUNK.TYPENUM.TABLE) + (\CODEHUNK.TYPENUM.TABLE) + (\PTRHUNK.TYPENUM.TABLE)) + (INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? + \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.NEW + \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK + \ALLOCHUNK) + (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE + FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK) + (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS + \TURN.ON.HUNKING \SETUP.TYPENUM.TABLE)) + (MKI.SUBFNS (\IN.MAKEINIT . T) + (\ALLOCBLOCK.OLD . NILL) + (\MERGEFORWARD . NILL) + (\FIXCODENUM . I.FIXUPNUM) + (\FIXCODESYM . I.FIXUPSYM) + (\FIXCODEPTR . I.FIXUPPTR) + (\CHECKARRAYBLOCK . NILL) + (\ARRAYMERGING PROGN NIL)) + (EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER + BUCKETINDEX FREEBLOCKCHAIN.N) + (RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE + \PARSEARRAYSPACE1)) + (RD.SUBFNS (EQPTR . EQUAL) + (ARRAYBLOCKCHECKING . T)) + (RDPTRS (\FREEBLOCKBUCKETS)) + (RDVALS (\ArrayFrLst) + (\ArrayFrLst2))) + EVAL@COMPILE + (ADDVARS (DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE + FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK) + (DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS + \TURN.ON.HUNKING \SETUP.TYPENUM.TABLE] + (COMS (* ; "Debugging aids") + (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \ArrayFrLst) + (CONSTANTS \ArrayBlockPassword) + (ADDVARS (DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK))) + (FNS \HUNKFIT? \AB.NEXT \AB.BACK)) + (LOCALVARS . T) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DMPHASH) + (NLAML) + (LAMA CL::PUTHASH + HARRAYPROP]) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA DMPHASH) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA CL::PUTHASH HARRAYPROP) +) (DECLARE%: DONTCOPY - (FILEMAP (NIL (9739 22117 (AIN 9749 . 12022) (AOUT 12024 . 14626) (ARRAY 14628 . 20213) (ARRAYSIZE -20215 . 20355) (ARRAYTYP 20357 . 20953) (ARRAYORIG 20955 . 21122) (COPYARRAY 21124 . 22115)) (22283 -29928 (ELT 22293 . 23722) (ELTD 23724 . 24649) (SETA 24651 . 26908) (SETD 26910 . 27904) (SUBARRAY -27906 . 29926)) (29963 55572 (HARRAY 29973 . 30193) (HASHARRAY 30195 . 34218) (HARRAYP 34220 . 34369) -(HARRAYPROP 34371 . 38406) (HARRAYSIZE 38408 . 38573) (CLRHASH 38575 . 39947) (MAPHASH 39949 . 41078) -(GETHASH 41080 . 44660) (PUTHASH 44662 . 44893) (CL::PUTHASH 44895 . 45607) (REMHASH 45609 . 45754) ( -\HASHRECLAIM 45756 . 47539) (\HASHACCESS 47541 . 53303) (REHASH 53305 . 54029) (\COPYHARRAYP 54031 . -54761) (\HASHTABLE.DEFPRINT 54763 . 55570)) (55573 56129 (STRINGHASHBITS 55583 . 55740) ( -STRING-EQUAL-HASHBITS 55742 . 56127)) (56130 58192 (\STRINGHASHBITS-UFN 56140 . 57246) ( -\STRING-EQUAL-HASHBITS-UFN 57248 . 58190)) (62479 67574 (\CODEARRAY 62489 . 63319) (\FIXCODENUM 63321 - . 63986) (\FIXCODEPTR 63988 . 65048) (\FIXCODESYM 65050 . 67572)) (79255 114491 (\ALLOCBLOCK 79265 . -83264) (\MAIKO.ALLOCBLOCK 83266 . 87458) (\ALLOCBLOCK.OLD 87460 . 92331) (\ALLOCBLOCK.NEW 92333 . -95339) (\PREFIXALIGNMENT? 95341 . 98884) (\MAKEFREEARRAYBLOCK 98886 . 99481) (\DELETEBLOCK? 99483 . -100588) (\LINKBLOCK 100590 . 102716) (\MERGEBACKWARD 102718 . 104079) (\MERGEFORWARD 104081 . 105178) -(\ARRAYBLOCKMERGER 105180 . 107365) (\#BLOCKDATACELLS 107367 . 108603) (\COPYARRAYBLOCK 108605 . -110173) (\RECLAIMARRAYBLOCK 110175 . 112304) (\ADVANCE.ARRAY.SEGMENTS 112306 . 114489)) (114553 116986 - (\BYTELT 114563 . 115362) (\BYTESETA 115364 . 116305) (\WORDELT 116307 . 116984)) (116987 117321 ( -\ARRAYTYPENAME 116997 . 117319)) (117444 121138 (\SHOW.ARRAY.FREELISTS 117454 . 121136)) (121451 -127201 (\CHECKARRAYBLOCK 121461 . 125836) (\PARSEARRAYSPACE 125838 . 126247) (\PARSEARRAYSPACE1 126249 - . 127199)) (127335 133601 (\ALLOCHUNK 127345 . 133599)) (134779 140675 (PREINITARRAYS 134789 . 135330 -) (POSTINITARRAYS 135332 . 138050) (FILEARRAYBASE 138052 . 138464) (FILEBLOCKTRAILER 138466 . 138761) -(FILECODEBLOCK 138763 . 139779) (FILEPATCHBLOCK 139781 . 140673)) (140712 146136 ( -\SETUP.HUNK.TYPENUMBERS 140722 . 141758) (\COMPUTE.HUNK.TYPEDECLS 141760 . 143040) (\TURN.ON.HUNKING -143042 . 143714) (\SETUP.TYPENUM.TABLE 143716 . 146134)) (148399 155000 (\HUNKFIT? 148409 . 149024) ( -\AB.NEXT 149026 . 152221) (\AB.BACK 152223 . 154998))))) + (FILEMAP (NIL (9935 22313 (AIN 9945 . 12218) (AOUT 12220 . 14822) (ARRAY 14824 . 20409) (ARRAYSIZE +20411 . 20551) (ARRAYTYP 20553 . 21149) (ARRAYORIG 21151 . 21318) (COPYARRAY 21320 . 22311)) (22488 +30133 (ELT 22498 . 23927) (ELTD 23929 . 24854) (SETA 24856 . 27113) (SETD 27115 . 28109) (SUBARRAY +28111 . 30131)) (30168 55777 (HARRAY 30178 . 30398) (HASHARRAY 30400 . 34423) (HARRAYP 34425 . 34574) +(HARRAYPROP 34576 . 38611) (HARRAYSIZE 38613 . 38778) (CLRHASH 38780 . 40152) (MAPHASH 40154 . 41283) +(GETHASH 41285 . 44865) (PUTHASH 44867 . 45098) (CL::PUTHASH 45100 . 45812) (REMHASH 45814 . 45959) ( +\HASHRECLAIM 45961 . 47744) (\HASHACCESS 47746 . 53508) (REHASH 53510 . 54234) (\COPYHARRAYP 54236 . +54966) (\HASHTABLE.DEFPRINT 54968 . 55775)) (55827 61097 (DMPHASH 55837 . 57451) (HASHOVERFLOW 57453 + . 61095)) (61873 62429 (STRINGHASHBITS 61883 . 62040) (STRING-EQUAL-HASHBITS 62042 . 62427)) (62430 +64492 (\STRINGHASHBITS-UFN 62440 . 63546) (\STRING-EQUAL-HASHBITS-UFN 63548 . 64490)) (68675 73770 ( +\CODEARRAY 68685 . 69515) (\FIXCODENUM 69517 . 70182) (\FIXCODEPTR 70184 . 71244) (\FIXCODESYM 71246 + . 73768)) (84170 119406 (\ALLOCBLOCK 84180 . 88179) (\MAIKO.ALLOCBLOCK 88181 . 92373) ( +\ALLOCBLOCK.OLD 92375 . 97246) (\ALLOCBLOCK.NEW 97248 . 100254) (\PREFIXALIGNMENT? 100256 . 103799) ( +\MAKEFREEARRAYBLOCK 103801 . 104396) (\DELETEBLOCK? 104398 . 105503) (\LINKBLOCK 105505 . 107631) ( +\MERGEBACKWARD 107633 . 108994) (\MERGEFORWARD 108996 . 110093) (\ARRAYBLOCKMERGER 110095 . 112280) ( +\#BLOCKDATACELLS 112282 . 113518) (\COPYARRAYBLOCK 113520 . 115088) (\RECLAIMARRAYBLOCK 115090 . +117219) (\ADVANCE.ARRAY.SEGMENTS 117221 . 119404)) (119468 121901 (\BYTELT 119478 . 120277) (\BYTESETA + 120279 . 121220) (\WORDELT 121222 . 121899)) (121902 122236 (\ARRAYTYPENAME 121912 . 122234)) (122359 + 126053 (\SHOW.ARRAY.FREELISTS 122369 . 126051)) (126358 132108 (\CHECKARRAYBLOCK 126368 . 130743) ( +\PARSEARRAYSPACE 130745 . 131154) (\PARSEARRAYSPACE1 131156 . 132106)) (132242 138508 (\ALLOCHUNK +132252 . 138506)) (139686 145582 (PREINITARRAYS 139696 . 140237) (POSTINITARRAYS 140239 . 142957) ( +FILEARRAYBASE 142959 . 143371) (FILEBLOCKTRAILER 143373 . 143668) (FILECODEBLOCK 143670 . 144686) ( +FILEPATCHBLOCK 144688 . 145580)) (145619 151043 (\SETUP.HUNK.TYPENUMBERS 145629 . 146665) ( +\COMPUTE.HUNK.TYPEDECLS 146667 . 147947) (\TURN.ON.HUNKING 147949 . 148621) (\SETUP.TYPENUM.TABLE +148623 . 151041)) (153219 159820 (\HUNKFIT? 153229 . 153844) (\AB.NEXT 153846 . 157041) (\AB.BACK +157043 . 159818))))) STOP diff --git a/sources/LLARRAYELT.LCOM b/sources/LLARRAYELT.LCOM index 307ee508..00bd047c 100644 Binary files a/sources/LLARRAYELT.LCOM and b/sources/LLARRAYELT.LCOM differ diff --git a/sources/LLSUBRS b/sources/LLSUBRS index 6e2aacd7..90e2f9b6 100644 --- a/sources/LLSUBRS +++ b/sources/LLSUBRS @@ -1,15 +1,13 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "13-Sep-2021 17:12:03" {DSK}briggs>Projects>medley>sources>LLSUBRS.;8 27017 - changes to%: (VARS \INITSUBRS) - (FNS WRITECALLSUBRS) +(FILECREATED " 5-Feb-2026 23:25:59" {WMEDLEY}LLSUBRS.;18 26279 - previous date%: "13-Sep-2021 16:07:08" {DSK}TMP>LLSUBRS.;1) + :EDIT-BY rmk + :CHANGES-TO (FNS UNIX-GETENV UNIX-USERNAME UNIX-FULLNAME UNIX-GETPARM) + + :PREVIOUS-DATE " 5-Feb-2026 18:13:25" {WMEDLEY}LLSUBRS.;11) -(* ; " -Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation. -") (PRETTYCOMPRINT LLSUBRSCOMS) @@ -94,9 +92,9 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation. ,@ARGS]) (DEFOPTIMIZER MISCN (NAME &REST ARGS) - `((OPCODES MISCN ,(MISCN-NUMBER NAME) - ,(LENGTH ARGS)) - ,@ARGS)) + `((OPCODES MISCN ,(MISCN-NUMBER NAME) + ,(LENGTH ARGS)) + ,@ARGS)) (DEFINEQ (MISCN-NUMBER @@ -190,25 +188,15 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation. (SETQ \MISCN-TABLE BASE]) ) -(PUTPROPS MISCN ARGNAMES (NAME &REST ARGS)) +(PUTPROPS MISCN ARGNAMES ("NAME" &REST "ARGS")) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE -(RECORD MISCN-UFN-SPEC ( - (* ;; - "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.") - - NAME (* ; - "Name of the MISCN, for the MISCN macro's use.") - INDEX (* ; "Sub-opcode index.") - UFN-NAME (* ; "Name of the UFN") - MVS (* ; - "T if the UFN can returnmultiple values. If this is NIL, MVs WILL NOT BE PRESERVED.") - )) +(RECORD MISCN-UFN-SPEC (NAME INDEX UFN-NAME MVS)) (BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG) - (NIL BITS 3) - (MISCN-UFN POINTER))) + (NIL BITS 3) + (MISCN-UFN POINTER))) ) ) @@ -218,7 +206,7 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation. (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) - (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN))) + (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN))) (* "END EXPORTED DEFINITIONS") @@ -233,7 +221,7 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation. (* ;; "Make Sure \USER-SUBR-TABLE is made") (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE) - \USER-SUBR-TABLE)) + \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (* ;; "See if the Name is already defined") @@ -450,9 +438,9 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation. ,@ARGS]) (DEFOPTIMIZER SUBRCALL (NAME &REST ARGS) - `((OPCODES SUBRCALL ,(SUBRNUMBER NAME) - ,(LENGTH ARGS)) - ,@ARGS)) + `((OPCODES SUBRCALL ,(SUBRNUMBER NAME) + ,(LENGTH ARGS)) + ,@ARGS)) (DEFINEQ (SUBRNUMBER @@ -612,52 +600,51 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation. else NIL]) (UNIX-USERNAME - [LAMBDA NIL (* ; "Edited 1-Aug-88 23:22 by masinter") - (if (EQ \MACHINETYPE \MAIKO) - then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING) - then (CONCAT (SUBSTRING UNIXSTRING 1 - (CL:POSITION #\Null UNIXSTRING - ]) + [LAMBDA NIL (* ; "Edited 5-Feb-2026 23:24 by rmk") + (* ; "Edited 1-Aug-88 23:22 by masinter") + (WITH-RESOURCE UNIXSTRING (CL:WHEN (SUBRCALL UNIX-USERNAME UNIXSTRING) + (SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null + UNIXSTRING))))]) (UNIX-FULLNAME - [LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter") - (if (EQ \MACHINETYPE \MAIKO) - then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING) - then (CONCAT (SUBSTRING UNIXSTRING 1 - (CL:POSITION #\Null - UNIXSTRING]) + [LAMBDA NIL (* ; "Edited 5-Feb-2026 23:24 by rmk") + (* ; "Edited 18-Jul-88 03:47 by masinter") + (WITH-RESOURCES UNIXSTRING (CL:WHEN (SUBRCALL UNIX-FULLNAME UNIXSTRING) + (SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null + UNIXSTRING))))]) (UNIX-GETENV - [LAMBDA (NAME) (* ; "Edited 21-Feb-2021 21:09 by larry") - (WITH-RESOURCES - UNIXSTRING - (LET ((X UNIXSTRING)) - (if (SUBRCALL UNIX-GETENV (MKSTRING NAME) - X) - then (CONCAT (SUBSTRING X 1 (for I from 1 - do (if (FMEMB (NTHCHARCODE X I) - '(0 NIL)) - then (RETURN (SUB1 I]) + [LAMBDA (NAME) (* ; "Edited 5-Feb-2026 23:25 by rmk") + (* ; "Edited 31-Jan-2026 22:28 by rmk") + (* ; "Edited 21-Feb-2021 21:09 by larry") + (WITH-RESOURCES UNIXSTRING + (CL:WHEN (SUBRCALL UNIX-GETENV (MTOSYSSTRING NAME) + UNIXSTRING) + [SYSTOMSTRING (SUBSTRING UNIXSTRING 1 + (for I from 1 + do (if (FMEMB (NTHCHARCODE UNIXSTRING I) + '(0 NIL)) + then (RETURN (SUB1 I])]) (UNIX-GETPARM - [LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm") + [LAMBDA (NAME) (* ; "Edited 5-Feb-2026 23:21 by rmk") + (* ; "Edited 27-Feb-91 17:11 by nm") (* ;; "Read information from the C emulator. Usually gets info about configuration of the machine we're running on.") (* ;; -"Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.") + "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.") (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.") - (if (EQ \MACHINETYPE \MAIKO) - then (LET (LEN) - (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME) - UNIXSTRING)) - (COND - [(SMALLP LEN) - (if (> LEN 0) - then (CONCAT (SUBSTRING UNIXSTRING 1 LEN] - (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING]) + (LET (LEN) + (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MTOSYSSTRING NAME) + UNIXSTRING)) + (COND + [(SMALLP LEN) + (if (> LEN 0) + then (SYSTOMSTRING (SUBSTRING UNIXSTRING 1 LEN] + (LEN (SYSTOMSTRING (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING]) ) (PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH)) @@ -684,20 +671,19 @@ Copyright (c) 1983-1986, 1988-1992, 2021 by Venue & Xerox Corporation. (PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR)) -(PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE) -(PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992 -2021)) +(PUTPROPS LLSUBRS FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTCOPY - (FILEMAP (NIL (3639 8383 (MISCN-NUMBER 3649 . 3865) (\MISCN.UFN 3867 . 6124) (\UNDEFINED-MISCN-UFN -6126 . 6442) (MISCN-COLLECT 6444 . 6661) (\GET-MY-BF 6663 . 6875) (\INIT-MISCN-TABLE 6877 . 8381)) ( -9767 11056 (ADD-USER-SUBR 9767 . 11056)) (11057 12808 (\USER-SUBR-UFN 11067 . 11642) ( -\INIT-USER-SUBR-TABLE 11644 . 12109) (\UNDEFINED-USER-SUBR-UFN 12111 . 12454) (USER-SUBR-NUMBER 12456 - . 12678) (EQ-TO-CAR 12680 . 12741) (EQ-TO-CADR 12743 . 12806)) (17091 17740 (SUBRNUMBER 17101 . 17738 -)) (17801 20104 (WRITECALLSUBRS 17811 . 19347) (FIX-SUBR-NAME 19349 . 20102)) (20313 26217 ( -\MOREVMEMFILE 20323 . 20488) (\WRITEMAP 20490 . 20650) (\COPYSYS0SUBR 20652 . 20812) (\PUPLEVEL1STATE -20814 . 20978) (SHOWDISPLAY 20980 . 21269) (SETSCREENCOLOR 21271 . 21434) (\WRITERAWPBI 21436 . 21594) - (\READRAWPBI 21596 . 21748) (RAID 21750 . 21905) (\LISPFINISH 21907 . 22065) (\GETPACKETBUFFER 22067 - . 22229) (\GATHERSTATS 22231 . 22389) (\DSPRATE 22391 . 22658) (DSPBOUT 22660 . 22814) (DISKPARTITION - 22816 . 23111) (\CHECKBCPLPASSWORD 23113 . 23292) (SUSPEND-LISP 23294 . 23552) (UNIX-USERNAME 23554 - . 24076) (UNIX-FULLNAME 24078 . 24604) (UNIX-GETENV 24606 . 25203) (UNIX-GETPARM 25205 . 26215))))) + (FILEMAP (NIL (2955 3362 (MISCN 2955 . 3362)) (3544 8288 (MISCN-NUMBER 3554 . 3770) (\MISCN.UFN 3772 + . 6029) (\UNDEFINED-MISCN-UFN 6031 . 6347) (MISCN-COLLECT 6349 . 6566) (\GET-MY-BF 6568 . 6780) ( +\INIT-MISCN-TABLE 6782 . 8286)) (8844 8979 (USER-SUBR 8844 . 8979)) (8981 10266 (ADD-USER-SUBR 8981 . +10266)) (10267 12018 (\USER-SUBR-UFN 10277 . 10852) (\INIT-USER-SUBR-TABLE 10854 . 11319) ( +\UNDEFINED-USER-SUBR-UFN 11321 . 11664) (USER-SUBR-NUMBER 11666 . 11888) (EQ-TO-CAR 11890 . 11951) ( +EQ-TO-CADR 11953 . 12016)) (15683 16094 (SUBRCALL 15683 . 16094)) (16289 16938 (SUBRNUMBER 16299 . +16936)) (16999 19302 (WRITECALLSUBRS 17009 . 18545) (FIX-SUBR-NAME 18547 . 19300)) (19511 25586 ( +\MOREVMEMFILE 19521 . 19686) (\WRITEMAP 19688 . 19848) (\COPYSYS0SUBR 19850 . 20010) (\PUPLEVEL1STATE +20012 . 20176) (SHOWDISPLAY 20178 . 20467) (SETSCREENCOLOR 20469 . 20632) (\WRITERAWPBI 20634 . 20792) + (\READRAWPBI 20794 . 20946) (RAID 20948 . 21103) (\LISPFINISH 21105 . 21263) (\GETPACKETBUFFER 21265 + . 21427) (\GATHERSTATS 21429 . 21587) (\DSPRATE 21589 . 21856) (DSPBOUT 21858 . 22012) (DISKPARTITION + 22014 . 22309) (\CHECKBCPLPASSWORD 22311 . 22490) (SUSPEND-LISP 22492 . 22750) (UNIX-USERNAME 22752 + . 23256) (UNIX-FULLNAME 23258 . 23765) (UNIX-GETENV 23767 . 24583) (UNIX-GETPARM 24585 . 25584))))) STOP diff --git a/sources/LLSUBRS.LCOM b/sources/LLSUBRS.LCOM index 23c14b23..06079798 100644 Binary files a/sources/LLSUBRS.LCOM and b/sources/LLSUBRS.LCOM differ diff --git a/sources/LOADFNS b/sources/LOADFNS index 3bff0dfb..d9afbb54 100644 --- a/sources/LOADFNS +++ b/sources/LOADFNS @@ -1,20 +1,18 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED " 2-May-2022 11:38:55" {DSK}larry>medley>sources>LOADFNS.;2 47218 +(FILECREATED "25-Feb-2026 01:03:38" {WMEDLEY}LOADFNS.;8 47522 - :CHANGES-TO (FNS SCANFILEHELP) + :EDIT-BY rmk - :PREVIOUS-DATE "16-Apr-2018 17:38:16" {DSK}larry>medley>sources>LOADFNS.;1) + :CHANGES-TO (VARS LOADFNSCOMS) + :PREVIOUS-DATE "23-Feb-2026 00:49:17" {WMEDLEY}LOADFNS.;7) -(* ; " -Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corporation. -") (PRETTYCOMPRINT LOADFNSCOMS) (RPAQQ LOADFNSCOMS - [(FNS LOADFROM LOADBLOCK GETBLOCKDEC LOADCOMP LOADCOMP? LOADVARS LOADEFS LOADFILEMAP LOADFNS + [(FNS LOADFROM LOADBLOCK GETBLOCKDEC LOADCOMP LOADCOMP? LOADVARS LOADFILEMAP LOADFNS LOADFNS-FINDFILE LOADFNS-MAKELIST) (FNS LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARECOLON SCANFILE1 SCANFILE2 TMPSUBFN RETRYSCAN SCANFILEHELP) @@ -98,10 +96,6 @@ Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corpo [LAMBDA (VARS FILE LDFLG) (LOADFNS NIL FILE LDFLG VARS]) -(LOADEFS - [LAMBDA (FNS FILE) (* wt%: " 9-APR-80 20:27") - (LOADFNS FNS FILE 'GETDEF]) - (LOADFILEMAP [LAMBDA (FILE) (* wt%: "16-MAY-79 22:05") @@ -110,107 +104,107 @@ Copyright (c) 1983-1984, 1986-1987, 1989-1990, 2018, 2022 by Venue & Xerox Corpo (LOADFNS NIL FILE NIL 'FILEMAP]) (LOADFNS - [LAMBDA (FNS FILE LDFLG VARS) (* bvm%: "17-Nov-86 23:28") + [LAMBDA (FNS FILE LDFLG VARS) (* ; "Edited 23-Feb-2026 00:49 by rmk") + (* bvm%: "17-Nov-86 23:28") -(* ;;; "All of LOADVARS, LOADCOMP, LOADFILEMAP, LOADFROM come thru here.") +(* ;;; "All of LOADVARS, LOADCOMP, LOADFILEMAP, LOADFROM come thru here.") - (DECLARE (SPECVARS FILE LDFLG VARS)) (* ; "Used free by RETRYSCAN") + (DECLARE (SPECVARS FILE LDFLG VARS)) (* ; "Used free by RETRYSCAN") (RESETLST - (PROG ((*PACKAGE* *INTERLISP-PACKAGE*) - (DFNFLG DFNFLG) - (BUILDMAPFLG BUILDMAPFLG) - (FILEPKGFLG FILEPKGFLG) - (ADDSPELLFLG ADDSPELLFLG) - (LISPXHIST LISPXHIST) - (FILECREATEDLST) - (PRLST (AND FILEPKGFLG (FILEPKGCHANGES))) - INSTREAM FNLST VARLST DONELST ROOTNAME FILEMAP TEM FILEMAPEND FILECREATEDLOC FILENV - RESETSAVER MAPUPDATED) - (DECLARE (SPECVARS *PACKAGE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FNLST - VARLST DONELST FILECREATEDLST FILECREATEDLOC)) - (* ; - "FILECREATEDLST is set by SCANEXP when it encounters a FILECREATED expression") - TOP (COND - ((OR (EQ LDFLG 'EXPRESSIONS) - (EQ LDFLG 'GETDEF) - (MEMB LDFLG LOADOPTIONS)) - (SETQ DFNFLG LDFLG)) - ((AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T))) - (SETQ LDFLG TEM) - (SETQ DFNFLG LDFLG)) - (T (SETQ LDFLG (ERROR "unrecognized load option" LDFLG)) - (GO TOP))) - (COND - ((EQ LDFLG 'SYSLOAD) - (SETQ DFNFLG T) - (SETQ ADDSPELLFLG NIL) - (SETQ BUILDMAPFLG NIL) - (SETQ FILEPKGFLG NIL) - (SETQ LISPXHIST NIL))) - [AND LISPXHIST (COND - ((SETQ TEM (FMEMB 'SIDE LISPXHIST)) - (FRPLACA (CADR TEM) - -1)) - (T (LISPXPUT 'SIDE (LIST -1) - NIL LISPXHIST] (* ; - "So that UNDOSAVE will keep saving regardless of how many undosaves are involved") - (SETQ FNLST (LOADFNS-MAKELIST FNS T)) (* ; "Get list of functions") - [COND - ((NULL FILE) (* ; - "Infer what file caller meant (this is a feature!)") - (SETQ FILE (LOADFNS-FINDFILE (CAR FNLST] - RETRY - [RESETSAVE NIL (SETQ RESETSAVER (LIST 'CLOSEF? (SETQ INSTREAM (OPENSTREAM FILE - 'INPUT] - (* ; - "CLOSEF? not CLOSEF because UPDATEFILEMAP might close file for us") - (RESETSAVE (INPUT INSTREAM)) - (SETQ FILE (FULLNAME INSTREAM)) (* ; - "Gets full file name. Also note that there may have been some error correction done in OPENSTREAM") - (COND - ((NOT (RANDACCESSP INSTREAM)) - (SETQ FILE (ERROR FILE "not a random access file")) - (GO RETRY))) - (SETFILEPTR INSTREAM 0) - (SETQ ROOTNAME (ROOTFILENAME FILE)) - (CL:MULTIPLE-VALUE-SETQ (FILENV FILEMAP FILECREATEDLOC FILECREATEDLST) - (GET-ENVIRONMENT-AND-FILEMAP INSTREAM)) - (SETQ VARLST (SELECTQ VARS - (NIL NIL) - (VARS (* ; - "Means load, i.e., evaluate, ALL rpaq/rpaqq") - 'VARS) - (FNS/VARS (LIST (FILECOMS ROOTNAME 'COMS) - (FILECOMS ROOTNAME 'BLOCKS))) - (LOADCOMP (* ; - "evaluate the EVAL@COMPILE expresions, notice the fns and vars.") - (SETQ FNLST T) - VARS) - (FILEMAP (* ; - "Return the filemap, or build one if not already available") - (if (AND FILEMAP (NULL (CAR FILEMAP))) - then (RETURN FILEMAP) - elseif (NULL BUILDMAPFLG) - then (RETURN NIL)) - 'FILEMAP) - (LOADFROM - - (* ;; "evaluate all non-defineq expressions, but just return file name as value, i.e. dont bother adding to donelst") + [PROG ((*PACKAGE* *INTERLISP-PACKAGE*) + (DFNFLG DFNFLG) + (BUILDMAPFLG BUILDMAPFLG) + (FILEPKGFLG FILEPKGFLG) + (ADDSPELLFLG ADDSPELLFLG) + (LISPXHIST LISPXHIST) + (FILECREATEDLST) + (PRLST (AND FILEPKGFLG (FILEPKGCHANGES))) + INSTREAM FNLST VARLST DONELST ROOTNAME FILEMAP TEM FILEMAPEND FILECREATEDLOC FILENV + RESETSAVER MAPUPDATED) + (DECLARE (SPECVARS *PACKAGE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FNLST + VARLST DONELST FILECREATEDLST FILECREATEDLOC)) + (* ; + "FILECREATEDLST is set by SCANEXP when it encounters a FILECREATED expression") + TOP (COND + ((OR (EQ LDFLG 'EXPRESSIONS) + (EQ LDFLG 'GETDEF) + (MEMB LDFLG LOADOPTIONS)) + (SETQ DFNFLG LDFLG)) + ((AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T))) + (SETQ LDFLG TEM) + (SETQ DFNFLG LDFLG)) + (T (SETQ LDFLG (ERROR "unrecognized load option" LDFLG)) + (GO TOP))) + (COND + ((EQ LDFLG 'SYSLOAD) + (SETQ DFNFLG T) + (SETQ ADDSPELLFLG NIL) + (SETQ BUILDMAPFLG NIL) + (SETQ FILEPKGFLG NIL) + (SETQ LISPXHIST NIL))) + [AND LISPXHIST (COND + ((SETQ TEM (FMEMB 'SIDE LISPXHIST)) + (FRPLACA (CADR TEM) + -1)) + (T (LISPXPUT 'SIDE (LIST -1) + NIL LISPXHIST] (* ; + "So that UNDOSAVE will keep saving regardless of how many undosaves are involved") + (SETQ FNLST (LOADFNS-MAKELIST FNS T)) (* ; "Get list of functions") + [COND + ((NULL FILE) (* ; + "Infer what file caller meant (this is a feature!)") + (SETQ FILE (LOADFNS-FINDFILE (CAR FNLST] + RETRY + [RESETSAVE NIL (SETQ RESETSAVER (LIST 'CLOSEF? (SETQ INSTREAM (OPENSTREAM FILE + 'INPUT] + (* ; + "CLOSEF? not CLOSEF because UPDATEFILEMAP might close file for us") + (RESETSAVE (INPUT INSTREAM)) + (SETQ FILE (FULLNAME INSTREAM)) (* ; + "Gets full file name. Also note that there may have been some error correction done in OPENSTREAM") + (COND + ((NOT (RANDACCESSP INSTREAM)) + (SETQ FILE (ERROR FILE "not a random access file")) + (GO RETRY))) + (SETFILEPTR INSTREAM 0) + (SETQ ROOTNAME (ROOTFILENAME FILE)) + (CL:MULTIPLE-VALUE-SETQ (FILENV FILEMAP FILECREATEDLOC FILECREATEDLST) + (GET-ENVIRONMENT-AND-FILEMAP INSTREAM)) + (\EXTERNALFORMAT INSTREAM FILENV) + (SETQ VARLST (SELECTQ VARS + (NIL NIL) + (VARS (* ; + "Means load, i.e., evaluate, ALL rpaq/rpaqq") + 'VARS) + (FNS/VARS (LIST (FILECOMS ROOTNAME 'COMS) + (FILECOMS ROOTNAME 'BLOCKS))) + (LOADCOMP (* ; + "evaluate the EVAL@COMPILE expresions, notice the fns and vars.") + (SETQ FNLST T) + VARS) + (FILEMAP (* ; + "Return the filemap, or build one if not already available") + (if (AND FILEMAP (NULL (CAR FILEMAP))) + then (RETURN FILEMAP) + elseif (NULL BUILDMAPFLG) + then (RETURN NIL)) + 'FILEMAP) + (LOADFROM + (* ;; "evaluate all non-defineq expressions, but just return file name as value, i.e. dont bother adding to donelst") - 'LOADFROM) - (DONTCOPY (* ; - "means load all DECLARE: DONTCOPY expressions") - VARS) - (LOADFNS-MAKELIST VARS))) - (SETQ FILEMAPEND (if FILEMAP - then (CAR FILEMAP) - else T)) (* ; - "Remember how far the filemap scan got already") - [WITH-READER-ENVIRONMENT - FILENV - (SETQ FILEMAP (LOADFNSCAN FILEMAP)) + 'LOADFROM) + (DONTCOPY (* ; + "means load all DECLARE: DONTCOPY expressions") + VARS) + (LOADFNS-MAKELIST VARS))) + (SETQ FILEMAPEND (if FILEMAP + then (CAR FILEMAP) + else T)) (* ; + "Remember how far the filemap scan got already") + (WITH-READER-ENVIRONMENT FILENV + (SETQ FILEMAP (LOADFNSCAN FILEMAP)) -(* ;;; "SCANFILE0 returns a 'map' for the file. The form of the map is (ADR ADRLST ADRLST ...) where ADR is last address scanned to in file, or NIL if entire file was scanned, or (ADR) where the scan stopped after a function in the middle of a DEFINEQ. Each ADRLST is either of the form (ADR1 ADR2 . FN) or (ADR1 ADR2 (FN ADRX . ADRY) (FN ADRX . ADRY) ...). +(* ;;; "SCANFILE0 returns a 'map' for the file. The form of the map is (ADR ADRLST ADRLST ...) where ADR is last address scanned to in file, or NIL if entire file was scanned, or (ADR) where the scan stopped after a function in the middle of a DEFINEQ. Each ADRLST is either of the form (ADR1 ADR2 . FN) or (ADR1 ADR2 (FN ADRX . ADRY) (FN ADRX . ADRY) ...). The first case corresponds to a compiled function, the second to a DEFINEQ. In the first case, ADR1 is the address of the first character AFTER the function name in the file (for use by LAPRD) and ADR2 the address of the first character after the de definition, i.e., after LAPRD or LCSKIP has finished. @@ -218,89 +212,89 @@ In the second case, ADR1 is the address of the lef paren before the DEFINEQ, and A map of non-functions is not kept because (a) it would not be of use to MAKEFILE since it always recomputes VARS, and (B) most requests for other than functions require scanning the entire file anyway, e.g. to find all RPAQQ's, and (C) the expressions are usually small compared to DEFINEQ's.") - [if FILEMAP - then - (if (NEQ FILEMAPEND (CAR FILEMAP)) - then (* ; "something was added") - (PUTFILEMAP FILE FILEMAP FILECREATEDLST) - (if (AND UPDATEMAPFLG (UPDATEFILEMAP INSTREAM FILEMAP)) - then (SETQ MAPUPDATED T))) - (if (AND DWIMFLG (NOT NOSPELLFLG) - (LISTP FNLST)) - then (* ; - "There are still FNS left that we didn't find") - (if (SETQ TEM - (for X on FNLST - bind [KNOWNFNS _ (for TRIPLE in (CDR FILEMAP) - join (* ; - "makes a list of functions found for use for spelling correction.") - (if (LISTP (SETQ TEM (CDDR TRIPLE))) - then - (* ; - "This is for normal source files, where TRIPLE = (start end . fnEntries)") - (MAPCAR TEM (FUNCTION CAR)) - elseif TEM - then - (* ; - "For compiled files, TRIPLE = (start end . fn)") - (LIST TEM] - when (AND (NOT (FMEMB (CAR X) - KNOWNFNS)) - (FIXSPELL (CAR X) - 70 KNOWNFNS NIL X)) collect - - (* ;; "The FMEMB check is necessary for when VARS=DEFS, as the reason that the function was not removed from FNLST may have been because this was a compiled file.") + [if FILEMAP + then + (if (NEQ FILEMAPEND (CAR FILEMAP)) + then (* ; "something was added") + (PUTFILEMAP FILE FILEMAP FILECREATEDLST) + (if (AND UPDATEMAPFLG (UPDATEFILEMAP INSTREAM FILEMAP)) + then (SETQ MAPUPDATED T))) + (if (AND DWIMFLG (NOT NOSPELLFLG) + (LISTP FNLST)) + then (* ; + "There are still FNS left that we didn't find") + (if + (SETQ TEM + (for X on FNLST + bind [KNOWNFNS _ + (for TRIPLE in (CDR FILEMAP) + join (* ; + "makes a list of functions found for use for spelling correction.") + (if (LISTP (SETQ TEM (CDDR TRIPLE))) + then (* ; + "This is for normal source files, where TRIPLE = (start end . fnEntries)") + (MAPCAR TEM (FUNCTION CAR)) + elseif TEM + then (* ; + "For compiled files, TRIPLE = (start end . fn)") + (LIST TEM] + when (AND (NOT (FMEMB (CAR X) + KNOWNFNS)) + (FIXSPELL (CAR X) + 70 KNOWNFNS NIL X)) collect - (CAR X))) - then (if MAPUPDATED - then (* ; "UPDATEFILEMAP had closed the file") - [RPLACA (CDR RESETSAVER) - (SETQ INSTREAM (OPENSTREAM FILE 'INPUT] - (INPUT INSTREAM)) - (SCANFILE1 FILEMAP TEM] - (if (AND NOT-FOUNDTAG (LISTP FNLST)) - then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG FNLST) - DONELST))) - (if - [AND - NOT-FOUNDTAG - (LISTP VARLST) - (SETQ TEM - (if (FNTYP VARLST) - then (AND (NULL DONELST) - (LIST VARLST)) - else (for X in VARLST collect X - unless (PROGN - - (* ;; "Reason for this is if user says LOADVARS (DEFLIST file), then DEFLIST is not removed from VARLST, since you want all such instances.") + (* ;; "The FMEMB check is necessary for when VARS=DEFS, as the reason that the function was not removed from FNLST may have been because this was a compiled file.") - (for Y in DONELST - thereis (if (ATOM X) - then (OR (EQ X (CAR Y)) - (EQ X (CADR Y))) - else (EDIT4E X Y] - then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG TEM) - DONELST))) - (if (EQ LDFLG 'SYSLOAD) - then (AND (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST))) - SYSFILES)) - (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME))) - (SMASHFILECOMS ROOTNAME) - elseif FILEPKGFLG - then (AND (NEQ VARS 'FILEMAP) - (NEQ LDFLG 'EXPRESSIONS) - (NEQ LDFLG 'GETDEF) - (ADDFILE FILE (SELECTQ VARS - ((T LOADFROM) - 'LOADFNS) - (LOADCOMP 'LOADCOMP) - 'loadfns) - PRLST FILECREATEDLST] - (RETURN (if (EQ VARS 'FILEMAP) - then FILEMAP - elseif (EQ VARS 'LOADFROM) - then FILE - else (DREVERSE DONELST]) + (CAR X))) + then (if MAPUPDATED + then (* ; "UPDATEFILEMAP had closed the file") + [RPLACA (CDR RESETSAVER) + (SETQ INSTREAM (OPENSTREAM FILE 'INPUT] + (INPUT INSTREAM)) + (SCANFILE1 FILEMAP TEM] + (if (AND NOT-FOUNDTAG (LISTP FNLST)) + then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG FNLST) + DONELST))) + (if + [AND + NOT-FOUNDTAG + (LISTP VARLST) + (SETQ TEM + (if (FNTYP VARLST) + then (AND (NULL DONELST) + (LIST VARLST)) + else (for X in VARLST collect X + unless (PROGN + + (* ;; "Reason for this is if user says LOADVARS (DEFLIST file), then DEFLIST is not removed from VARLST, since you want all such instances.") + + (for Y in DONELST + thereis (if (ATOM X) + then (OR (EQ X (CAR Y)) + (EQ X (CADR Y))) + else (EDIT4E X Y] + then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG TEM) + DONELST))) + (if (EQ LDFLG 'SYSLOAD) + then (AND (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST))) + SYSFILES)) + (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME))) + (SMASHFILECOMS ROOTNAME) + elseif FILEPKGFLG + then (AND (NEQ VARS 'FILEMAP) + (NEQ LDFLG 'EXPRESSIONS) + (NEQ LDFLG 'GETDEF) + (ADDFILE FILE (SELECTQ VARS + ((T LOADFROM) + 'LOADFNS) + (LOADCOMP 'LOADCOMP) + 'loadfns) + PRLST FILECREATEDLST)))) + (RETURN (if (EQ VARS 'FILEMAP) + then FILEMAP + elseif (EQ VARS 'LOADFROM) + then FILE + else (DREVERSE DONELST])]) (LOADFNS-FINDFILE [LAMBDA (FN) (* bvm%: "27-Sep-86 15:03") @@ -883,13 +877,12 @@ A map of non-functions is not kept because (a) it would not be of use to MAKEFIL (SPECVARS VARLST) (RETFNS SCANFILE0)) ) -(PUTPROPS LOADFNS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1986 1987 1989 1990 2018 2022)) (DECLARE%: DONTCOPY - (FILEMAP (NIL (1224 19374 (LOADFROM 1234 . 1707) (LOADBLOCK 1709 . 2217) (GETBLOCKDEC 2219 . 3084) ( -LOADCOMP 3086 . 4249) (LOADCOMP? 4251 . 4951) (LOADVARS 4953 . 5033) (LOADEFS 5035 . 5179) ( -LOADFILEMAP 5181 . 5585) (LOADFNS 5587 . 17659) (LOADFNS-FINDFILE 17661 . 18177) (LOADFNS-MAKELIST -18179 . 19372)) (19375 46586 (LOADFNSCAN 19385 . 19563) (SCANFILE0 19565 . 22972) (SCANCOMPILEDFN -22974 . 25276) (SCANDEFINEQ 25278 . 30576) (SCANEXP 30578 . 35329) (SCANDECLARECOLON 35331 . 39535) ( -SCANFILE1 39537 . 43619) (SCANFILE2 43621 . 43907) (TMPSUBFN 43909 . 45073) (RETRYSCAN 45075 . 45472) -(SCANFILEHELP 45474 . 46584))))) + (FILEMAP (NIL (1109 19777 (LOADFROM 1119 . 1592) (LOADBLOCK 1594 . 2102) (GETBLOCKDEC 2104 . 2969) ( +LOADCOMP 2971 . 4134) (LOADCOMP? 4136 . 4836) (LOADVARS 4838 . 4918) (LOADFILEMAP 4920 . 5324) ( +LOADFNS 5326 . 18062) (LOADFNS-FINDFILE 18064 . 18580) (LOADFNS-MAKELIST 18582 . 19775)) (19778 46989 +(LOADFNSCAN 19788 . 19966) (SCANFILE0 19968 . 23375) (SCANCOMPILEDFN 23377 . 25679) (SCANDEFINEQ 25681 + . 30979) (SCANEXP 30981 . 35732) (SCANDECLARECOLON 35734 . 39938) (SCANFILE1 39940 . 44022) ( +SCANFILE2 44024 . 44310) (TMPSUBFN 44312 . 45476) (RETRYSCAN 45478 . 45875) (SCANFILEHELP 45877 . +46987))))) STOP diff --git a/sources/LOADFNS.LCOM b/sources/LOADFNS.LCOM index ee8151b6..e316b11f 100644 Binary files a/sources/LOADFNS.LCOM and b/sources/LOADFNS.LCOM differ diff --git a/sources/MACHINEINDEPENDENT b/sources/MACHINEINDEPENDENT index 67e15d34..31804af4 100644 --- a/sources/MACHINEINDEPENDENT +++ b/sources/MACHINEINDEPENDENT @@ -1,14 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "29-Sep-2025 12:51:06"  -{DSK}kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;39 119579 +(FILECREATED "22-Feb-2026 13:55:06" {WMEDLEY}MACHINEINDEPENDENT.;40 125302 :EDIT-BY rmk :CHANGES-TO (VARS MACHINEINDEPENDENTCOMS) - :PREVIOUS-DATE "18-Jan-2024 10:40:56" -{DSK}kaplan>Local>medley3.5>working-medley>sources>MACHINEINDEPENDENT.;38) + :PREVIOUS-DATE "29-Sep-2025 12:51:06" {WMEDLEY}MACHINEINDEPENDENT.;39) (PRETTYCOMPRINT MACHINEINDEPENDENTCOMS) @@ -19,9 +17,6 @@ (INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT] (COMS (* ;  "random machine-independent utilities") - (FNS DMPHASH HASHOVERFLOW) - (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST - HASHOVERFLOW.UPDATEARRAY)) (FNS BKBUFS CHANGENAME CHNGNM CLBUFS DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1 LCSKIP MAPRINT MKLIST NAMEFIELD NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE @@ -485,104 +480,6 @@ (DEFINEQ -(DMPHASH - [NLAMBDA L (* rmk%: " 6-Apr-84 14:30") - (MAPC L (FUNCTION (LAMBDA (ARRAYNAME) - (DECLARE (SPECVARS ARRAYNAME)) - (ERSETQ (PROG ((A (EVALV ARRAYNAME 'DMPHASH)) - AP) - [PRINT (LIST 'RPAQ ARRAYNAME - (COND - [(LISTP A) - (SETQ AP (CAR A)) - (LIST 'CONS [LIST 'HARRAY (HARRAYSIZE AP) - (KWOTE (HARRAYPROP - AP - 'OVERFLOW] - (KWOTE (CDR A] - (T (LIST 'HASHARRAY (HARRAYSIZE A) - (KWOTE (HARRAYPROP AP 'OVERFLOW] - (MAPHASH (OR AP A) - (FUNCTION (LAMBDA (VAL ITEM) - (PRINT (LIST 'PUTHASH (KWOTE ITEM) - (KWOTE VAL) - ARRAYNAME]) - -(HASHOVERFLOW - [LAMBDA (HARRAY) (* ; "Edited 26-Feb-91 13:16 by jds") - - (* ;; "Should be called from PUTHASH on hash overflow, but for implementations where PUTHASH calls ERRORX directly, may be called from ERRORX2 when the offender is a listp. HARRAY is guaranteed to be either HARRAYP or (LIST HARRAYP)") - - (PROG ((OLDARRAY (HASHOVERFLOW.ARRAYTEST HARRAY)) - NEWARRAY NEWSIZE OLDNUMKEYS OVACTION NEWOVFLW) - [COND - ((LISTP HARRAY) - (SETQ OVACTION (CDR HARRAY)) - - (* ;; "Get OVERFLOW method from original HARRAY since it would erroneously be ERROR if we got the method from the coerced OLDARRAY") - - (SETQ NEWOVFLW 'ERROR)) - (T (SETQ OVACTION (SETQ NEWOVFLW (HARRAYPROP OLDARRAY 'OVERFLOW] - (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS)) - - (* ;; "Compute the new array size:") - - [SETQ NEWSIZE (SELECTQ OVACTION - (NIL - (* ;; "SIZE*1.5 --- favor to bbn, since pdp-11 doesnt have floatng point, and LRSH on other systems might be faster than IQUOTIENT") - - (* ;; - "[32749 IS THE BIGGEST PRIME < 32765, THE LIMIT ON ARRAY SIZES]") - - [IMAX (+ OLDNUMKEYS 3) - (IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS) - 1]) - (ERROR (do (ERRORX (LIST 26 HARRAY)))) - (if (FLOATP OVACTION) - then [IMAX (+ OLDNUMKEYS 3) - (IMIN 32760 (FIXR (FTIMES OLDNUMKEYS OVACTION] - elseif (FIXP OVACTION) - then (IMAX (+ OLDNUMKEYS 3) - (IMIN 32749 (+ OLDNUMKEYS OVACTION))) - elseif [AND (FNTYP OVACTION) - (NUMBERP (SETQ OVACTION (APPLY* OVACTION HARRAY] - then (if (FLOATP OVACTION) - then (* ; - "recompute NUMKEYS since OVACTION might have removed keys") - [IMAX (+ (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY - 'NUMKEYS)) - 3) - (IMIN 32749 (FIXR (FTIMES OLDNUMKEYS - OVACTION] - else OVACTION) - else (* ; "Default: multiply by 1.5") - (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS)) - (IMAX (+ OLDNUMKEYS 3) - (IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS) - 1] - [SETQ NEWARRAY (REHASH OLDARRAY (HASHARRAY NEWSIZE NEWOVFLW (HARRAYPROP OLDARRAY - 'HASHBITSFN) - (HARRAYPROP OLDARRAY 'EQUIVFN] - (HASHOVERFLOW.UPDATEARRAY HARRAY NEWARRAY OLDARRAY) - (RETURN HARRAY]) -) -(DECLARE%: EVAL@COMPILE DONTCOPY -(DECLARE%: EVAL@COMPILE - -[PROGN (PUTPROPS HASHOVERFLOW.ARRAYTEST MACRO [(HARRAY) - (CAR (OR (LISTP HARRAY) - (ERRORX (LIST 27 HARRAY]) - (PUTPROPS HASHOVERFLOW.ARRAYTEST DMACRO ((HARRAY) - (\DTEST HARRAY 'HARRAYP)))] - -[PROGN (PUTPROPS HASHOVERFLOW.UPDATEARRAY MACRO ((HARRAY NEWARRAY OLDARRAY) - (FRPLACA HARRAY NEWARRAY))) - (PUTPROPS HASHOVERFLOW.UPDATEARRAY DMACRO ((HARRAY NEWARRAY OLDARRAY) - (\COPYHARRAYP NEWARRAY OLDARRAY)))] -) -) -(DEFINEQ - (BKBUFS [LAMBDA (BUFS ID) (* DD%: " 6-Oct-81 15:34") (PROG (L S) @@ -2494,24 +2391,255 @@ This has little hope of working any more.") (LOCALVARS . T) ) +(PRETTYCOMPRINT MACHINEINDEPENDENTCOMS) + +(RPAQQ MACHINEINDEPENDENTCOMS + ([COMS (* ; " %"File loader%"") + (FNS LOAD? FILESLOAD DOFILESLOAD FINDFILE-WITH-EXTENSIONS READ-FILECREATED) + (INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT] + (COMS (* ; + "random machine-independent utilities") + (FNS BKBUFS CHANGENAME CHNGNM CLBUFS DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1 + LCSKIP MAPRINT MKLIST NAMEFIELD NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE + READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE + UNSAFE.TO.MODIFY) + (VARS UNSAFE.TO.MODIFY.FNS) + (INITVARS (OK.TO.MODIFY.FNS)) + [COMS (* ; + "FILEDATE, for finding out the creation date of source files, from the compiled files.") + (FNS FILEDATE COMPILEFILETYPE) + + (* ;; "FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now. It's defined in FASLOAD.") + + (P (MOVD? 'NILL 'FASL-FILEDATE] + (P (MOVD? 'CL:FMAKUNBOUND 'UNDOABLY-FMAKUNBOUND)) + (* ; + "used in FNS.PUTDEF before CMLUNDO loaded") + ) + (COMS (* ; + "Functions for retrieving and remembering FILEMAPs and file reader environments") + (FNS FILEMAP \PARSE-FILE-HEADER GET-ENVIRONMENT-AND-FILEMAP + LOOKUP-ENVIRONMENT-AND-FILEMAP GET-FILEMAP-FROM-FILECREATED \FILEMAP-HASHOVERFLOW + FLUSHFILEMAPS LISPSOURCEFILEP LISPFILETYPE GETFILEMAP PUTFILEMAP UPDATEFILEMAP) + [INITVARS (*FILEMAP-LIMIT* 20) + (*FILEMAP-VERSIONS* 2) + (*FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \FILEMAP-HASHOVERFLOW) + (FUNCTION STRING-EQUAL-HASHBITS) + (FUNCTION STRING.EQUAL] + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FILEMAPHASH) + (GLOBALVARS *FILEMAP-LIMIT* *FILEMAP-VERSIONS* *FILEMAP-HASH*))) + (COMS (* * LVLPRINT) + (FNS LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0)) + (COMS (* ; "used by PRINTOUT") + (FNS FLUSHRIGHT PRINTPARA PRINTPARA1)) + (COMS (* ; "SUBLIS and friends") + (FNS SUBLIS SUBPAIR DSUBLIS)) + [COMS (* * CONSTANTS) + (FNS CONSTANTOK) + (P (MOVD? 'EVQ 'CONSTANT) + (MOVD? 'EVQ 'DEFERREDCONSTANT) + (MOVD? 'EVQ 'LOADTIMECONSTANT] + (COMS (* * SCRATCHLIST) + (PROP MACRO SCRATCHLIST ADDTOSCRATCHLIST) + (PROP INFO SCRATCHLIST)) + (GLOBALVARS SYSFILES LOADOPTIONS LISPXCOMS CLISPTRANFLG COMMENTFLG HISTSTR4 LISPXREADFN + REREADFLG HISTSTR0 CTRLUFLG NOLINKMESS PROMPTCHARFORMS PROMPT#FLG FILERDTBL SPELLINGS2 + USERWORDS BELLS CLISPARRAY) + (FNS NLAMBDA.ARGS) + [DECLARE%: + DONTEVAL@LOAD DOCOPY (* ; + "initialization of variables used in many places") + (ADDVARS (CLISPARRAY) + (CLISPFLG) + (CTRLUFLG) + (EDITCALLS) + (EDITHISTORY) + (EDITUNDOSAVES) + (EDITUNDOSTATS) + (GLOBALVARS) + (LCASEFLG) + (LISPXBUFS) + (LISPXCOMS) + (LISPXFNS) + (LISPXHIST) + (LISPXHISTORY) + (LISPXPRINTFLG) + (NOCLEARSTKLST) + (NOFIXFNSLST) + (NOFIXVARSLST) + (P.A.STATS) + (PROMPTCHARFORMS) + (READBUF) + (READBUFSOURCE) + (REREADFLG) + (RESETSTATE) + (SPELLSTATS1)) + (INITVARS (CHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL NIL)) + (CHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL)) + (CHCONLST2 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL + NIL NIL)) + (CLEARSTKLST T) + (CLISPTRANFLG 'CLISP% ) + (HISTSTR0 "") + (HISTSTR2 "repeat") + (HISTSTR3 "from event:") + (HISTSTR4 "ignore") + (LISPXREADFN 'READ) + (USEMAPFLG T)) + (P [MAPC '((APPLY BLKAPPLY) + (SETTOPVAL SETATOMVAL) + (GETTOPVAL GETATOMVAL) + (APPLY* BLKAPPLY*) + (RPLACA FRPLACA) + (RPLACD FRPLACD) + (STKNTH FSTKNTH) + (STKNAME FSTKNAME) + (CHARACTER FCHARACTER) + (STKARG FSTKARG) + (CHCON DCHCON) + (UNPACK DUNPACK) + (ADDPROP /ADDPROP) + (ATTACH /ATTACH) + (DREMOVE /DREMOVE) + (DSUBST /DSUBST) + (NCONC /NCONC) + (NCONC1 /NCONC1) + (PUT /PUT) + (PUTPROP /PUTPROP) + (PUTD /PUTD) + (REMPROP /REMPROP) + (RPLACA /RPLACA) + (RPLACD /RPLACD) + (SET /SET) + (SETATOMVAL /SETATOMVAL) + (SETTOPVAL /SETTOPVAL) + (SETPROPLIST /SETPROPLIST) + (SET SAVESET) + (PRINT LISPXPRINT) + (PRIN1 LISPXPRIN1) + (PRIN2 LISPXPRIN2) + (SPACES LISPXSPACES) + (TAB LISPXTAB) + (TERPRI LISPXTERPRI) + (PRINT SHOWPRINT) + (PRIN2 SHOWPRIN2) + (PUTHASH /PUTHASH) + '* + (FNCLOSER /FNCLOSER) + (FNCLOSERA /FNCLOSERA) + (FNCLOSERD /FNCLOSERD) + (EVQ DELFILE) + (NILL SMASHFILECOMS) + (PUTASSOC /PUTASSOC) + (LISTPUT1 PUTL) + (NILL I.S.OPR) + (NILL RESETUNDO) + (NILL LISPXWATCH) + 'ADDSTATS + (NILL FREEVARS) + 'USEDFREE + (COPYBYTES COPYCHARS)) + (FUNCTION (LAMBDA (X) + (MOVD? (CAR X) + (CADR X] + [MAPC '((TIME PRIN1 LISPXPRIN1) + (TIME SPACES LISPXSPACES) + (TIME PRINT LISPXPRINT) + (DEFC PRINT LISPXPRINT) + (DEFC PUTD /PUTD) + (DEFC PUTPROP /PUTPROP) + (DOLINK FNCLOSERD /FNCLOSERD) + (DOLINK FNCLOSERA /FNCLOSERA) + (DEFLIST PUTPROP /PUTPROP) + (SAVEDEF1 PUTPROP /PUTPROP) + (MKSWAPBLOCK PUTD /PUTD)) + (FUNCTION (LAMBDA (X) + (AND (CCODEP (CAR X)) + (APPLY 'CHANGENAME X] + (MAPC '[[EVALQT (LAMBDA NIL (PROG (TEM) + (RESETRESTORE NIL 'RESET) + LP + (PROMPTCHAR '_ T) + (LISPX (LISPXREAD T T)) + (GO LP] + [LISPX (LAMBDA (LISPXX) + (PRINT [AND LISPXX (PROG (LISPXLINE LISPXHIST TEM) + (RETURN (COND ((AND (NLISTP LISPXX) + (SETQ LISPXLINE + (READLINE T NIL + T))) + (APPLY LISPXX (CAR + LISPXLINE + ))) + (T (EVAL LISPXX] + T T] + [LISPXREAD (LAMBDA (FILE RDTBL) + (COND [READBUF (PROG1 (CAR READBUF) + (SETQ READBUF (CDR READBUF)))] + (T (READ FILE RDTBL] + [LISPXREADP (LAMBDA (FLG) + (COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))) + T) + (T (READP T FLG] + [LISPXUNREAD (LAMBDA (LST) + (SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF] + [LISPXREADBUF (LAMBDA (RDBUF) + (PROG NIL LP (COND ((NLISTP RDBUF) + (RETURN NIL)) + ((EQ (CAR RDBUF) + HISTSTR0) + (SETQ RDBUF (CDR RDBUF)) + (GO LP)) + (T (RETURN RDBUF] + [LISPX/ (LAMBDA (X) + X] + [LOWERCASE (LAMBDA (FLG) + (PROG1 LCASEFLG + (RAISE (NULL FLG)) + (RPAQ LCASEFLG FLG))] + [FILEPOS (LAMBDA (STR FILE) + (PROG NIL LP (COND ((EQ (PEEKC FILE) + (NTHCHAR STR 1)) + (RETURN T))) + (READC FILE) + (GO LP] + (FILEPKGCOM (NLAMBDA NIL NIL] + (FUNCTION (LAMBDA (L) + (OR (GETD (CAR L)) + (PUTD (CAR L) + (CADR L] + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA RESETBUFS + FILESLOAD) + (NLAML FILEMAP) + (LAMA READFILE NLIST))) + (LOCALVARS . T))) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA RESETBUFS FILESLOAD) + +(ADDTOVAR NLAML FILEMAP) + +(ADDTOVAR LAMA READFILE NLIST) +) (DECLARE%: DONTCOPY - (FILEMAP (NIL (12643 26068 (LOAD? 12653 . 14504) (FILESLOAD 14506 . 14795) (DOFILESLOAD 14797 . 22423) - (FINDFILE-WITH-EXTENSIONS 22425 . 25624) (READ-FILECREATED 25626 . 26066)) (26185 31506 (DMPHASH -26195 . 27789) (HASHOVERFLOW 27791 . 31504)) (32262 64370 (BKBUFS 32272 . 33391) (CHANGENAME 33393 . -33654) (CHNGNM 33656 . 35504) (CLBUFS 35506 . 36779) (DEFINE 36781 . 37505) (FNS.PUTDEF 37507 . 40922) - (EQMEMB 40924 . 41106) (EQUALN 41108 . 41937) (FNCHECK 41939 . 43946) (FNTYP1 43948 . 44045) (LCSKIP -44047 . 44891) (MAPRINT 44893 . 45839) (MKLIST 45841 . 45991) (NAMEFIELD 45993 . 47518) (NLIST 47520 - . 47855) (PRINTBELLS 47857 . 47983) (PROMPTCHAR 47985 . 49875) (RAISEP 49877 . 50138) (READFILE 50140 - . 52484) (READLINE 52486 . 57926) (REMPROPLIST 57928 . 58816) (RESETBUFS 58818 . 59268) (TAB 59270 . -59866) (UNSAVED1 59868 . 60973) (WRITEFILE 60975 . 62717) (CLOSE-AND-MAYBE-DELETE 62719 . 63063) ( -UNSAFE.TO.MODIFY 63065 . 64368)) (66589 71430 (FILEDATE 66599 . 69531) (COMPILEFILETYPE 69533 . 71428) -) (71796 98999 (FILEMAP 71806 . 72276) (\PARSE-FILE-HEADER 72278 . 76093) (GET-ENVIRONMENT-AND-FILEMAP - 76095 . 78322) (LOOKUP-ENVIRONMENT-AND-FILEMAP 78324 . 80515) (GET-FILEMAP-FROM-FILECREATED 80517 . -81341) (\FILEMAP-HASHOVERFLOW 81343 . 86007) (FLUSHFILEMAPS 86009 . 86632) (LISPSOURCEFILEP 86634 . -88026) (LISPFILETYPE 88028 . 91277) (GETFILEMAP 91279 . 91698) (PUTFILEMAP 91700 . 93891) ( -UPDATEFILEMAP 93893 . 98997)) (99665 103251 (LVLPRINT 99675 . 99848) (LVLPRIN1 99850 . 100032) ( -LVLPRIN2 100034 . 100266) (LVLPRIN 100268 . 101282) (LVLPRIN0 101284 . 103249)) (103285 108202 ( -FLUSHRIGHT 103295 . 104110) (PRINTPARA 104112 . 105210) (PRINTPARA1 105212 . 108200)) (108238 110523 ( -SUBLIS 108248 . 108856) (SUBPAIR 108858 . 110086) (DSUBLIS 110088 . 110521)) (110546 111146 ( -CONSTANTOK 110556 . 111144)) (112899 113604 (NLAMBDA.ARGS 112909 . 113602))))) + (FILEMAP (NIL (12360 25785 (LOAD? 12370 . 14221) (FILESLOAD 14223 . 14512) (DOFILESLOAD 14514 . 22140) + (FINDFILE-WITH-EXTENSIONS 22142 . 25341) (READ-FILECREATED 25343 . 25783)) (25902 58010 (BKBUFS 25912 + . 27031) (CHANGENAME 27033 . 27294) (CHNGNM 27296 . 29144) (CLBUFS 29146 . 30419) (DEFINE 30421 . +31145) (FNS.PUTDEF 31147 . 34562) (EQMEMB 34564 . 34746) (EQUALN 34748 . 35577) (FNCHECK 35579 . 37586 +) (FNTYP1 37588 . 37685) (LCSKIP 37687 . 38531) (MAPRINT 38533 . 39479) (MKLIST 39481 . 39631) ( +NAMEFIELD 39633 . 41158) (NLIST 41160 . 41495) (PRINTBELLS 41497 . 41623) (PROMPTCHAR 41625 . 43515) ( +RAISEP 43517 . 43778) (READFILE 43780 . 46124) (READLINE 46126 . 51566) (REMPROPLIST 51568 . 52456) ( +RESETBUFS 52458 . 52908) (TAB 52910 . 53506) (UNSAVED1 53508 . 54613) (WRITEFILE 54615 . 56357) ( +CLOSE-AND-MAYBE-DELETE 56359 . 56703) (UNSAFE.TO.MODIFY 56705 . 58008)) (60229 65070 (FILEDATE 60239 + . 63171) (COMPILEFILETYPE 63173 . 65068)) (65436 92639 (FILEMAP 65446 . 65916) (\PARSE-FILE-HEADER +65918 . 69733) (GET-ENVIRONMENT-AND-FILEMAP 69735 . 71962) (LOOKUP-ENVIRONMENT-AND-FILEMAP 71964 . +74155) (GET-FILEMAP-FROM-FILECREATED 74157 . 74981) (\FILEMAP-HASHOVERFLOW 74983 . 79647) ( +FLUSHFILEMAPS 79649 . 80272) (LISPSOURCEFILEP 80274 . 81666) (LISPFILETYPE 81668 . 84917) (GETFILEMAP +84919 . 85338) (PUTFILEMAP 85340 . 87531) (UPDATEFILEMAP 87533 . 92637)) (93305 96891 (LVLPRINT 93315 + . 93488) (LVLPRIN1 93490 . 93672) (LVLPRIN2 93674 . 93906) (LVLPRIN 93908 . 94922) (LVLPRIN0 94924 . +96889)) (96925 101842 (FLUSHRIGHT 96935 . 97750) (PRINTPARA 97752 . 98850) (PRINTPARA1 98852 . 101840) +) (101878 104163 (SUBLIS 101888 . 102496) (SUBPAIR 102498 . 103726) (DSUBLIS 103728 . 104161)) (104186 + 104786 (CONSTANTOK 104196 . 104784)) (106539 107244 (NLAMBDA.ARGS 106549 . 107242))))) STOP diff --git a/sources/MACHINEINDEPENDENT.LCOM b/sources/MACHINEINDEPENDENT.LCOM index 3a4d6ef1..7abe1c4a 100644 Binary files a/sources/MACHINEINDEPENDENT.LCOM and b/sources/MACHINEINDEPENDENT.LCOM differ diff --git a/sources/MCCS b/sources/MCCS index cea65763..f4524019 100644 --- a/sources/MCCS +++ b/sources/MCCS @@ -1,12 +1,12 @@ -(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8) -(FILECREATED "17-Oct-2025 08:50:00" {WMEDLEY}MCCS.;155 57020 +(FILECREATED "26-Feb-2026 12:57:11" {WMEDLEY}MCCS.;168 61634 :EDIT-BY rmk - :CHANGES-TO (VARS MCCSCOMS) + :CHANGES-TO (FNS MCCSMAPPAIRS) - :PREVIOUS-DATE "15-Oct-2025 18:31:01" {WMEDLEY}MCCS.;154) + :PREVIOUS-DATE "20-Feb-2026 09:21:16" {WMEDLEY}MCCS.;167) (PRETTYCOMPRINT MCCSCOMS) @@ -17,14 +17,14 @@ (FNS \MCCSINCCODE \MCCSPEEKCCODE \MCCSOUTCHAR \MCCSBACKCCODE \MCCSFORMATBYTESTREAM \MCCSCHARSETFN) - (FNS \CREATE.MCCS.EXTERNALFORMAT) + (FNS \CREATE.MCCS.EXTERNALFORMAT \CREATE.XCCS.EXTERNALFORMAT) (FNS \MCCS.24BITENCODING.ERROR) (INITVARS (*SIGNAL-MCCS.24BITENCODING.ERROR*)) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (CONSTANTS (\NORUNCODE 255) (NSCHARSETSHIFT 255)) (MACROS \RUNCODED))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.MCCS.EXTERNALFORMAT :MCCS) - (\CREATE.MCCS.EXTERNALFORMAT :XCCS))) + (\CREATE.XCCS.EXTERNALFORMAT :XCCS))) (* ;; "") @@ -57,7 +57,10 @@  "Mappings into MCCS: needed for hardcopy and Tedit coercion, e.g. \TEDIT.MCCS.TRANSLATE") (FNS GACHATOMCODE SYMBOLTOMCODE SIGMATOMCODE ATOMCODE MATHTOMCODE HIPPOTOMCODE - CYRILLICTOMCODE PALATINOTOMCODE]) + CYRILLICTOMCODE PALATINOTOMCODE)) + (COMS (FNS SYSTEM-EXTERNALFORMAT MTOSYSSTRING SYSTOMSTRING) + (EXPORT (GLOBALVARS *SYSTEM-EXTERNALFORMAT*)) + (INITVARS (*SYSTEM-EXTERNALFORMAT* :UTF-8]) @@ -291,6 +294,33 @@ (FUNCTION \MCCSFORMATBYTESTREAM) (OR EOL 'LF) T NIL NIL (FUNCTION \MCCSCHARSETFN]) + +(\CREATE.XCCS.EXTERNALFORMAT + [LAMBDA (NAME EOL) (* ; "Edited 5-Feb-2026 15:54 by rmk") + (* ; "Edited 1-Feb-2026 12:22 by rmk") + (* ; "Edited 23-Apr-2025 14:19 by rmk") + (* ; "Edited 7-Dec-2023 23:03 by rmk") + (* ; "Edited 30-Jun-2022 18:08 by rmk") + (* ; "Edited 10-Sep-2021 19:49 by rmk:") + +(* ;;; "Create the :XCCS external format. Stream's EOL overrides the (vacuous) default here. Just like :MCCS except for switch of underscore-circumflex/arrows.") + + (MAKE-EXTERNALFORMAT (OR NAME :XCCS) + [FUNCTION (LAMBDA (STREAM COUNTP) + (XTOMCODE (\MCCSINCCODE STREAM COUNTP] + [FUNCTION (LAMBDA (STREAM NOERROR) + (XTOMCODE (\MCCSPEEKCCODE STREAM NOERROR] + [FUNCTION (LAMBDA (STREAM COUNTP) + (XTOMCODE (\MCCSBACKCCODE STREAM COUNTP] + [FUNCTION (LAMBDA (STREAM CHARCODE) + (\MCCSOUTCHAR STREAM (MTOXCODE CHARCODE] + (FUNCTION \MCCSFORMATBYTESTREAM) + (OR EOL 'LF) + T + (FUNCTION MTOXSTRING) + NIL + (FUNCTION \MCCSCHARSETFN) + (FUNCTION XTOMSTRING]) ) (DEFINEQ @@ -338,7 +368,7 @@ (\CREATE.MCCS.EXTERNALFORMAT :MCCS) -(\CREATE.MCCS.EXTERNALFORMAT :XCCS) +(\CREATE.XCCS.EXTERNALFORMAT :XCCS) ) @@ -393,7 +423,7 @@ (* ;; "Converts Unicodes to MCCS codes in XSTRING.") - (for I XCODE (MSTRING _ (CL:IF DESTRUCTIVE + (for I XCODE (MSTRING ↠(CL:IF DESTRUCTIVE XSTRING (CONCAT XSTRING))) from 1 while (SETQ XCODE (NTHCHARCODE XSTRING I)) do (RPLCHARCODE MSTRING I (XTOMCODE XCODE)) finally (RETURN MSTRING]) @@ -404,7 +434,7 @@ (* ;; "Converts XCCS to MCCS codes in XSTRING.") - (for I MCODE (XSTRING _ (CL:IF DESTRUCTIVE + (for I MCODE (XSTRING ↠(CL:IF DESTRUCTIVE MSTRING (CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I)) do (RPLCHARCODE XSTRING I (MTOXCODE MCODE)) finally (RETURN XSTRING]) @@ -466,12 +496,12 @@ ( (* ;; "From bravo doc") - (^N "356,055" MINUS) - (^V "357,44" ENDASH) - (^S EMDASH) - (^O EMQUAD) - (^X "356,055" MINUS) - (^Y FIGURESPACE ENQUAD) + (↑N "356,055" MINUS) + (↑V "357,44" ENDASH) + (↑S EMDASH) + (↑O EMQUAD) + (↑X "356,055" MINUS) + (↑Y FIGURESPACE ENQUAD) (* ;; "Fom current Helvetica/Timesroman fonts") @@ -1246,7 +1276,9 @@ (DEFINEQ (MCCSCODEMAPARRAY - [LAMBDA (MAP) (* ; "Edited 6-Sep-2025 18:26 by rmk") + [LAMBDA (MAP INVERT) (* ; "Edited 5-Feb-2026 11:02 by rmk") + (* ; "Edited 2-Feb-2026 23:11 by rmk") + (* ; "Edited 6-Sep-2025 18:26 by rmk") (* ; "Edited 31-Aug-2025 16:15 by rmk") (* ; "Edited 7-Aug-2025 08:55 by rmk") (* ; "Edited 2-Jun-2025 11:45 by rmk") @@ -1260,19 +1292,28 @@ (XCCS (SETQ MAP (APPEND MTOXCODEMAP ALTOTEXT2MCCS))) (MCCS (SETQ MAP ALTOTEXT2MCCS)) NIL) - (LET ((TABLE (ARRAY (ADD1 \MAXTHINCHAR) - 'WORD 0 0))) - (for I from 0 to \MAXTHINCHAR do (SETA TABLE I I)) + (LET ((ARRAY (ARRAY (ADD1 \MAXTHINCHAR) + 'WORD 0 0)) + HARRAY) + (for I from 0 to \MAXTHINCHAR do (SETA ARRAY I I)) (* ; "Default") [for PAIR FROMCODE in MAP when (LISTP PAIR) unless (EQ '* (CAR PAIR)) - when (SETQ FROMCODE (CL:IF (CHARCODEP (CAR PAIR)) - (CAR PAIR) + when (SETQ FROMCODE (OR (CHARCODEP (CAR PAIR)) (CHARCODE.DECODE (CAR PAIR) - T))) do (SETA TABLE FROMCODE (CL:IF (CHARCODEP - (CADR PAIR)) - (CADR PAIR) + T))) do (SETA ARRAY FROMCODE (OR (CHARCODEP (CADR PAIR)) (CHARCODE.DECODE - (CADR PAIR)))] - TABLE]) + (CADR PAIR] + (CL:WHEN INVERT + (SETQ HARRAY (HASHARRAY 20)) + (for I from 0 to \MAXTHINCHAR do (PUTHASH I I HARRAY)) + (for PAIR FROMCODE in MAP when (LISTP PAIR) unless (EQ '* (CAR PAIR)) + do (PUTHASH (OR (CHARCODEP (CADR PAIR)) + (CHARCODE.DECODE (CADR PAIR))) + (OR (CHARCODEP (CAR PAIR)) + (CHARCODE.DECODE (CAR PAIR))) + HARRAY))) + (CL:IF HARRAY + (LIST ARRAY HARRAY) + ARRAY)]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY @@ -1327,7 +1368,8 @@ NIL]) (MCCSMAPPAIRS - [LAMBDA (FROMENCODING NONIDENTITY) (* ; "Edited 7-Oct-2025 14:47 by rmk") + [LAMBDA (FROMENCODING NONIDENTITY) (* ; "Edited 26-Feb-2026 12:56 by rmk") + (* ; "Edited 7-Oct-2025 14:47 by rmk") (* ; "Edited 6-Oct-2025 09:47 by rmk") (* ; "Edited 20-Sep-2025 09:45 by rmk") (* ; "Edited 6-Sep-2025 16:43 by rmk") @@ -1335,27 +1377,30 @@ (* ;; "Returns the pairs for MOVEFONTCHARS to use to move charset-0 glyphs into their MCCS positions. For example, the Leftarrow and Lowline glyphs switch positions in an XCCS$ font. Returns NIL (= nothing to do) if there is no function.") - (LET ((FN (MCCSMAPFN FROMENCODING)) - PAIRS KEEPCS0) - (CL:WHEN FN - [SETQ PAIRS (SELECTQ FROMENCODING - (GACHA (* ; "ctrl and upper are slugged") - [APPEND (XCCSUNDEFINEDPAIRS) - '(((Uparrow TERMINAL) - Circumflex) - (^X Lowline]) - (ALTOTEXT (APPEND (XCCSUNDEFINEDPAIRS) - ALTOTEXT2MCCS)) - (XCCS$ '((Uparrow Circumflex) - (Leftarrow Lowline) - (Lowline Leftarrow) - (Circumflex Uparrow))) - (PALATINO (APPEND (XCCS.CS0.UNDEFINED) - PALATINOTOMCCS)) - (PROGN (SETQ KEEPCS0 T) - (for C M from 0 to \MAXTHINCHAR - when (SETQ M (APPLY* FN C NONIDENTITY)) - collect (LIST C M] + (LET (PAIRS KEEPCS0) + [SETQ PAIRS (SELECTQ FROMENCODING + (GACHA (* ; "ctrl and upper are slugged") + [APPEND (XCCSUNDEFINEDPAIRS) + '(((Uparrow TERMINAL) + Circumflex) + (↑X Lowline]) + (ALTOTEXT (APPEND (XCCSUNDEFINEDPAIRS) + ALTOTEXT2MCCS)) + (XCCS$ '((Uparrow Circumflex) + (Leftarrow Lowline) + (Lowline Leftarrow) + (Circumflex Uparrow))) + (UNICODE *UNICODETOMCCS*) + (PALATINO (APPEND (XCCS.CS0.UNDEFINED) + PALATINOTOMCCS)) + (PROGN (SETQ KEEPCS0 T) + (for C M FN from 0 to \MAXTHINCHAR first (CL:UNLESS (SETQ FN + (MCCSMAPFN + FROMENCODING)) + (RETURN)) + when (SETQ M (APPLY* FN C NONIDENTITY)) + collect (LIST C M] + (CL:WHEN (LISTP PAIRS) (* ;; "Weed out interspersed comments, convert to charcodes") @@ -1378,14 +1423,16 @@ (* ;; "Any character that is moved gets replaced by a slug. It may then be coerced from another font. But families like SYMBOL, HIPPO etc. want to preserve CS0 even if they copy their glyphs also to somewhere else.") - [APPEND PAIRS (for P in PAIRS when (CAR P) - unless [OR (AND KEEPCS0 (ILEQ (CAR P) - \MAXTHINCHAR)) - (AND (LISTP (CAR P)) - (LITATOM (CADAR P))) - (thereis X in PAIRS suchthat (EQ (CADR X) - (CAR P] - collect (LIST NIL (CAR P])]) + [SETQ PAIRS (APPEND PAIRS (for P in PAIRS when (CAR P) + unless [OR (AND KEEPCS0 (ILEQ (CAR P) + \MAXTHINCHAR)) + (AND (LISTP (CAR P)) + (LITATOM (CADAR P))) + (thereis X in PAIRS + suchthat (EQ (CADR X) + (CAR P] + collect (LIST NIL (CAR P]) + PAIRS]) (XCCS.CS0.UNDEFINED [LAMBDA NIL (* ; "Edited 5-Oct-2025 22:44 by rmk") @@ -1418,7 +1465,7 @@ (* ;; "Gacha did not have a code for circumflex, so there is nothing to map") - (CL:IF (EQ GCODE (CHARCODE ^X)) + (CL:IF (EQ GCODE (CHARCODE ↑X)) (CHARCODE Lowline) GCODE)]) @@ -1496,16 +1543,52 @@ MCODE))) PCODE]) ) +(DEFINEQ + +(SYSTEM-EXTERNALFORMAT + [LAMBDA NIL (* ; "Edited 6-Feb-2026 11:29 by rmk") + (* ; "Edited 31-Jan-2026 18:51 by rmk") + (* ; "Edited 10-Oct-2022 11:55 by lmm") + (* ; "Edited 7-Jul-2022 10:41 by rmk") + + (* ;; "Returns the name, sets the global. For now, UTF-8 or through, could be something else.") + + (fetch (EXTERNALFORMAT NAME) of (SETQ *SYSTEM-EXTERNALFORMAT* + (FIND-FORMAT (FOR X IN '("LC_CTYPE" "LC_ALL" "LANG") + WHEN (STRPOS ".UTF-8" (UNIX-GETENV X)) + DO (RETURN :UTF-8) FINALLY (RETURN :THROUGH]) + +(MTOSYSSTRING + [LAMBDA (MSTRING) (* ; "Edited 6-Feb-2026 00:20 by rmk") + (MCCSTOFORMATBYTES *SYSTEM-EXTERNALFORMAT* (MKSTRING MSTRING]) + +(SYSTOMSTRING + [LAMBDA (SYSTRING) (* ; "Edited 5-Feb-2026 23:36 by rmk") + + (* ;; "SYSSTRING is presumably shared with Unix, guarantee a copy on the way out") + + (CONCAT (FORMATBYTESTOMCCS *SYSTEM-EXTERNALFORMAT* SYSTRING]) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *SYSTEM-EXTERNALFORMAT*) +) + +(* "END EXPORTED DEFINITIONS") + + +(RPAQ? *SYSTEM-EXTERNALFORMAT* :UTF-8) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2853 14424 (\MCCSINCCODE 2863 . 5951) (\MCCSPEEKCCODE 5953 . 8840) (\MCCSOUTCHAR 8842 - . 10941) (\MCCSBACKCCODE 10943 . 12487) (\MCCSFORMATBYTESTREAM 12489 . 13219) (\MCCSCHARSETFN 13221 - . 14422)) (14425 15307 (\CREATE.MCCS.EXTERNALFORMAT 14435 . 15305)) (15308 16285 ( -\MCCS.24BITENCODING.ERROR 15318 . 16283)) (17661 20299 (MTOXCODE 17671 . 18468) (XTOMCODE 18470 . -19127) (XTOMSTRING 19129 . 19714) (MTOXSTRING 19716 . 20297)) (20300 21960 (MTOX$CODE 20310 . 21042) ( -X$TOMCODE 21044 . 21958)) (21961 22601 (KANJICHARSETP 21971 . 22227) (CHINESECHARSETP 22229 . 22599)) -(43169 45043 (MCCSCODEMAPARRAY 43179 . 45041)) (45659 52140 (MCCSMAPFN 45669 . 47036) (MCCSMAPPAIRS -47038 . 51146) (XCCS.CS0.UNDEFINED 51148 . 51777) (XCCSUNDEFINEDPAIRS 51779 . 52138)) (52245 56997 ( -GACHATOMCODE 52255 . 52767) (SYMBOLTOMCODE 52769 . 53417) (SIGMATOMCODE 53419 . 54065) (ATOMCODE 54067 - . 54599) (MATHTOMCODE 54601 . 55257) (HIPPOTOMCODE 55259 . 55796) (CYRILLICTOMCODE 55798 . 56232) ( -PALATINOTOMCODE 56234 . 56995))))) + (FILEMAP (NIL (3103 14674 (\MCCSINCCODE 3113 . 6201) (\MCCSPEEKCCODE 6203 . 9090) (\MCCSOUTCHAR 9092 + . 11191) (\MCCSBACKCCODE 11193 . 12737) (\MCCSFORMATBYTESTREAM 12739 . 13469) (\MCCSCHARSETFN 13471 + . 14672)) (14675 17126 (\CREATE.MCCS.EXTERNALFORMAT 14685 . 15555) (\CREATE.XCCS.EXTERNALFORMAT 15557 + . 17124)) (17127 18104 (\MCCS.24BITENCODING.ERROR 17137 . 18102)) (19480 22122 (MTOXCODE 19490 . +20287) (XTOMCODE 20289 . 20946) (XTOMSTRING 20948 . 21535) (MTOXSTRING 21537 . 22120)) (22123 23783 ( +MTOX$CODE 22133 . 22865) (X$TOMCODE 22867 . 23781)) (23784 24424 (KANJICHARSETP 23794 . 24050) ( +CHINESECHARSETP 24052 . 24422)) (45004 47493 (MCCSCODEMAPARRAY 45014 . 47491)) (48109 55125 (MCCSMAPFN + 48119 . 49486) (MCCSMAPPAIRS 49488 . 54131) (XCCS.CS0.UNDEFINED 54133 . 54762) (XCCSUNDEFINEDPAIRS +54764 . 55123)) (55230 59984 (GACHATOMCODE 55240 . 55754) (SYMBOLTOMCODE 55756 . 56404) (SIGMATOMCODE +56406 . 57052) (ATOMCODE 57054 . 57586) (MATHTOMCODE 57588 . 58244) (HIPPOTOMCODE 58246 . 58783) ( +CYRILLICTOMCODE 58785 . 59219) (PALATINOTOMCODE 59221 . 59982)) (59985 61423 (SYSTEM-EXTERNALFORMAT +59995 . 60939) (MTOSYSSTRING 60941 . 61134) (SYSTOMSTRING 61136 . 61421))))) STOP diff --git a/sources/MCCS.LCOM b/sources/MCCS.LCOM index b46f2b65..4b2d7afd 100644 Binary files a/sources/MCCS.LCOM and b/sources/MCCS.LCOM differ diff --git a/sources/MEDLEYDIR b/sources/MEDLEYDIR index ef363133..886f4497 100644 --- a/sources/MEDLEYDIR +++ b/sources/MEDLEYDIR @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "26-Nov-2025 21:51:39" {WMEDLEY}MEDLEYDIR.;43 15970 +(FILECREATED "31-Jan-2026 23:43:06" {WMEDLEY}MEDLEYDIR.;44 16074 :EDIT-BY rmk - :CHANGES-TO (VARS MEDLEYDIRCOMS) + :CHANGES-TO (FNS MEDLEYDIR) - :PREVIOUS-DATE "26-Nov-2025 17:12:16" {WMEDLEY}MEDLEYDIR.;42) + :PREVIOUS-DATE "26-Nov-2025 21:51:39" {WMEDLEY}MEDLEYDIR.;43) (PRETTYCOMPRINT MEDLEYDIRCOMS) @@ -139,7 +139,8 @@ NIL]) (MEDLEYDIR - [LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 23-Aug-2025 17:21 by lmm") + [LAMBDA (DIRNAME FILENAME OUTPUT NOERROR) (* ; "Edited 31-Jan-2026 23:42 by rmk") + (* ; "Edited 23-Aug-2025 17:21 by lmm") (* ; "Edited 18-Aug-2025 11:15 by FGH") (* ; "Edited 29-Jun-2023 22:48 by rmk") (* ; "Edited 18-Oct-2022 17:49 by lmm") @@ -184,7 +185,7 @@ (UNIX-GETENV "HOME") DIRNAME))) [(EQUAL DIRNAME "loadups") (* ; "special case for loadups dir") - (OR (DIRECTORYNAME (UNIX-GETENV "MEDLEY_LOADUPS_DIR")) + (OR (DIRECTORYNAME (UNIX-GETENV "MEDLEY¬LOADUPS¬DIR")) (DIRECTORYNAME (CONCAT (MEDLEYDIR) "loadups" ">") NIL OUTPUT) @@ -284,6 +285,6 @@ (ADDTOVAR GLOBALVARS MEDLEYDIR MEDLEY-INIT-VARS \SAVE.MEDLEYDIR DIRECTORIES SYSOUTCOMMITS) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (5329 13232 (MEDLEY-INIT-VARS 5339 . 8817) (MEDLEYDIR 8819 . 12032) (MEDLEYSUBSTDIR -12034 . 13012) (SET-SYSOUT-COMMIT 13014 . 13230))))) + (FILEMAP (NIL (5324 13336 (MEDLEY-INIT-VARS 5334 . 8812) (MEDLEYDIR 8814 . 12136) (MEDLEYSUBSTDIR +12138 . 13116) (SET-SYSOUT-COMMIT 13118 . 13334))))) STOP diff --git a/sources/MEDLEYDIR.LCOM b/sources/MEDLEYDIR.LCOM index 8ad061fb..d348dc27 100644 Binary files a/sources/MEDLEYDIR.LCOM and b/sources/MEDLEYDIR.LCOM differ diff --git a/sources/MEDLEYFONTFORMAT b/sources/MEDLEYFONTFORMAT index e40d6b49..96f410e0 100644 --- a/sources/MEDLEYFONTFORMAT +++ b/sources/MEDLEYFONTFORMAT @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "23-Jan-2026 15:10:16" {WMEDLEY}MEDLEYFONTFORMAT.;249 60332 +(FILECREATED "14-Feb-2026 00:39:34" {WMEDLEY}MEDLEYFONTFORMAT.;250 60733 :EDIT-BY rmk - :CHANGES-TO (FNS MEDLEYFONT.FILENAME MEDLEYFONT.WRITE.FONT MEDLEYFONT.READ.FONT - MEDLEYFONT.READ.VERIFIEDFONT) + :CHANGES-TO (FNS MEDLEYFONT.GETCHARSET MEDLEYFONT.READ.CHARSET) - :PREVIOUS-DATE " 9-Oct-2025 15:20:59" {WMEDLEY}MEDLEYFONTFORMAT.;242) + :PREVIOUS-DATE "23-Jan-2026 15:10:16" {WMEDLEY}MEDLEYFONTFORMAT.;249) (PRETTYCOMPRINT MEDLEYFONTFORMATCOMS) @@ -130,7 +129,8 @@ (FULLNAME STREAM]) (MEDLEYFONT.GETCHARSET - [LAMBDA (STREAM CHARSET FONT) (* ; "Edited 9-Oct-2025 15:18 by rmk") + [LAMBDA (STREAM CHARSET FONT) (* ; "Edited 14-Feb-2026 00:36 by rmk") + (* ; "Edited 9-Oct-2025 15:18 by rmk") (* ; "Edited 3-Sep-2025 11:32 by rmk") (* ; "Edited 15-Jul-2025 17:09 by rmk") (* ; "Edited 9-Jul-2025 15:45 by rmk") @@ -185,7 +185,7 @@ (SETFILEPTR STREAM (IPLUS CSVECTORLOC (UNFOLD CHARSET BYTESPERCELL))) (CL:UNLESS (EQ 0 (SETQ CSLOC (\FIXPIN STREAM))) (SETFILEPTR STREAM CSLOC))) - (MEDLEYFONT.READ.CHARSET STREAM CHARSET))))]) + (MEDLEYFONT.READ.CHARSET STREAM CHARSET FONT))))]) (MEDLEYFONT.CHARSET? [LAMBDA (FILE CHARSET) (* ; "Edited 15-Jul-2025 15:21 by rmk") @@ -343,7 +343,8 @@ FONT]) (MEDLEYFONT.READ.CHARSET - [LAMBDA (STREAM CHARSET) (* ; "Edited 4-Sep-2025 10:39 by rmk") + [LAMBDA (STREAM CHARSET FONT) (* ; "Edited 14-Feb-2026 00:36 by rmk") + (* ; "Edited 4-Sep-2025 10:39 by rmk") (* ; "Edited 28-Aug-2025 15:27 by rmk") (* ; "Edited 26-Aug-2025 23:36 by rmk") (* ; "Edited 17-Aug-2025 13:01 by rmk") @@ -356,6 +357,9 @@ (* ; "Edited 16-May-2025 20:19 by rmk") (* ; "Edited 14-May-2025 10:43 by rmk") (* ; "Edited 12-May-2025 07:55 by rmk") + + (* ;; "FONT is only needed for the \READCHARSET call below that interprets an INDIRECT and leads to a recursiving invocation of MEDLEYFONT.GETCHARSET and this function. It is the font descriptor provided at the top-level call. ") + (MEDLEYFONT.READ.ITEM STREAM 'CHARSETSTRING) (* ;  "Throwaway for looking with text editor") (LET (CSNO INDIRECT) @@ -366,7 +370,7 @@ (* ;; "Read what we peeked and use it to create a complete charset from another file (e.g. shared Kanji). ") (SETQ INDIRECT (MEDLEYFONT.READ.ITEM STREAM 'INDIRECTCHARSET)) - (\READCHARSET INDIRECT CHARSET) + (\READCHARSET INDIRECT CHARSET FONT) else (bind PAIR LABEL ITEM (CSINFO _ (create CHARSETINFO WIDTHS _ NIL OFFSETS _ NIL)) eachtime (SETQ PAIR @@ -920,11 +924,11 @@ ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (2222 16857 (MEDLEYFONT.WRITE.FONT 2232 . 7287) (MEDLEYFONT.GETCHARSET 7289 . 11316) ( -MEDLEYFONT.CHARSET? 11318 . 12787) (MEDLEYFONT.GETFILEPROP 12789 . 14889) (MEDLEYFONT.FILEP 14891 . -16855)) (16883 39217 (MEDLEYFONT.READ.FONT 16893 . 21429) (MEDLEYFONT.READ.CHARSET 21431 . 26789) ( -MEDLEYFONT.READ.ITEM 26791 . 32940) (MEDLEYFONT.PEEK.ITEM 32942 . 33804) (MEDLEYFONT.READ.FONTPROPS -33806 . 34271) (MEDLEYFONT.READ.VERIFIEDFONT 34273 . 39215)) (39243 57080 (MEDLEYFONT.WRITE.CHARSET -39253 . 43815) (MEDLEYFONT.WRITE.ITEM 43817 . 52870) (MEDLEYFONT.WRITE.FONTPROPS 52872 . 56425) ( -MEDLEYFONT.WRITE.HEADER 56427 . 57078)) (57081 59447 (MEDLEYFONT.FILENAME 57091 . 59445))))) + (FILEMAP (NIL (2152 16901 (MEDLEYFONT.WRITE.FONT 2162 . 7217) (MEDLEYFONT.GETCHARSET 7219 . 11360) ( +MEDLEYFONT.CHARSET? 11362 . 12831) (MEDLEYFONT.GETFILEPROP 12833 . 14933) (MEDLEYFONT.FILEP 14935 . +16899)) (16927 39618 (MEDLEYFONT.READ.FONT 16937 . 21473) (MEDLEYFONT.READ.CHARSET 21475 . 27190) ( +MEDLEYFONT.READ.ITEM 27192 . 33341) (MEDLEYFONT.PEEK.ITEM 33343 . 34205) (MEDLEYFONT.READ.FONTPROPS +34207 . 34672) (MEDLEYFONT.READ.VERIFIEDFONT 34674 . 39616)) (39644 57481 (MEDLEYFONT.WRITE.CHARSET +39654 . 44216) (MEDLEYFONT.WRITE.ITEM 44218 . 53271) (MEDLEYFONT.WRITE.FONTPROPS 53273 . 56826) ( +MEDLEYFONT.WRITE.HEADER 56828 . 57479)) (57482 59848 (MEDLEYFONT.FILENAME 57492 . 59846))))) STOP diff --git a/sources/MEDLEYFONTFORMAT.LCOM b/sources/MEDLEYFONTFORMAT.LCOM index 68400424..23ade3fc 100644 Binary files a/sources/MEDLEYFONTFORMAT.LCOM and b/sources/MEDLEYFONTFORMAT.LCOM differ diff --git a/sources/PACKAGE-STARTUP b/sources/PACKAGE-STARTUP index dad817d4..f0af97ce 100644 --- a/sources/PACKAGE-STARTUP +++ b/sources/PACKAGE-STARTUP @@ -1,13 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) -(FILECREATED "21-Mar-2024 10:21:14" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;9| 36658 +(FILECREATED " 8-Feb-2026 11:47:57" |{WMEDLEY}PACKAGE-STARTUP.;6| 36725 - :EDIT-BY "lmm" + :EDIT-BY |rmk| - :CHANGES-TO (VARIABLES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.SHARED) + :CHANGES-TO (FUNCTIONS PACKAGE-ENABLE) - :PREVIOUS-DATE "20-Mar-2024 23:34:56" |{DSK}larry>il>medley>sources>PACKAGE-STARTUP.;8| -) + :PREVIOUS-DATE "21-Mar-2024 10:21:14" |{WMEDLEY}PACKAGE-STARTUP.;5|) (PRETTYCOMPRINT PACKAGE-STARTUPCOMS) @@ -566,7 +565,8 @@ (CONCOCT-SYMBOL I)) T) -(CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*)) +(CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*)) + (* \; "Edited 8-Feb-2026 11:47 by rmk") "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly." (DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *PACKAGE* *OLD-INTERLISP-READ-ENVIRONMENT* *PER-EXEC-VARIABLES*)) @@ -594,8 +594,8 @@ (T (PROMPTPRINT "Invalid package, reset to LISP") (SETQ *PACKAGE* (CL:FIND-PACKAGE "LISP"))))) *PER-EXEC-VARIABLES* :TEST 'CL:EQUAL) - (CL:SETF *DEFAULT-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT - :XCCS)) + (CL:SETF *DEFAULT-MAKEFILE-ENVIRONMENT* `(:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :FORMAT + ,*DEFAULT-EXTERNALFORMAT*)) (MOVD '\\NEW.READ.SYMBOL '\\READ.SYMBOL) (MOVD '\\NEW.MKATOM '\\MKATOM) (CL:SETF *PACKAGE* PACKAGE) @@ -644,14 +644,14 @@ (PACKAGE-INIT) ) (DECLARE\: DONTCOPY - (FILEMAP (NIL (3038 3133 (RETURN-FIRST-OF-THREE 3038 . 3133)) (3135 3273 ( -ERROR-MISSING-EXTERNAL-SYMBOL 3135 . 3273)) (3880 4848 (CHECK-SYMBOL-NAMESTRING 3880 . 4848)) (4850 -8008 (\\NEW.READ.SYMBOL 4850 . 8008)) (8010 9720 (\\NEW.MKATOM 8010 . 9720)) (23549 23631 ( -LITATOM.EXISTS 23549 . 23631)) (24311 25317 (NAMESTRING-CONVERSION-CLAUSE 24311 . 25317)) (25319 26574 - (CONVERT-LITATOM 25319 . 26574)) (26576 28649 (CONCOCT-SYMBOL 26576 . 28649)) (28651 28945 ( -TRANSFER-SYMBOL 28651 . 28945)) (28947 29655 (INTERN-LITATOM 28947 . 29655)) (29657 30336 ( -\\LITATOM.EATCHARS 29657 . 30336)) (30338 30615 (PACKAGE-INIT 30338 . 30615)) (30617 31190 ( -PACKAGE-CLEAR 30617 . 31190)) (31192 32583 (PACKAGE-MAKE 31192 . 32583)) (32585 33897 ( -PACKAGE-HIERARCHY-INIT 32585 . 33897)) (33899 35508 (PACKAGE-ENABLE 33899 . 35508)) (35510 36153 ( -PACKAGE-DISABLE 35510 . 36153)) (36200 36226 (ID 36200 . 36226))))) + (FILEMAP (NIL (2977 3072 (RETURN-FIRST-OF-THREE 2977 . 3072)) (3074 3212 ( +ERROR-MISSING-EXTERNAL-SYMBOL 3074 . 3212)) (3819 4787 (CHECK-SYMBOL-NAMESTRING 3819 . 4787)) (4789 +7947 (\\NEW.READ.SYMBOL 4789 . 7947)) (7949 9659 (\\NEW.MKATOM 7949 . 9659)) (23488 23570 ( +LITATOM.EXISTS 23488 . 23570)) (24250 25256 (NAMESTRING-CONVERSION-CLAUSE 24250 . 25256)) (25258 26513 + (CONVERT-LITATOM 25258 . 26513)) (26515 28588 (CONCOCT-SYMBOL 26515 . 28588)) (28590 28884 ( +TRANSFER-SYMBOL 28590 . 28884)) (28886 29594 (INTERN-LITATOM 28886 . 29594)) (29596 30275 ( +\\LITATOM.EATCHARS 29596 . 30275)) (30277 30554 (PACKAGE-INIT 30277 . 30554)) (30556 31129 ( +PACKAGE-CLEAR 30556 . 31129)) (31131 32522 (PACKAGE-MAKE 31131 . 32522)) (32524 33836 ( +PACKAGE-HIERARCHY-INIT 32524 . 33836)) (33838 35575 (PACKAGE-ENABLE 33838 . 35575)) (35577 36220 ( +PACKAGE-DISABLE 35577 . 36220)) (36267 36293 (ID 36267 . 36293))))) STOP diff --git a/sources/PACKAGE-STARTUP.LCOM b/sources/PACKAGE-STARTUP.LCOM index 49f479dc..145e0e86 100644 Binary files a/sources/PACKAGE-STARTUP.LCOM and b/sources/PACKAGE-STARTUP.LCOM differ diff --git a/sources/UFS b/sources/UFS index 29105409..3505edc9 100644 --- a/sources/UFS +++ b/sources/UFS @@ -1,12 +1,12 @@ (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) -(FILECREATED "17-Jan-2026 11:06:10" {WMEDLEY}UFS.;62 91935 +(FILECREATED " 6-Feb-2026 23:23:31" {WMEDLEY}UFS.;68 92871 :EDIT-BY rmk - :CHANGES-TO (VARS UFSCOMS) + :CHANGES-TO (FNS \UFS.NEXTFILEFN \UFSGenerateFiles \UFSDirectoryNameP \UFS.DIRECTORY.NAME) - :PREVIOUS-DATE "27-Oct-2025 11:10:55" {WMEDLEY}UFS.;61) + :PREVIOUS-DATE " 5-Feb-2026 18:34:38" {WMEDLEY}UFS.;66) (PRETTYCOMPRINT UFSCOMS) @@ -14,11 +14,6 @@ (RPAQQ UFSCOMS [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) UFS) - [COMS - (* ;; "For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed.") - - (P (MOVD? 'EVQ 'UTF8TOMSTRING) - (MOVD? 'EVQ 'MTOUTF8STRING] (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP) DIRECTORY FILEIO)) (INITVARS (\UFS.DEFAULT.EOLC NIL)) @@ -135,17 +130,6 @@ (PUTPROPS UFS FILETYPE :BCOMPL) (PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) - - - -(* ;; -"For filename coercion before UNICODE-TABLES and UNICODE are loaded. Until then, only files with 7-bit MCCS names are allowed." -) - - -(MOVD? 'EVQ 'UTF8TOMSTRING) - -(MOVD? 'EVQ 'MTOUTF8STRING) (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILESLOAD (LOADCOMP) @@ -290,7 +274,8 @@ (DEFINEQ (\UFSOpenFile - [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 16-Oct-2025 08:52 by rmk") + [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 5-Feb-2026 18:31 by rmk") + (* ; "Edited 16-Oct-2025 08:52 by rmk") (* ; "Edited 6-Jun-90 12:18 by nm") (* ;;; "Open a file.") @@ -355,7 +340,7 @@ (\UFSError CASE.CORRECT.NAME 23 FDEV))) (SETQ CDATE (CREATECELL \FIXP)) (SETQ BYTESIZE (CREATECELL \FIXP)) - [SETQ FILEID (OR (\UFSOpenFile-C (MTOUTF8STRING CASE.CORRECT.FULLFILENAME) + [SETQ FILEID (OR (\UFSOpenFile-C (MTOSYSSTRING CASE.CORRECT.FULLFILENAME) REC ACC CDATE BYTESIZE ERRNO) (RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV] (if (= (IPLUS BYTESIZE 0) @@ -398,7 +383,8 @@ ) (\UFS.RECOGNIZE.FILE - [LAMBDA (FILENAME RECOG DEV) (* ; "Edited 16-Oct-2025 10:19 by rmk") + [LAMBDA (FILENAME RECOG DEV) (* ; "Edited 5-Feb-2026 18:32 by rmk") + (* ; "Edited 16-Oct-2025 10:19 by rmk") (* ; "Edited 13-Mar-90 11:19 by nm") (* ;; "This assumes that input FILENAME is MCCS, returns MCCS") @@ -410,7 +396,7 @@ (ERRNO (CREATECELL \FIXP)) LEN) (SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV) - (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV)) + (MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD FILENAME DEV)) (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) @@ -421,28 +407,28 @@ NAMEAREA ERRNO)) (COND ((FIXP LEN) - (UTF8TOMSTRING (SUBSTRING NAMEAREA 1 LEN))) + (SYSTOMSTRING (SUBSTRING NAMEAREA 1 LEN))) (T (\UFSError FILENAME ERRNO])]) (\UFS.DIRECTORY.NAME - [LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 15-Oct-2025 16:30 by rmk") + [LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 6-Feb-2026 18:23 by rmk") + (* ; "Edited 15-Oct-2025 16:30 by rmk") (* ; "Edited 1-Apr-90 23:36 by nm") (* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"true%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"true%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.") - (* ;; "DIRSTRING is MCCS, the true name is not") + (* ;; "DIRSTRING is in system format") (if (STREQUAL DIRSTRING "<") then (RPLSTRING NAMEAREA 1 "<") 1 else (WITH.MONITOR (\UFSGetMonitor DEV) (CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV) - (MTOUTF8STRING DIRSTRING) - NAMEAREA - (CREATECELL \FIXP)))]) + DIRSTRING NAMEAREA (CREATECELL \FIXP)))]) (\UFSCloseFile - [LAMBDA (STREAMFILE) (* ; "Edited 16-Oct-2025 13:47 by rmk") + [LAMBDA (STREAMFILE) (* ; "Edited 5-Feb-2026 18:31 by rmk") + (* ; "Edited 16-Oct-2025 13:47 by rmk") (* ; "Edited 16-Sep-2023 09:21 by briggs") (* ; "Edited 30-Mar-90 10:39 by nm") (* ; "return stream") @@ -467,7 +453,7 @@ then (* ; "Open for output") (FDEVOP 'TRUNCATEFILE DEVICE STREAMFILE) (SETQ CDATE (fetch (UFSSTREAM CDATE) of STREAMFILE))) - (RETURN (if (\UFSCloseFile-C (MTOUTF8STRING UNIXNAME) + (RETURN (if (\UFSCloseFile-C (MTOSYSSTRING UNIXNAME) (fetch (UFSSTREAM FILEID) of STREAMFILE) CDATE ERRNO) then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL) @@ -482,7 +468,8 @@ ) (\UFSDeleteFile - [LAMBDA (FILENAME DEV) (* ; "Edited 27-Oct-2025 11:10 by rmk") + [LAMBDA (FILENAME DEV) (* ; "Edited 5-Feb-2026 18:31 by rmk") + (* ; "Edited 27-Oct-2025 11:10 by rmk") (* ; "Edited 30-Mar-90 10:46 by nm") (* ; "return deleted file name") (* ; "if error, return NIL") @@ -493,14 +480,15 @@  "file found and not open, so try to delete") (LET ((ERRNO (CREATECELL \FIXP))) (COND - ((\UFSDeleteFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NAME DEV)) + ((\UFSDeleteFile-C (MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD NAME DEV)) DEV ERRNO) (* ; "Success") (\UFS.FULLNAME NAME DEV T)) (T (* ; "Failure") (\UFSError NAME ERRNO DEV])]) (\UFSRenameFile - [LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 16-Oct-2025 08:46 by rmk") + [LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 5-Feb-2026 18:31 by rmk") + (* ; "Edited 16-Oct-2025 08:46 by rmk") (* ; "Edited 18-Dec-2024 12:52 by rmk") (* ; "Edited 16-Apr-90 13:46 by nm") (if (NEQ OLD-DEVICE NEW-DEVICE) @@ -518,10 +506,10 @@ (LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME 'NEW NEW-DEVICE)) (ERRNO (CREATECELL \FIXP))) (COND - ((\UFSRenameFile-C (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD - OLDUNIXNAME OLD-DEVICE)) - (MTOUTF8STRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME - NEW-DEVICE)) + ((\UFSRenameFile-C (MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME + OLD-DEVICE)) + (MTOSYSSTRING (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE + )) NEW-DEVICE ERRNO) (\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE)) (T (if (EQL (IPLUS ERRNO 0) @@ -543,7 +531,8 @@ ) (\UFSTruncateFile - [LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 16-Oct-2025 08:56 by rmk") + [LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 5-Feb-2026 18:31 by rmk") + (* ; "Edited 16-Oct-2025 08:56 by rmk") (* ; "Edited 22-Aug-90 16:46 by nm") (* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.") @@ -581,16 +570,19 @@ (* ;;  "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.") - (if (\UFSGetFileInfo-C (MTOUTF8STRING (fetch (UFSSTREAM UNIXNAME) of STREAM)) + (if (\UFSGetFileInfo-C (MTOSYSSTRING (fetch (UFSSTREAM UNIXNAME) of STREAM)) ATTR-WDATE DT ERRNO) then (replace (STREAM VALIDATION) of STREAM with DT]) (\UFSDirectoryNameP - [LAMBDA (DIRSPEC DEV) (* ; "Edited 16-Oct-2025 10:23 by rmk") + [LAMBDA (DIRSPEC DEV) (* ; "Edited 6-Feb-2026 23:19 by rmk") + (* ; "Edited 16-Oct-2025 10:23 by rmk") (* ; "Edited 21-Sep-92 15:27 by jds") (* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.") + (* ;; "DIRSPEC is in system format") + (LET ([DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC 'DEVICE) "") (OR (UNPACKFILENAME.STRING DIRSPEC 'DIRECTORY 'RETURN) @@ -606,12 +598,13 @@ (COND (DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.") - (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV)) + (SETQ LEN (\UFS.DIRECTORY.NAME (MTOSYSSTRING DIRECTORY) + NAMEAREA DEV)) (COND ((FIXP LEN) (* ;  "LEN holds the length of the %"true%" name of DIRECTORY.") - (UTF8TOMSTRING (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) - DEV NIL))) + (\UFS.FULLNAME (SYSTOMSTRING (SUBSTRING NAMEAREA 1 LEN)) + DEV NIL)) (T NIL))) (T NIL]) @@ -620,7 +613,8 @@ ) (\UFSGetFileInfo - [LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 16-Oct-2025 08:49 by rmk") + [LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 5-Feb-2026 18:32 by rmk") + (* ; "Edited 16-Oct-2025 08:49 by rmk") (* ; "Edited 30-Mar-90 12:27 by nm") (* ;;; "Get the value of the attribute for a file.") @@ -639,7 +633,7 @@ (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE) (if FILENAME - then (SETQ FILENAME (MTOUTF8STRING FILENAME)) + then (SETQ FILENAME (MTOSYSSTRING FILENAME)) (SELECTQ ATTRIBUTE (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) @@ -671,7 +665,7 @@ (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER ERRNO)) - then (UTF8TOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE)) + then (SYSTOMSTRING (CL:SUBSEQ BUFFER 0 NAMESIZE)) else (\UFSError FILENAME ERRNO DEVICE))) (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) @@ -692,7 +686,8 @@ ) (\UFSSetFileInfo - [LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 16-Oct-2025 08:51 by rmk") + [LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 5-Feb-2026 18:31 by rmk") + (* ; "Edited 16-Oct-2025 08:51 by rmk") (* ; "Edited 30-Mar-90 12:31 by nm") (* ;;; "Get the VALUE of the ATTRIBUTE for a file.") @@ -711,7 +706,7 @@ (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE PATHNAME) (if FILENAME - then (SETQ FILENAME (MTOUTF8STRING FILENAME)) + then (SETQ FILENAME (MTOSYSSTRING FILENAME)) (SELECTQ ATTRIBUTE (TYPE (\UFSSetFileType FILENAME VALUE)) ((CREATIONDATE WRITEDATE) @@ -735,6 +730,8 @@ (\UFSGenerateFiles [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) + (* ;; "Edited 6-Feb-2026 22:43 by rmk") + (* ;; "Edited 16-Oct-2025 11:06 by rmk") (* ;; "Edited 27-Mar-2022 15:55 by rmk: Use the EXTENSION and VERFSION in the pattern instead of the inherited defaults") @@ -750,8 +747,13 @@ (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") + (* ;; + "All the internals are in system format, individual results must be converted back to MCCS.") + + (* ;; "PATTERN is MCCS, is immediately converted to system format") + (WITH.MONITOR (\UFSGetMonitor FDEV) - [PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN)) + [PROG* ((PARSED (UNPACKFILENAME.STRING (MTOSYSSTRING PATTERN))) (DIRECTORY (OR (LISTGET PARSED 'DIRECTORY) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED 'RELATIVEDIRECTORY) FDEV) @@ -769,27 +771,26 @@ (DEFAULTVERS (OR (LISTGET PARSED 'VERSION) DEFAULTVERS))) + (* ;; "All fields are now in the system external format") + (* ;; "rmk: uses the default below, don't want NIL if the pattern includes something else.") (COND ((STREQUAL DIRECTORY "/") (SETQ DIRECTORY "<"))) - - (* ;; "DIRECTORY is MCCS, FILTER is UTF8") - - [SETQ FILTER (MTOUTF8STRING (COND - ((STREQUAL DIRECTORY "<") - (CONCAT "{" (LISTGET PARSED 'HOST) - "}" - (OR DEVICE "") - "<" - (PACKFILENAME.STRING 'NAME NAME 'EXTENSION - EXTENSION 'VERSION VERSION))) - (T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY - 'HOST - (LISTGET PARSED 'HOST) - 'DEVICE DEVICE 'NAME NAME 'EXTENSION - EXTENSION 'VERSION VERSION] + [SETQ FILTER (COND + ((STREQUAL DIRECTORY "<") + (CONCAT "{" (LISTGET PARSED 'HOST) + "}" + (OR DEVICE "") + "<" + (PACKFILENAME.STRING 'NAME NAME 'EXTENSION EXTENSION + 'VERSION VERSION))) + (T (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'HOST (LISTGET + PARSED + 'HOST) + 'DEVICE DEVICE 'NAME NAME 'EXTENSION EXTENSION 'VERSION + VERSION] (SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") DIRECTORY) NAMEAREA FDEV)) @@ -797,7 +798,7 @@ ((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR] - (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ; "DIRECTORY is now UTF8") + (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") @@ -808,8 +809,7 @@ (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (COND [(< TOTALNUM 0) - (OR (\UFSError (UTF8TOMSTRING DIRECTORY) - ERRNO FDEV) + (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR] (T (COND ((ZEROP TOTALNUM) @@ -819,7 +819,8 @@ (FMEMB 'RESETLST OPTIONS)) (RESETSAVE NIL '(AND RESETSTATE (\UFSFinishFileInfo-C ID] - (* ;; "Everything in FILEGENOBJ is UTF8") + (* ;; + "Everything in FILEGENOBJ is in system character encoding (UTF-8?)") (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) @@ -842,20 +843,21 @@ CURRENT-DEPTH _ 1 MAX-DEPTH _ FILING.ENUMERATION.DEPTH - FILTER _ - (PACKFILENAME.STRING - 'NAME - (AND NAME (MTOUTF8STRING - NAME)) - 'EXTENSION - (AND EXTENSION ( - MTOUTF8STRING - EXTENSION)) - 'VERSION VERSION])]) + FILTER _ ( + PACKFILENAME.STRING + 'NAME NAME + 'EXTENSION + EXTENSION + 'VERSION VERSION]) + ]) (\UFS.NEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY) + (* ;; "Edited 6-Feb-2026 23:23 by rmk") + + (* ;; "Edited 5-Feb-2026 18:32 by rmk") + (* ;; "Edited 16-Oct-2025 16:59 by rmk") (* ;; @@ -865,7 +867,7 @@ (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") - (* ;; "All the fields of the UFSGENFILESTATE are UTF8. FILENAME is MCCS") + (* ;; "All the fields of the UFSGENFILESTATE are in system format (UTF-8?). Returned FILENAME is converted to MCCS") (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE)) FILENAME NAMELEN NEWNAME) @@ -900,72 +902,74 @@ (LET [(FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE] - (AND (> FINFOID -1) - (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) - (CL:UNWIND-PROTECT - (CL:WHEN (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) - 0) - (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of + (CL:WHEN (AND (> FINFOID -1) + (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE))) + (CL:UNWIND-PROTECT + (CL:WHEN (> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) + 0) + (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE - ) - 0 NAMELEN)) + ) + 0 NAMELEN)) - (* ;; "NEWNAME and DIRECTORY are both UTF8") + (* ;; + "NEWNAME and DIRECTORY are both in system format, and so is FILENAME here") - (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) - of GENFILESTATE) - NEWNAME - (fetch (UFSGENFILESTATE DEV) of GENFILESTATE)) - ) - (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with FILENAME) - (COND - ((= (add FILEID 1) - (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) + (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) + of GENFILESTATE) + NEWNAME + (fetch (UFSGENFILESTATE DEV) of GENFILESTATE))) + (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with FILENAME) + (COND + ((= (add FILEID 1) + (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (* ; "Generator exhausted. ") - (\UFS.UNREGISTER.GFS GENFILESTATE T)) - (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID) - )) - (COND - ((AND (EQ (CHARCODE >) - (NTHCHARCODE FILENAME -1)) - (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE) - T) - (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH) - of GENFILESTATE) - (fetch (UFSGENFILESTATE MAX-DEPTH) of + (\UFS.UNREGISTER.GFS GENFILESTATE T)) + (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID)) + ) (* ; "\GENERATEFILES operates in MCCS") + (COND + ((AND (EQ (CHARCODE >) + (NTHCHARCODE FILENAME -1)) + (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE) + T) + (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH) + of GENFILESTATE) + (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE - ))) - [SETQ SUBGEN (\GENERATEFILES (CONCAT FILENAME - (FETCH (UFSGENFILESTATE - FILTER) - OF GENFILESTATE)) - (CL:WHEN (fetch (UFSGENFILESTATE PROPP) - of GENFILESTATE) + ))) + [SETQ SUBGEN (\GENERATEFILES + (SYSTOMSTRING (CONCAT FILENAME + (FETCH (UFSGENFILESTATE + FILTER) + OF GENFILESTATE))) + (CL:WHEN (fetch (UFSGENFILESTATE PROPP) + of GENFILESTATE) - (* ;; + (* ;;  "Need any legal attributes to cause string allocation.") - '(SIZE CREATIONDATE AUTHOR)) - '(SORT RESETLST] - (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN)) + '(SIZE CREATIONDATE AUTHOR)) + '(SORT RESETLST] + (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN)) - (* ;; "It's a directory, so let's recurse into it.") + (* ;; "It's a directory, so let's recurse into it.") - (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN)) - (replace (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE - with SUBGEN) - (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN - with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) - of GENFILESTATE))) - (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN - with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) + (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of SUBGEN)) + (replace (UFSGENFILESTATE SUBGENERATOR) of GENFILESTATE + with SUBGEN) + (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN + with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of + GENFILESTATE + ))) + (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN + with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) - (* ;; "We're set up to recurse into the SUBGEN above") + (* ;; "We're set up to recurse into the SUBGEN above") - (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)) - (NAMEONLY (UTF8TOMSTRING NEWNAME)) - (T (UTF8TOMSTRING FILENAME)))) - (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T)))]) + (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)) + (NAMEONLY (SYSTOMSTRING NEWNAME)) + (T (SYSTOMSTRING FILENAME)))) + (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T))))]) (\UFS.FILEINFOFN (LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T))))) @@ -1076,7 +1080,8 @@ (DEFINEQ (CHDIR - [LAMBDA (PATHNAME) (* ; "Edited 16-Oct-2025 18:22 by rmk") + [LAMBDA (PATHNAME) (* ; "Edited 5-Feb-2026 18:31 by rmk") + (* ; "Edited 16-Oct-2025 18:22 by rmk") (* ; "Edited 2-Apr-90 01:07 by nm") (* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.") @@ -1089,7 +1094,7 @@ (if (OR (EQ HOST 'DSK) (EQ HOST 'UNIX)) then (if (SETQ PATH (DIRECTORYNAME PATH)) - then (if (\UFSCHDIR-C (MTOUTF8STRING PATH)) + then (if (\UFSCHDIR-C (MTOSYSSTRING PATH)) then (DIRECTORYNAME PATH) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) @@ -1557,23 +1562,23 @@ update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disap (ADDTOVAR LAMA ) ) (DECLARE%: DONTCOPY - (FILEMAP (NIL (9311 10864 (\UFSCreateDevice 9321 . 9686) (\UFS.CREATE.DEVICE 9688 . 10544) ( -\UFSOpenDevice 10546 . 10723) (\UFSCloseDevice 10725 . 10862)) (15127 63821 (\UFSOpenFile 15137 . -21713) (\UFS.OPENP 21715 . 22212) (\UFS.RECOGNIZE.FILE 22214 . 23644) (\UFS.DIRECTORY.NAME 23646 . -24736) (\UFSCloseFile 24738 . 26797) (\UFSGetFileName 26799 . 26998) (\UFSDeleteFile 27000 . 28194) ( -\UFSRenameFile 28196 . 30513) (\UFSReadPages 30515 . 31650) (\UFSWritePages 31652 . 32872) ( -\UFSTruncateFile 32874 . 35280) (\UFSDirectoryNameP 35282 . 37145) (\UFSEventFn 37147 . 37809) ( -\UFSGetFileInfo 37811 . 42274) (\UFS.CREATE.PROPS 42276 . 42629) (\UFSSetFileInfo 42631 . 44977) ( -\UFSGenerateFiles 44979 . 52591) (\UFS.NEXTFILEFN 52593 . 60409) (\UFS.FILEINFOFN 60411 . 61860) ( -\UFS.VALID.PROPP 61862 . 62154) (\UFS.REGISTER.GFS 62156 . 62411) (\UFS.UNREGISTER.GFS 62413 . 62996) -(\UFS.ABORT.DIRECTORY 62998 . 63346) (\UFS.ABORT.CL-DIRECTORY 63348 . 63635) (\UFS.CLEANUP.GFS.TABLE -63637 . 63819)) (63856 70540 (\UFSMakeUnixFormatName 63866 . 64887) (\UFSParseNameString 64889 . 65263 -) (\UFSParse-Directory 65265 . 65806) (\UFS.PARSE.BODY 65808 . 66353) (\UFS.ADJUST.HOST 66355 . 66514) - (\UFS.FULLNAME 66516 . 67724) (\UFS.ADD.HOST.FIELD 67726 . 68086) (\UFS.REMOVE.HOST.FIELD 68088 . -69758) (\UFS.HANDLE.RELATIVEDIRECTORY 69760 . 70538)) (71356 72501 (CHDIR 71366 . 72499)) (72573 73559 - (\DEVICEFILE.EOSERROR 72583 . 73557)) (73632 74869 (\UNVISIBLE.PAGED.REVALIDATEFILELST 73642 . 74487) - (\UNVISIBLE.FLUSH.OPEN.STREAMS 74489 . 74867)) (74902 76528 (\UFSError 74912 . 76526)) (76572 78987 ( -\UFSGetFileType 76582 . 77183) (\UFSSetFileType 77185 . 77782) (\UFSeol 77784 . 78985)) (87630 88754 ( -\UFSGetPrintFileType 87640 . 88052) (\UFSGetFileTypeConfirm 88054 . 88502) (\UFSPrintTypeMenu 88504 . -88752)) (88784 91622 (\UFStoOtherCopyMess 88794 . 90472) (\UFStoOtherRenameMess 90474 . 91620))))) + (FILEMAP (NIL (8911 10464 (\UFSCreateDevice 8921 . 9286) (\UFS.CREATE.DEVICE 9288 . 10144) ( +\UFSOpenDevice 10146 . 10323) (\UFSCloseDevice 10325 . 10462)) (14727 64649 (\UFSOpenFile 14737 . +21421) (\UFS.OPENP 21423 . 21920) (\UFS.RECOGNIZE.FILE 21922 . 23459) (\UFS.DIRECTORY.NAME 23461 . +24590) (\UFSCloseFile 24592 . 26759) (\UFSGetFileName 26761 . 26960) (\UFSDeleteFile 26962 . 28264) ( +\UFSRenameFile 28266 . 30687) (\UFSReadPages 30689 . 31824) (\UFSWritePages 31826 . 33046) ( +\UFSTruncateFile 33048 . 35562) (\UFSDirectoryNameP 35564 . 37617) (\UFSEventFn 37619 . 38281) ( +\UFSGetFileInfo 38283 . 42853) (\UFS.CREATE.PROPS 42855 . 43208) (\UFSSetFileInfo 43210 . 45664) ( +\UFSGenerateFiles 45666 . 53078) (\UFS.NEXTFILEFN 53080 . 61237) (\UFS.FILEINFOFN 61239 . 62688) ( +\UFS.VALID.PROPP 62690 . 62982) (\UFS.REGISTER.GFS 62984 . 63239) (\UFS.UNREGISTER.GFS 63241 . 63824) +(\UFS.ABORT.DIRECTORY 63826 . 64174) (\UFS.ABORT.CL-DIRECTORY 64176 . 64463) (\UFS.CLEANUP.GFS.TABLE +64465 . 64647)) (64684 71368 (\UFSMakeUnixFormatName 64694 . 65715) (\UFSParseNameString 65717 . 66091 +) (\UFSParse-Directory 66093 . 66634) (\UFS.PARSE.BODY 66636 . 67181) (\UFS.ADJUST.HOST 67183 . 67342) + (\UFS.FULLNAME 67344 . 68552) (\UFS.ADD.HOST.FIELD 68554 . 68914) (\UFS.REMOVE.HOST.FIELD 68916 . +70586) (\UFS.HANDLE.RELATIVEDIRECTORY 70588 . 71366)) (72184 73437 (CHDIR 72194 . 73435)) (73509 74495 + (\DEVICEFILE.EOSERROR 73519 . 74493)) (74568 75805 (\UNVISIBLE.PAGED.REVALIDATEFILELST 74578 . 75423) + (\UNVISIBLE.FLUSH.OPEN.STREAMS 75425 . 75803)) (75838 77464 (\UFSError 75848 . 77462)) (77508 79923 ( +\UFSGetFileType 77518 . 78119) (\UFSSetFileType 78121 . 78718) (\UFSeol 78720 . 79921)) (88566 89690 ( +\UFSGetPrintFileType 88576 . 88988) (\UFSGetFileTypeConfirm 88990 . 89438) (\UFSPrintTypeMenu 89440 . +89688)) (89720 92558 (\UFStoOtherCopyMess 89730 . 91408) (\UFStoOtherRenameMess 91410 . 92556))))) STOP diff --git a/sources/UFS.LCOM b/sources/UFS.LCOM index 021af392..174a048d 100644 Binary files a/sources/UFS.LCOM and b/sources/UFS.LCOM differ diff --git a/sources/UNICODE-FORMATS b/sources/UNICODE-FORMATS new file mode 100644 index 00000000..1ab0cd81 --- /dev/null +++ b/sources/UNICODE-FORMATS @@ -0,0 +1,2739 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8) + +(FILECREATED "23-Feb-2026 12:15:24" {WMEDLEY}UNICODE-FORMATS.;2 216288 + + :EDIT-BY rmk + + :CHANGES-TO (VARS UNICODE-FORMATSCOMS) + (FNS MAKE-UNICODE-FORMATS) + + :PREVIOUS-DATE "23-Feb-2026 08:52:29" {WMEDLEY}UNICODE-UTF8.;26) + + +(PRETTYCOMPRINT UNICODE-FORMATSCOMS) + +(RPAQQ UNICODE-FORMATSCOMS + ( + (* ;; "Defines the UTF-8 external format. This is part of the MAKEINIT, and therefore loads and uses the ALIST mapping that is created whenever the file is dumped. ") + + (FNS UTF8.OUTCHARFN UTF8.SLUG.OUTCHARFN UTF8.INCCODEFN UTF8.PEEKCCODEFN \UTF8.BACKCCODEFN) + (FNS UTF16BE.OUTCHARFN UTF16BE.INCCODEFN UTF16BE.PEEKCCODEFN \UTF16BE.BACKCCODEFN) + (FNS UTF16LE.OUTCHARFN UTF16LE.INCCODEFN UTF16LE.PEEKCCODEFN \UTF16LE.BACKCCODEFN) + (FNS READBOM WRITEBOM) + (FNS MAKE-UNICODE-FORMATS) + [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-FORMATS 'LF] + (FNS UTF8.BINCODE \UTF8.FETCHCODE) + (FNS UTF8.VALIDATE NUTF8-BYTE1-BYTES NUTF8-CODE-BYTES NUTF8-STRING-BYTES N-MCHARS) + (COMS (* ; + "For MAKEINIT, before hashing--no need for XCCS") + (FNS MTOUCODE UTOMCODE MTOUCODE? UTOMCODE?)) + (FNS MTOUSTRING UTOMSTRING MTOUTF8STRING UTF8TOMSTRING) + (* ; + "XCCS is not so interesting in the loadup") + (FNS XTOUCODE UTOXCODE XTOUCODE? UTOXCODE? XTOUSTRING UTOXSTRING XTOUTF8STRING) + (FNS MERGE-UNICODE-TRANSLATION-TABLES UNICODE.UNMAPPED) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS UNICODE.TRANSLATE \UTF8.GETBASEBYTE UNICODE.SMALLP + TRUECODEP)) + (ADDVARS (*DEFAULT-EXTERNALFORMATS* (UNIX :UTF-8))) + (INITVARS *MCCSTOUNICODE* *UNICODETOMCCS* *LARGEUNICODES*) + (GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *LARGEUNICODES*) + (COMS + (* ;; "There are 6400 private Unicodes in 25 256-code charsets. For MCCS we map to a contiguous region of unused/reserved--private isn't big enough") + + (GLOBALVARS *NEXT-PRIVATE-UNICODE* *NEXT-PRIVATE-MCCSCODE*) + [DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) + (LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) + (FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) + (LAST-PRIVATE-MCCSCODE (CHARCODE "230,377"] + (FNS UNICODE-INIT) + (P (UNICODE-INIT))) + (DECLARE%: EVAL@LOAD DONTCOPY (FILES UNICODE-TABLES)) + (E (PRINTOUT NIL "(MERGE-UNICODE-TRANSLATION-TABLES NIL (QUOTE " (GET-MCCS-UNICODE-MAPPING + 'ALL) + "))" T)))) + + + +(* ;; +"Defines the UTF-8 external format. This is part of the MAKEINIT, and therefore loads and uses the ALIST mapping that is created whenever the file is dumped. " +) + +(DEFINEQ + +(UTF8.OUTCHARFN + [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 24-Apr-2025 15:43 by rmk") + (* ; "Edited 20-Jan-2025 20:45 by rmk") + (* ; "Edited 31-Jan-2024 00:32 by rmk") + (* ; "Edited 8-Aug-2021 13:02 by rmk:") + (* ; "Edited 17-Aug-2020 08:45 by rmk:") + (* ; "Edited 30-Jan-2020 23:08 by rmk:") + + (* ;; "Perhaps the translation table should already do the mapping for EOL to LF, but that seems to be a separate property of the stream. Also, CRLF=2 bytes.") + + (* ;; "Print UTF8 sequence for CHARCODE. Do not do MCCS to Unicode translation if RAW.") + + (IF (EQ CHARCODE (CHARCODE EOL)) + THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) + (\BOUTEOL STREAM) + ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM) + (IPLUS16 1 DATUM)) + (FOR C INSIDE (CL:IF RAW + CHARCODE + (UNICODE.TRANSLATE CHARCODE *MCCSTOUNICODE*)) + 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.SLUG.OUTCHARFN + [LAMBDA (STREAM CODE RAW) (* ; "Edited 24-Apr-2025 15:43 by rmk") + (* ; "Edited 21-Jan-2025 18:37 by rmk") + (* ; "Edited 14-Jan-2025 12:39 by rmk") + + (* ;; "Produces Unicode Representative FFFD as a slug for MCCS unmapped characters") + + (UTF8.OUTCHARFN STREAM (OR (CL:IF RAW + CODE + (XTOUCODE? CODE)) + (CONSTANT (HEXNUM? "FFFD"))) + T]) + +(UTF8.INCCODEFN + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 22-Feb-2026 14:13 by rmk") + (* ; "Edited 19-Feb-2026 11:31 by rmk") + (* ; "Edited 23-Oct-2025 08:31 by rmk") + (* ; "Edited 24-Apr-2025 15:44 by rmk") + (* ; "Edited 2-Feb-2024 11:44 by rmk") + (* ; "Edited 30-Jan-2024 22:56 by rmk") + (* ; "Edited 6-Aug-2021 16:02 by rmk:") + (* ; "Edited 6-Aug-2020 17:13 by rmk:") + + (* ;; "Do not do UNICODE to MCSS translation if RAW.") + + (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (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 (ILEQ BYTE1 127) + then + (* ;; + "Test first: Ascii is the common case. EOL requires its own translation") + + (SELCHARQ BYTE1 + (CR (SELECTC (fetch (STREAM EOLCONVENTION) of STREAM) + (CR.EOLC (* ; "Also eq BYTE1") + (CHARCODE EOL)) + (CRLF.EOLC (if (EQ (CHARCODE LF) + (\PEEKBIN STREAM T)) + then (\BIN STREAM) + (CL:WHEN COUNTP (SETQ COUNT 2)) + (CHARCODE EOL) + else BYTE1)) + BYTE1)) + (LF (CL:IF (EQ LF.EOLC (fetch (STREAM EOLCONVENTION) + of STREAM)) + (CHARCODE EOL) + BYTE1)) + BYTE1) + elseif (ILEQ BYTE1 223) + then (* ; "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)) + elseif (ILEQ BYTE1 239) + 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 (* ; "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]) + (CL:WHEN (FIXP CODE) (* ; + "Could be ENDOFSTREAMOP NIL, return NIL") + (CL:UNLESS RAW + (SETQ CODE (UNICODE.TRANSLATE (UNICODE.SMALLP (UNICODE.SMALLP CODE)) + *UNICODETOMCCS*)))) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) + CODE]) + +(UTF8.PEEKCCODEFN + [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 22-Feb-2026 14:12 by rmk") + (* ; "Edited 23-Oct-2025 08:26 by rmk") + (* ; "Edited 24-Apr-2025 15:44 by rmk") + (* ; "Edited 2-Feb-2024 11:48 by rmk") + (* ; "Edited 14-Jun-2021 22:53 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 MCCS translation if RAW") + + (PROG (BYTE1 BYTE2 BYTE3 BYTE4 CODE) + (SETQ BYTE1 (\PEEKBIN STREAM NOERROR)) + + (* ;; "Distinguish on header bytex") + + (CL:UNLESS BYTE1 (RETURN NIL)) + [if (ILEQ BYTE1 127) + then + (* ;; + "Test first: Ascii is the common case. No need to back up, since we peeked.") + + (SETQ CODE BYTE1) + elseif [ILEQ BYTE1 223 (* ; "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] + elseif (ILEQ BYTE1 239) + 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 CODE)) + (BIN STREAM) + (SETQ BYTE3 (\PEEKBIN STREAM NOERROR)) (* ; + "PEEK the last, no need to back it up") + (\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 (* ; "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 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 CODE)) + (BIN STREAM) + (SETQ BYTE4 (\PEEKBIN STREAM NOERROR)) + (\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] + (CL:WHEN (AND CODE (NOT RAW)) + (SETQ CODE (UNICODE.TRANSLATE (UNICODE.SMALLP (UNICODE.SMALLP CODE)) + *UNICODETOMCCS*))) + (RETURN CODE]) + +(\UTF8.BACKCCODEFN + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 19-Jul-2022 15:30 by rmk") + (* ; "Edited 6-Aug-2021 16:04 by rmk:") + + (* ;; "\BACKFILEPTR is NIL at beginning of FILE. Presumably a little bit more efficient if we decoded the UTF8 bytes backwards and didn't do the peek, but probably not worth the complexity. ") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (BIND (C ↠0) WHILE (IF (\BACKFILEPTR STREAM) + THEN (ADD C -1) + (EQ 2 (LRSH (\PEEKBIN STREAM) + 6)) + ELSE (CL:WHEN COUNTP (SETQ *BYTECOUNTER* C)) + (RETURN NIL)) REPEATUNTIL (EQ C -4) + FINALLY (CL:WHEN COUNTP (SETQ *BYTECOUNTER* C)) + (RETURN (UTF8.PEEKCCODEFN STREAM NIL RAW]) +) +(DEFINEQ + +(UTF16BE.OUTCHARFN + [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 24-Apr-2025 15:44 by rmk") + (* ; "Edited 31-Jan-2024 00:32 by rmk") + (* ; "Edited 8-Aug-2021 13:09 by rmk:") + (* ; "Edited 30-Jan-2020 23:08 by rmk:") + + (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do MCCS to UNICODE translation if RAW.") + + (* ;; "Not sure about EOL conversion if truly %"raw%"") + + (IF (EQ CHARCODE (CHARCODE EOL)) + THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) + ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM) + (IPLUS16 1 DATUM))) + (FOR C INSIDE (CL:IF RAW + CHARCODE + (UNICODE.TRANSLATE CHARCODE *MCCSTOUNICODE*)) DO (\WOUT STREAM C]) + +(UTF16BE.INCCODEFN + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 19-Feb-2026 11:33 by rmk") + (* ; "Edited 24-Apr-2025 15:45 by rmk") + (* ; "Edited 10-Mar-2024 12:00 by rmk") + (* ; "Edited 6-Aug-2021 16:05 by rmk:") + + (* ;; + "Do not do UNICODE to MCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (LET (CODE BYTE1 BYTE2 COUNT) + (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM))) + (SMALLP (SETQ BYTE2 (\BIN STREAM] + THEN (SETQ COUNT 2) + (SETQ CODE (create WORD + HIBYTE ↠(\BIN STREAM) + LOBYTE ↠(\BIN STREAM))) + (CL:WHEN (FIXP CODE) (* ; "Funky ENDOFSTREAMOP ?") + (CL:UNLESS RAW + (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)))) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) + CODE + ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) + +(UTF16BE.PEEKCCODEFN + [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 24-Apr-2025 15:45 by rmk") + (* ; "Edited 10-Mar-2024 12:01 by rmk") + (* ; "Edited 14-Jun-2021 22:58 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 MCCS 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 (create WORD + HIBYTE ↠BYTE1 + LOBYTE ↠BYTE2)) + (CL:IF RAW + CODE + (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)) + ELSEIF NOERROR + THEN NIL) + ELSEIF NOERROR + THEN NIL + ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) + +(\UTF16BE.BACKCCODEFN + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:28 by rmk") + (* ; "Edited 10-Mar-2024 12:02 by rmk") + (* ; "Edited 19-Jul-2022 15:14 by rmk") + (* ; "Edited 6-Aug-2021 16:07 by rmk:") + + (* ;; "\BACKFILEPTR is NIL at beginning of FILE, do nothing.") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (CL:WHEN (\BACKFILEPTR STREAM) + (LET (CODE (BYTE2 (\PEEKBIN STREAM))) + (IF (\BACKFILEPTR STREAM) + THEN (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -2)) + (SETQ CODE (create WORD + HIBYTE ↠(\PEEKBIN STREAM) + LOBYTE ↠BYTE2)) + (CL:IF RAW + CODE + (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)) + ELSEIF COUNTP + THEN (SETQ *BYTECOUNTER* -1) + NIL)))]) +) +(DEFINEQ + +(UTF16LE.OUTCHARFN + [LAMBDA (STREAM CHARCODE RAW) (* ; "Edited 24-Apr-2025 15:45 by rmk") + (* ; "Edited 10-Mar-2024 11:58 by rmk") + (* ; "Edited 8-Aug-2021 13:09 by rmk:") + (* ; "Edited 30-Jan-2020 23:08 by rmk:") + + (* ;; "PRINT UTF16 sequence for CHARCODE. Do not do MCCS to UNICODE translation if RAW.") + + (* ;; "Not sure about EOL conversion if truly %"raw%"") + + (IF (EQ CHARCODE (CHARCODE EOL)) + THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) + ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM) + (IPLUS16 1 DATUM))) + (FOR C INSIDE (CL:IF RAW + CHARCODE + (UNICODE.TRANSLATE CHARCODE *MCCSTOUNICODE*)) + DO (BOUT STREAM (fetch LOBYTE of CHARCODE)) + (BOUT STREAM (fetch HIBYTE of CHARCODE]) + +(UTF16LE.INCCODEFN + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:45 by rmk") + (* ; "Edited 10-Mar-2024 12:03 by rmk") + (* ; "Edited 6-Aug-2021 16:05 by rmk:") + + (* ;; + "Do not do UNICODE to MCCS translation if RAW. Test for SMALLPin case of funky EOF behavior") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (LET (CODE BYTE1 BYTE2 COUNT) + (IF [AND (SMALLP (SETQ BYTE1 (\BIN STREAM))) + (SMALLP (SETQ BYTE2 (\BIN STREAM] + THEN (SETQ COUNT 2) + (SETQ CODE (create WORD + LOBYTE ↠(\BIN STREAM) + HIBYTE ↠(\BIN STREAM))) + (CL:UNLESS RAW + (SETQ CODE (UNICODE.TRANSLATE CODE *UNICODETOMCCS*))) + (CL:WHEN COUNTP (SETQ *BYTECOUNTER* COUNT)) + CODE + ELSE (ERROR "ODD NUMBER OF BYTES IN UTF16 FILE" STREAM]) + +(UTF16LE.PEEKCCODEFN + [LAMBDA (STREAM NOERROR RAW) (* ; "Edited 24-Apr-2025 15:46 by rmk") + (* ; "Edited 10-Mar-2024 11:43 by rmk") + (* ; "Edited 14-Jun-2021 22:58 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 MCCS 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 BYTE2 8) + BYTE1)) + (CL:IF RAW + CODE + (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)) + ELSEIF NOERROR + THEN NIL) + ELSEIF NOERROR + THEN NIL + ELSE (ERROR "INVALID UTF16 CHARACTER" (LIST BYTE1 BYTE2]) + +(\UTF16LE.BACKCCODEFN + [LAMBDA (STREAM COUNTP RAW) (* ; "Edited 24-Apr-2025 15:28 by rmk") + (* ; "Edited 10-Mar-2024 12:04 by rmk") + (* ; "Edited 19-Jul-2022 15:14 by rmk") + (* ; "Edited 6-Aug-2021 16:07 by rmk:") + + (* ;; "\BACKFILEPTR is NIL at beginning of FILE, do nothing.") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (CL:WHEN (\BACKFILEPTR STREAM) + (LET (CODE (BYTE2 (\PEEKBIN STREAM))) + (IF (\BACKFILEPTR STREAM) + THEN (CL:WHEN COUNTP (SETQ *BYTECOUNTER* -2)) + (SETQ CODE (create WORD + HIBYTE ↠BYTE2 + LOBYTE ↠(\PEEKBIN STREAM))) + (CL:IF RAW + CODE + (UNICODE.TRANSLATE CODE *UNICODETOMCCS*)) + ELSEIF COUNTP + THEN (SETQ *BYTECOUNTER* -1) + NIL)))]) +) +(DEFINEQ + +(READBOM + [LAMBDA (STREAM COUNTP) (* ; "Edited 17-Jan-2025 11:29 by rmk") + (* ; "Edited 11-Mar-2024 23:53 by rmk") + (* ; "Edited 10-Mar-2024 13:01 by rmk") + + (* ;; "If COUNTP, this must be under a generic \INCCODE that binds *BYTECOUNTER*") + + (* ;; "Reads and decodes the BOM bytes. If BOM ispresent, the stream is left at the first following byte, otherwise the stream is reset to its position on entry (presumably 0).") + + (* ;; "I used the UNHEXTRING constants so that the hex bytes are visible in the code, maybe there's another function that does that?") + + (DECLARE (USEDFREE *BYTECOUNTER*)) + (SELECTC (\PEEKBIN STREAM T) + ((HEXNUM? "EF") + (BIN STREAM) + (if (EQ (CONSTANT (HEXNUM? "BB")) + (\PEEKBIN STREAM T)) + then (BIN STREAM) + (if (EQ (CONSTANT (HEXNUM? "BF")) + (\PEEKBIN STREAM T)) + then (BIN STREAM) + (CL:WHEN COUNTP (add *BYTECOUNTER* 3)) + :UTF-8 + else (\BACKFILEPTR STREAM)) + else (\BACKFILEPTR STREAM))) + ((HEXNUM? "FE") + (BIN STREAM) + (if (EQ (CONSTANT (HEXNUM? "FF")) + (\PEEKBIN STREAM T)) + then (BIN STREAM) + (CL:WHEN COUNTP (add *BYTECOUNTER* 2)) + :UTF-16BE + else (\BACKFILEPTR STREAM))) + ((HEXNUM? "FF") + (BIN STREAM) + (if (EQ (CONSTANT (HEXNUM? "FE")) + (\PEEKBIN STREAM T)) + then (BIN STREAM) + (CL:WHEN COUNTP (add *BYTECOUNTER* 2)) + :UTF-16LE + else (\BACKFILEPTR STREAM))) + NIL]) + +(WRITEBOM + [LAMBDA (STREAM FORMAT) (* ; "Edited 17-Jan-2025 11:29 by rmk") + (* ; "Edited 16-Mar-2024 20:53 by rmk") + (* ; "Edited 11-Mar-2024 23:53 by rmk") + (* ; "Edited 10-Mar-2024 13:01 by rmk") + + (* ;; "Writes a BOM that represents FORMAT (:UTF-8, :UTF16-BE, :UTF16-LE") + + (SELECTQ FORMAT + (:UTF-8 (BOUT STREAM (CONSTANT (HEXNUM? "EF"))) + (BOUT STREAM (CONSTANT (HEXNUM? "BB"))) + (BOUT STREAM (CONSTANT (HEXNUM? "BF")))) + (:UTF-16BE (BOUT STREAM (CONSTANT (HEXNUM? "FE"))) + (BOUT STREAM (CONSTANT (HEXNUM? "FF")))) + (:UTF-16LE (BOUT STREAM (CONSTANT (HEXNUM? "FF"))) + (BOUT STREAM (HEXNUM? "FE"))) + NIL]) +) +(DEFINEQ + +(MAKE-UNICODE-FORMATS + [LAMBDA (EXTERNALEOL) (* ; "Edited 23-Feb-2026 12:14 by rmk") + (* ; "Edited 22-Feb-2026 09:14 by rmk") + (* ; "Edited 5-Feb-2026 11:06 by rmk") + (* ; "Edited 17-Jan-2025 18:38 by rmk") + (* ; "Edited 10-Mar-2024 11:55 by rmk") + (* ; "Edited 8-Dec-2023 15:19 by rmk") + (* ; "Edited 19-Jul-2022 15:36 by rmk") + (* ; "Edited 6-Aug-2021 16:08 by rmk:") + + (* ;; "RAW formats do not do MCCS/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.") + + (MAKE-EXTERNALFORMAT :UTF-8 (FUNCTION UTF8.INCCODEFN) + (FUNCTION UTF8.PEEKCCODEFN) + (FUNCTION \UTF8.BACKCCODEFN) + (FUNCTION UTF8.OUTCHARFN) + NIL + 'LF NIL (FUNCTION MTOUTF8STRING) + NIL + (FUNCTION NILL) + (FUNCTION UTF8TOMSTRING)) + + (* ;; "Don't remember what this is for:") + + (\INSTALL.EXTERNALFORMAT (create EXTERNALFORMAT using (FIND-FORMAT :UTF-8) + NAME ↠:UTF-8-SLUG OUTCHARFN ↠+ (FUNCTION UTF8.SLUG.OUTCHARFN))) + (MAKE-EXTERNALFORMAT :UTF-8-RAW [FUNCTION (LAMBDA (STREAM COUNTP) + (UTF8.INCCODEFN STREAM COUNTP T] + [FUNCTION (LAMBDA (STREAM NOERROR) + (UTF8.PEEKCCODEFN STREAM NOERROR T] + [FUNCTION (LAMBDA (STREAM COUNTP) + (\UTF8.BACKCCODEFN STREAM COUNTP T] + [FUNCTION (LAMBDA (STREAM CHARCODE) + (UTF8.OUTCHARFN STREAM CHARCODE T] + NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) + (MAKE-EXTERNALFORMAT :UTF-16BE (FUNCTION UTF16BE.INCCODEFN) + (FUNCTION UTF16BE.PEEKCCODEFN) + (FUNCTION \UTF16BE.BACKCCODEFN) + (FUNCTION UTF16BE.OUTCHARFN) + NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) + (MAKE-EXTERNALFORMAT :UTF-16BE-RAW [FUNCTION (LAMBDA (STREAM COUNTP) + (UTF16BE.INCCODEFN STREAM COUNTP T] + [FUNCTION (LAMBDA (STREAM NOERROR) + (UTF16BE.PEEKCCODEFN STREAM NOERROR T] + [FUNCTION (LAMBDA (STREAM COUNTP) + (\UTF16BE.BACKCCODEFN STREAM COUNTP T] + [FUNCTION (LAMBDA (STREAM CHARCODE) + (UTF16BE.OUTCHARFN STREAM CHARCODE T] + NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) + (MAKE-EXTERNALFORMAT :UTF-16LE (FUNCTION UTF16LE.INCCODEFN) + (FUNCTION UTF16LE.PEEKCCODEFN) + (FUNCTION \UTF16LE.BACKCCODEFN) + (FUNCTION UTF16LE.OUTCHARFN) + NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL)) + (MAKE-EXTERNALFORMAT :UTF-16LE-RAW [FUNCTION (LAMBDA (STREAM COUNTP) + (UTF16LE.INCCODEFN STREAM COUNTP T] + [FUNCTION (LAMBDA (STREAM NOERROR) + (UTF16LE.PEEKCCODEFN STREAM NOERROR T] + [FUNCTION (LAMBDA (STREAM COUNTP) + (\UTF16LE.BACKCCODEFN STREAM COUNTP T] + [FUNCTION (LAMBDA (STREAM CHARCODE) + (UTF16LE.OUTCHARFN STREAM CHARCODE T] + NIL EXTERNALEOL NIL NIL NIL (FUNCTION NILL]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(MAKE-UNICODE-FORMATS 'LF) +) +(DEFINEQ + +(UTF8.BINCODE + [LAMBDA (STREAM RAW) (* ; "Edited 24-Apr-2025 15:28 by rmk") + (* ; "Edited 4-Feb-2024 01:06 by rmk") + (* ; "Edited 1-Feb-2024 11:21 by rmk") + (* ; "Edited 28-Dec-2023 13:32 by rmk") + (* ; "Edited 6-Aug-2021 16:02 by rmk:") + (* ; "Edited 6-Aug-2020 17:13 by rmk:") + + (* ;; "Decodes a UTF8 character code by binning from STREAM ") + + (* ;; "The validity of STREAM is guaranteed by the caller (presumably TEDIT), we aren't testing here for the validity of the trailing bytes.") + + (* ;; "This doesn't do EOL conversion or translation, unlike UTF8.INCCODEFN.") + + (LET ((BYTE1 (BIN STREAM)) + CODE) + [SETQ CODE (if (ILEQ BYTE1 127) + then BYTE1 + elseif (ILEQ BYTE1 223) + then (* ; "2 bytes") + (LOGOR (LLSH (LOADBYTE BYTE1 0 5) + 6) + (LOADBYTE (BIN STREAM) + 0 6)) + elseif (ILEQ BYTE1 239) + then (* ; "3 bytes") + (LOGOR (LLSH (LOADBYTE BYTE1 0 4) + 12) + (LLSH (LOADBYTE (BIN STREAM) + 0 6) + 6) + (LOADBYTE (BIN STREAM) + 0 6)) + else (* ; "4 bytes") + (LOGOR (LLSH (LOADBYTE BYTE1 0 3) + 18) + (LLSH (LOADBYTE (BIN STREAM) + 0 6) + 12) + (LLSH (LOADBYTE (BIN STREAM) + 0 6) + 6) + (LOADBYTE (BIN STREAM) + 0 6] + (CL:IF RAW + CODE + (UNICODE.TRANSLATE CODE *UNICODETOMCCS*))]) + +(\UTF8.FETCHCODE + [LAMBDA (CODESIZE BUFFER BYTEOFFSET) (* ; "Edited 28-Dec-2023 13:32 by rmk") + (* ; "Edited 6-Aug-2021 16:02 by rmk:") + (* ; "Edited 6-Aug-2020 17:13 by rmk:") + + (* ;; "Decodes a UTF8 byte sequence of size CODESIZE in BUFFER starting at BYTEOFFSET.") + + (* ;; "The validity of the thesize, buffer, and offset are guaranteed by the caller.") + + (LET ((BYTE1 (\GETBASEBYTE BUFFER BYTEOFFSET)) + BYTE2 BYTE3 BYTE4) + (SELECTQ CODESIZE + (2 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET))) + (LOGOR (LLSH (LOADBYTE BYTE1 0 5) + 6) + (LOADBYTE BYTE2 0 6))) + (3 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET))) + (SETQ BYTE3 (\UTF8.GETBASEBYTE BUFFER (IPLUS 2 BYTEOFFSET))) + (LOGOR (LLSH (LOADBYTE BYTE1 0 4) + 12) + (LLSH (LOADBYTE BYTE2 0 6) + 6) + (LOADBYTE BYTE3 0 6))) + (4 (SETQ BYTE2 (\UTF8.GETBASEBYTE BUFFER (IPLUS 1 BYTEOFFSET))) + (SETQ BYTE3 (\UTF8.GETBASEBYTE BUFFER (IPLUS 2 BYTEOFFSET))) + (SETQ BYTE4 (\UTF8.GETBASEBYTE BUFFER (IPLUS 3 BYTEOFFSET))) + (LOGOR (LLSH (LOADBYTE BYTE1 0 3) + 18) + (LLSH (LOADBYTE BYTE2 0 6) + 12) + (LLSH (LOADBYTE BYTE3 0 6) + 6) + (LOADBYTE BYTE4 0 6))) + (1 BYTE1) + (SHOULDNT]) +) +(DEFINEQ + +(UTF8.VALIDATE + [LAMBDA (STREAM BYTE) (* ; "Edited 2-Feb-2024 12:03 by rmk") + (* ; "Edited 28-Dec-2023 11:57 by rmk") + (* ; "Edited 6-Aug-2021 16:02 by rmk:") + (* ; "Edited 6-Aug-2020 17:13 by rmk:") + + (* ;; "Returns the codesize if the bytes starting at STREAM's current position form a valid UTF-8 sequence.") + + (* ;; "If BYTE is provided, it is interpreted as the just-read header byte with the stream is positioned just after it.") + + (* ;; "Test for smallp because the stream's End-of-file operation may suppress the error--otherwise an error will happen if the streams runs out of necessary bytes.") + + (* ;; "For valid sequences, returns the same value as UTF8-SIZE-FROM-BYTE1, but this reads/validates the rest of the bytes. On a non-NILreturn the stream is positioned before the header byte of the next putative code. The stream position is uncertain on a NIL return.") + + (* ;; "") + + (* ;; "Distinguish on the header byte BYTE. Not SMALLP presumably if ENDOFSTREAMOP did something unusual.") + + (CL:UNLESS BYTE + (SETQ BYTE (BIN STREAM))) + (CL:WHEN (SMALLP BYTE) + (if (ILEQ BYTE 127) + then 1 + elseif (ILEQ BYTE 223) + then (* ; " 2 bytes") + (CL:UNLESS (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] + (ILESSP BYTE 128)) + 2) + elseif (ILEQ BYTE 239) + then (* ; "3 bytes") + (CL:UNLESS (OR (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] + (ILESSP BYTE 128)) + (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] + (ILESSP BYTE 128))) + 3) + else (* ; "4 bytes") + (CL:UNLESS (OR (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] + (ILESSP BYTE 128)) + (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] + (ILESSP BYTE 128)) + (OR [NOT (SMALLP (SETQ BYTE (BIN STREAM] + (ILESSP BYTE 128))) + 4)))]) + +(NUTF8-BYTE1-BYTES + [LAMBDA (BYTE1) (* ; "Edited 3-Feb-2024 15:00 by rmk") + (* ; "Edited 8-Jan-2024 10:57 by rmk") + (* ; "Edited 28-Jun-2022 00:02 by rmk") + (* ; "Edited 10-Aug-2020 12:35 by rmk:") + + (* ;; "Returns the number of bytes in a UTF8 code representation whose first byte is BYTEE1. ") + + (IF (ILEQ BYTE1 127) + THEN 1 + ELSEIF (ILEQ BYTE1 223) + THEN 2 + ELSEIF (ILEQ BYTE1 239) + THEN 3 + ELSE 4]) + +(NUTF8-CODE-BYTES + [LAMBDA (CODE) (* ; "Edited 3-Feb-2024 14:42 by rmk") + (* ; "Edited 8-Jan-2024 10:57 by rmk") + (* ; "Edited 28-Jun-2022 00:02 by rmk") + (* ; "Edited 10-Aug-2020 12:35 by rmk:") + + (* ;; "Returns the number of bytes needed to encode in UTF8 a number headed by BYTE. ") + + (IF (ILESSP CODE 128) + THEN 1 + ELSEIF (ILESSP CODE 2048) + THEN (* ; "x800") + 2 + ELSEIF (ILESSP CODE 65536) + THEN (* ; "x10000") + 3 + ELSEIF (ILESSP CODE 2097152) + THEN (* ; "x200000") + 4 + ELSE (ERROR "INVALID UTF-8 CODE"]) + +(NUTF8-STRING-BYTES + [LAMBDA (STRING RAW) (* ; "Edited 2-Sep-2025 10:40 by rmk") + (* ; "Edited 24-Apr-2025 15:37 by rmk") + (* ; "Edited 3-Feb-2024 21:32 by rmk") + (* ; "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 MCCS string unless RAWFLG. ") + + (for I C from 1 while (SETQ C (NTHCHARCODE STRING I)) sum (NUTF8-CODE-BYTES (CL:IF RAW + C + (MTOUCODE C))]) + +(N-MCHARS + [LAMBDA (UTF8STRING) (* ; "Edited 9-Sep-2025 08:35 by rmk") + + (* ;; "Returns the number of MCCS characters coded in UTF8STRING") + + (for I B from 1 while (SETQ B (NTHCHARCODE UTF8STRING I)) by (NUTF8-BYTE1-BYTES B) count T]) +) + + + +(* ; "For MAKEINIT, before hashing--no need for XCCS") + +(DEFINEQ + +(MTOUCODE + [LAMBDA (MCODE) (* ; "Edited 22-Feb-2026 13:56 by rmk") + (UNICODE.TRANSLATE MCODE *MCCSTOUNICODE*]) + +(UTOMCODE + [LAMBDA (UCODE) (* ; "Edited 22-Feb-2026 13:57 by rmk") + (UNICODE.TRANSLATE (UNICODE.SMALLP UCODE) + *UNICODETOMCCS*]) + +(MTOUCODE? + [LAMBDA (MCODE) (* ; "Edited 22-Feb-2026 13:57 by rmk") + + (* ;; "Returns the Unix range-code(s) corresponding to MCODE if there are true mapppings, otherwise NIL. Alternative codes are returned in a list, the code itself is returned for a singleton.") + + (UNICODE.TRANSLATE MCODE *MCCSTOUNICODE* T T]) + +(UTOMCODE? + [LAMBDA (UCODE) (* ; "Edited 22-Feb-2026 13:58 by rmk") + + (* ;; "Returns the MCCS range-code(s) corresponding to UCODE if there are true mapppings, otherwise NIL. ") + + (* ;; + " NOTE: Alternative codes are returned in a list, the code itself is returned for a singleton.") + + (* ;; "Canonicalize unicodes outside of the 16-bit plane") + + (UNICODE.TRANSLATE (UNICODE.SMALLP UCODE) + *UNICODETOMCCS* T T]) +) +(DEFINEQ + +(MTOUSTRING + [LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 12:19 by rmk") + (* ; "Edited 29-Apr-2025 12:01 by rmk") + + (* ;; "Converts MCCS codes in MSTRING to Unicodes.") + + (for I MCODE (USTRING ↠(CL:IF DESTRUCTIVE + MSTRING + (CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I)) + do (RPLCHARCODE USTRING I (MTOUCODE MCODE)) finally (RETURN USTRING]) + +(UTOMSTRING + [LAMBDA (USTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 12:18 by rmk") + (* ; "Edited 29-Apr-2025 12:00 by rmk") + + (* ;; "Converts Unicodes to MCCS codes in USTRING.") + + (for I UCODE (MSTRING ↠(CL:IF DESTRUCTIVE + USTRING + (CONCAT USTRING))) from 1 while (SETQ UCODE (NTHCHARCODE USTRING I)) + do (RPLCHARCODE MSTRING I (UTOMCODE UCODE)) finally (RETURN MSTRING]) + +(MTOUTF8STRING + [LAMBDA (MSTRING) (* ; "Edited 31-Jan-2026 19:15 by rmk") + (* ; "Edited 9-Sep-2025 07:51 by rmk") + (* ; "Edited 4-Sep-2025 15:13 by rmk") + (* ; "Edited 2-Sep-2025 11:12 by rmk") + (* ; "Edited 24-Apr-2025 15:37 by rmk") + (* ; "Edited 3-Feb-2024 14:55 by rmk") + (* ; "Edited 10-Aug-2020 21:42 by rmk:") + + (* ;; + "Produces a string that contains the UTF8 bytes that represent the characters in MSTRING. ") + + (* ;; "The resulting string will not be directly interpretable inside Medley.") + + (if (if (STRINGP MSTRING) + then [OR (ffetch (STRINGP FATSTRINGP) of MSTRING) + (thereis C instring MSTRING suchthat (OR (IGEQ C 128) + (NEQ C (MTOUCODE C] + elseif (LITATOM MSTRING) + then [OR (ffetch (LITATOM FATPNAMEP) of MSTRING) + (thereis C inatom MSTRING suchthat (OR (IGEQ C 128) + (NEQ C (MTOUCODE C] + else T) + then (LET [(USTR (ALLOCSTRING (NUTF8-STRING-BYTES MSTRING] + (for I UCODE MCODE (SINDEX ↠0) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I)) + do (SETQ UCODE (MTOUCODE MCODE)) + (if (ILESSP UCODE 128) + then (RPLCHARCODE USTR (ADD SINDEX 1) + UCODE) + elseif (ILESSP UCODE 2048) + then (* ; "x800") + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 3 6) + (LRSH UCODE 6))) + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 2 6) + (LOADBYTE UCODE 0 6))) + elseif (ILESSP UCODE 65536) + then (* ; "x10000") + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 7 5) + (LRSH UCODE 12))) + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 2 6) + (LOADBYTE UCODE 6 6))) + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 2 6) + (LOADBYTE UCODE 0 6))) + elseif (ILESSP UCODE 2097152) + then (* ; "x200000") + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 15 4) + (LRSH UCODE 18))) + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 2 6) + (LOADBYTE UCODE 12 6))) + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 2 6) + (LOADBYTE UCODE 6 6))) + (RPLCHARCODE USTR (ADD SINDEX 1) + (LOGOR (LLSH 2 6) + (LOADBYTE UCODE 0 6))) + else (SHOULDNT))) + USTR) + else MSTRING]) + +(UTF8TOMSTRING + [LAMBDA (UTF8STRING) (* ; "Edited 22-Oct-2025 22:00 by rmk") + (* ; "Edited 16-Oct-2025 14:39 by rmk") + (* ; "Edited 9-Sep-2025 08:59 by rmk") + (CL:UNLESS (OR (STRINGP UTF8STRING) + (LITATOM UTF8STRING)) + (SETQ UTF8STRING (MKSTRING UTF8STRING))) + (CL:WHEN (ffetch (STRINGP FATSTRINGP) of UTF8STRING) + (\ILLEGAL.ARG UTF8STRING)) + (LET* ((NMCHARS (N-MCHARS UTF8STRING)) + (MSTRING (ALLOCSTRING NMCHARS))) + [for M NBYTES BYTE1 (BASE ↠(ffetch (STRINGP BASE) of UTF8STRING)) from 1 to NMCHARS + as OFFSET from (fetch (STRINGP OFFST) of MSTRING) by NBYTES + do (SETQ BYTE1 (\GETBASEBYTE BASE OFFSET)) + (SETQ NBYTES (NUTF8-BYTE1-BYTES BYTE1)) + (RPLCHARCODE MSTRING M (UTOMCODE (\UTF8.FETCHCODE NBYTES BASE OFFSET] + MSTRING]) +) + + + +(* ; "XCCS is not so interesting in the loadup") + +(DEFINEQ + +(XTOUCODE + [LAMBDA (XCODE) (* ; "Edited 4-Sep-2025 15:09 by rmk") + (* ; "Edited 24-May-2025 23:16 by rmk") + (* ; "Edited 24-Apr-2025 15:27 by rmk") + (* ; "Edited 9-Aug-2020 09:04 by rmk:") + (UNICODE.TRANSLATE (XTOMCODE XCODE) + *MCCSTOUNICODE*]) + +(UTOXCODE + [LAMBDA (UNICODE) (* ; "Edited 24-May-2025 23:17 by rmk") + (* ; "Edited 24-Apr-2025 15:28 by rmk") + (* ; "Edited 16-Jan-2025 23:46 by rmk") + (* ; "Edited 9-Aug-2020 09:04 by rmk:") + (MTOXCODE (UNICODE.TRANSLATE UNICODE *UNICODETOMCCS*]) + +(XTOUCODE? + [LAMBDA (XCCSCODE) (* ; "Edited 24-May-2025 23:18 by rmk") + (* ; "Edited 24-Apr-2025 15:27 by rmk") + (* ; "Edited 20-Jan-2025 20:38 by rmk") + (* ; "Edited 18-Jan-2025 11:44 by rmk") + (* ; "Edited 15-Jan-2025 19:51 by rmk") + (* ; "Edited 14-Jan-2025 13:14 by rmk") + (* ; "Edited 9-Aug-2020 09:04 by rmk:") + + (* ;; "Returns the Unix range-code(s) corresponding to XCCSCODE if there are true mapppings, otherwise NIL. Alternative codes are returned in a list, the code itself is returned for a singleton.") + + (UNICODE.TRANSLATE (XTOMCODE XCCSCODE) + *MCCSTOUNICODE* T T]) + +(UTOXCODE? + [LAMBDA (UNICODE) (* ; "Edited 24-May-2025 23:19 by rmk") + (* ; "Edited 24-Apr-2025 15:28 by rmk") + (* ; "Edited 19-Jan-2025 21:14 by rmk") + (* ; "Edited 18-Jan-2025 11:46 by rmk") + (* ; "Edited 15-Jan-2025 19:51 by rmk") + (* ; "Edited 14-Jan-2025 13:14 by rmk") + (* ; "Edited 9-Aug-2020 09:04 by rmk:") + + (* ;; "Returns the XCCS range-code(s) corresponding to UNICODE if there are true mapppings, otherwise NIL. ") + + (* ;; + " NOTE: Alternative codes are returned in a list, the code itself is returned for a singleton.") + + (MTOXCODE (UNICODE.TRANSLATE UNICODE *UNICODETOMCCS* T T]) + +(XTOUSTRING + [LAMBDA (XSTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 12:00 by rmk") + (* ; "Edited 29-Apr-2025 12:01 by rmk") + + (* ;; "Converts XCCS codes in XSTRING to Unicodes.") + + (for I UCODE XCODE (USTRING ↠(CL:IF DESTRUCTIVE + XSTRING + (CONCAT XSTRING))) from 1 while (SETQ XCODE (NTHCHARCODE + XSTRING I)) + do (RPLCHARCODE USTRING I (XTOUCODE XCODE)) finally (RETURN USTRING]) + +(UTOXSTRING + [LAMBDA (USTRING DESTRUCTIVE) (* ; "Edited 2-Sep-2025 11:54 by rmk") + (* ; "Edited 29-Apr-2025 12:00 by rmk") + + (* ;; "Converts Unicodes in USTRING to XCCS codes.") + + (for I XCODE UCODE (XSTRING ↠(CL:IF DESTRUCTIVE + USTRING + (CONCAT USTRING))) from 1 while (SETQ UCODE (NTHCHARCODE + USTRING I)) + unless (EQ UCODE (SETQ XCODE (UTOXCODE UCODE))) do (RPLCHARCODE XSTRING I XCODE) + finally (RETURN XSTRING]) + +(XTOUTF8STRING + [LAMBDA (XSTRING) (* ; "Edited 4-Sep-2025 18:37 by rmk") + (* ; "Edited 2-Sep-2025 11:37 by rmk") + (* ; "Edited 29-Apr-2025 12:53 by rmk") + (* ; "Edited 24-Apr-2025 15:42 by rmk") + (* ; "Edited 3-Feb-2024 14:55 by rmk") + (* ; "Edited 10-Aug-2020 21:42 by rmk:") + + (* ;; "Produces a string that contains the UTF8 bytes that represent the characters in XSTRING. Applies the ") + + (* ;; "The resulting string will not be interpretable inside Medley.") + + (for I C (MSTRING ↠(CONCAT XSTRING)) from 1 while (SETQ C (NTHCHARCODE XSTRING I)) + do (RPLCHARCODE MSTRING I (XTOMCODE C)) finally (RETURN (MTOUTF8STRING MSTRING]) +) +(DEFINEQ + +(MERGE-UNICODE-TRANSLATION-TABLES + [LAMBDA (INVERSE MAPPING TABLE INVERSETABLE) (* ; "Edited 21-Feb-2026 23:52 by rmk") + (* ; "Edited 11-Oct-2025 10:24 by rmk") + (* ; "Edited 24-Apr-2025 15:28 by rmk") + (* ; "Edited 1-Feb-2025 21:42 by rmk") + (* ; "Edited 26-Jan-2025 12:58 by rmk") + (* ; "Edited 22-Jan-2025 08:20 by rmk") + (* ; "Edited 19-Jan-2025 15:58 by rmk") + (* ; "Edited 18-Jan-2025 11:49 by rmk") + (* ; "Edited 27-Mar-2024 12:10 by rmk") + (* ; "Edited 3-Feb-2024 12:46 by rmk") + (* ; "Edited 31-Jan-2024 10:06 by rmk") + + (* ;; "MAPPINGS is a list of pairs that map domain codes to range codes. TABLE and INVERSETABLE default to *MCCSTOUNICODE* *UNICODETOMCCS* respectively. ") + + (CL:UNLESS TABLE + [SETQ TABLE (OR *MCCSTOUNICODE* (SETQ *MCCSTOUNICODE* (HASHARRAY (LENGTH MAPPING]) + (CL:UNLESS INVERSETABLE + [SETQ INVERSETABLE (OR *UNICODETOMCCS* (SETQ *UNICODETOMCCS* (HASHARRAY (LENGTH MAPPING]) + (for M D R OLDR in MAPPING first (CL:IF INVERSE (swap TABLE INVERSETABLE)) + eachtime (SETQ D (CAR M)) + (SETQ R (CADR M)) + + (* ;; "We don't do combiners, but we are allowing non-SMALLP's") + unless (OR (LISTP D) + (LISTP R)) do + (* ;; "The (CONS R OLDR) deals with alternatives: (U X1) (U X2) => (U (X1 X2)), lowest code first. Those are only possible in the U-to-X direction when the tables contain (X1 U) and (X2 U). There are no duplicates/alternative table entries in the X-to-U direction.") + + (SETQ OLDR (GETHASH D TABLE)) + (CL:UNLESS (MEMB R OLDR) + (PUTHASH D (SORT (CONS R OLDR)) + TABLE)) + (swap D R) + (SETQ OLDR (GETHASH D INVERSETABLE)) + (CL:UNLESS (MEMB R OLDR) + (PUTHASH D (SORT (CONS R OLDR)) + INVERSETABLE))) + (LIST TABLE INVERSETABLE]) + +(UNICODE.UNMAPPED + [LAMBDA (CODE TABLE DONTFAKE) (* ; "Edited 22-Feb-2026 16:27 by rmk") + (* ; "Edited 24-Apr-2025 15:48 by rmk") + (* ; "Edited 22-Jan-2025 08:19 by rmk") + (* ; "Edited 19-Jan-2025 22:02 by rmk") + (* ; "Edited 18-Jan-2025 12:02 by rmk") + (* ; "Edited 2-Feb-2024 23:52 by rmk") + (* ; "Edited 31-Jan-2024 10:07 by rmk") + (* ; "Edited 11-Aug-2020 20:23 by rmk:") + + (* ;; "This is the fall-out when UNICODE.TRANSLATE determines that CODE has no mapping in TRANSLATION-TABLE. We assume that the tables are complete, so unless DONTFAKE, we make up a mapping with the next unused private code in the code space.") + + (* ;; "The number of possible faked mappings is determined by the number of private-use Unicodes, since the MCCS character space is pretty sparse. The codes don't have to come from the same part of the code space, and the NEXTCODEs are saved in global variables. The last available codes are constants.") + + (* ;; "") + + (CL:UNLESS DONTFAKE + (PROG ((INVERSE (EQ TABLE *UNICODETOMCCS*)) + RANGE HASH) + (CL:WHEN (IEQP *NEXT-PRIVATE-MCCSCODE* LAST-PRIVATE-MCCSCODE) + (* ; + "Same number of available codes both ways") + (ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES")) + (if INVERSE + then (SETQ RANGE *NEXT-PRIVATE-MCCSCODE*) + (add *NEXT-PRIVATE-MCCSCODE* 1) + else (SETQ RANGE *NEXT-PRIVATE-UNICODE*) + (add *NEXT-PRIVATE-UNICODE* 1)) + (MERGE-UNICODE-TRANSLATION-TABLES INVERSE (CONS (LIST CODE RANGE))) + + (* ;; "CONS because of LIST convention so we can eventually distinguish combiners.") + + (RETURN (CONS RANGE))))]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS UNICODE.TRANSLATE MACRO [OPENLAMBDA (CODE TRANSLATION-TABLE DONTFAKE RETURNALL) + + (* ;; "If RETURNALL and there are alternatives in the RANG, the list is returned. Othewise just the first one if the fake flag allows ") + + (LET [(RANGE (OR (GETHASH CODE TRANSLATION-TABLE) + (UNICODE.UNMAPPED CODE TRANSLATION-TABLE + DONTFAKE] + (CL:WHEN RANGE + (if (AND RETURNALL (CDR RANGE)) + then RANGE + else (SETQ RANGE (CAR RANGE)) + (CL:IF DONTFAKE + (TRUECODEP RANGE TRANSLATION-TABLE) + RANGE)))]) + +(PUTPROPS \UTF8.GETBASEBYTE MACRO ((BASE OFFSET ERROR?) (* ; + "Fetches the OFFSET'th byte from BASE, checking for UTF-8 validity if ERROR?") + (IF ERROR? + THEN (LET ((BYTE (\GETBASEBYTE BASE OFFSET))) + (CL:WHEN (ILESSP BYTE 128) + (ERROR "INVALID UTF8 BYTE" BYTE)) + BYTE) + ELSE (\GETBASEBYTE BASE OFFSET)))) + +(PUTPROPS UNICODE.SMALLP MACRO [OPENLAMBDA (UNICODE) (* ; + "Cananonicalizes a large UNICODE for EQ hash-testing") + (OR (SMALLP UNICODE) + (CAR (OR (MEMBER UNICODE *LARGEUNICODES*) + (PUSH *LARGEUNICODES* UNICODE]) + +(PUTPROPS TRUECODEP MACRO (OPENLAMBDA (RANGE TABLE) + + (* ;; "Return NIL if RANGE is a fake range in TABLE, otherwise RANGE.") + + (CL:UNLESS (CL:IF (EQ TABLE *MCCSTOUNICODE*) + (AND (IGEQ RANGE FIRST-PRIVATE-UNICODE) + (ILEQ RANGE LAST-PRIVATE-UNICODE)) + (AND (IGEQ RANGE FIRST-PRIVATE-MCCSCODE) + (ILEQ RANGE LAST-PRIVATE-MCCSCODE))) + RANGE))) +) +) + +(ADDTOVAR *DEFAULT-EXTERNALFORMATS* (UNIX :UTF-8)) + +(RPAQ? *MCCSTOUNICODE* NIL) + +(RPAQ? *UNICODETOMCCS* NIL) + +(RPAQ? *LARGEUNICODES* NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *MCCSTOUNICODE* *UNICODETOMCCS* *LARGEUNICODES*) +) + + + +(* ;; +"There are 6400 private Unicodes in 25 256-code charsets. For MCCS we map to a contiguous region of unused/reserved--private isn't big enough" +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *NEXT-PRIVATE-UNICODE* *NEXT-PRIVATE-MCCSCODE*) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQ FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) + +(RPAQ LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) + +(RPAQ FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) + +(RPAQ LAST-PRIVATE-MCCSCODE (CHARCODE "230,377")) + + +(CONSTANTS (FIRST-PRIVATE-UNICODE (HEXNUM? "E000")) + (LAST-PRIVATE-UNICODE (HEXNUM? "F8FF")) + (FIRST-PRIVATE-MCCSCODE (CHARCODE "200,0")) + (LAST-PRIVATE-MCCSCODE (CHARCODE "230,377"))) +) +) +(DEFINEQ + +(UNICODE-INIT + [LAMBDA NIL (* ; "Edited 23-Feb-2026 10:14 by rmk") + (SETQ *NEXT-PRIVATE-MCCSCODE* FIRST-PRIVATE-MCCSCODE) + (SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE]) +) + +(UNICODE-INIT) +(DECLARE%: EVAL@LOAD DONTCOPY + +(FILESLOAD UNICODE-TABLES) +) +(MERGE-UNICODE-TRANSLATION-TABLES NIL (QUOTE ((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 + 9) (10 10) (11 11) (12 12) (13 13) (14 14) (15 15) (16 16) (17 17) (18 18) (19 19) (20 20) (21 21) ( +22 22) (23 23) (24 24) (25 25) (26 26) (27 27) (28 28) (29 29) (30 30) (31 31) (32 32) (33 33) (34 34) + (35 35) (36 36) (37 37) (38 38) (39 39) (40 40) (41 41) (42 42) (43 43) (44 44) (45 45) (46 46) (47 +47) (48 48) (49 49) (50 50) (51 51) (52 52) (53 53) (54 54) (55 55) (56 56) (57 57) (58 58) (59 59) ( +60 60) (61 61) (62 62) (63 63) (64 64) (65 65) (66 66) (67 67) (68 68) (69 69) (70 70) (71 71) (72 72) + (73 73) (74 74) (75 75) (76 76) (77 77) (78 78) (79 79) (80 80) (81 81) (82 82) (83 83) (84 84) (85 +85) (86 86) (87 87) (88 88) (89 89) (90 90) (91 91) (92 92) (93 93) (94 8593) (95 8592) (96 96) (97 97 +) (98 98) (99 99) (100 100) (101 101) (102 102) (103 103) (104 104) (105 105) (106 106) (107 107) (108 + 108) (109 109) (110 110) (111 111) (112 112) (113 113) (114 114) (115 115) (116 116) (117 117) (118 +118) (119 119) (120 120) (121 121) (122 122) (123 123) (124 124) (125 125) (126 126) (127 127) (161 +161) (162 162) (163 163) (164 164) (165 165) (167 167) (169 8216) (170 8220) (171 171) (172 95) (173 +94) (174 8594) (175 8595) (176 176) (177 177) (178 178) (179 179) (180 215) (181 181) (182 182) (183 +183) (184 247) (185 8217) (186 8221) (187 187) (188 188) (189 189) (190 190) (191 191) (193 768) (194 +769) (195 770) (196 771) (197 772) (198 774) (199 775) (200 776) (202 778) (203 807) (204 818) (205 +779) (206 808) (207 780) (208 8213) (209 185) (210 174) (211 169) (212 8482) (213 9834) (220 8539) ( +221 8540) (222 8541) (223 8542) (224 8486) (225 198) (226 208) (227 170) (228 294) (229 567) (230 306) + (231 319) (232 321) (233 216) (234 338) (235 186) (236 222) (237 358) (238 330) (239 329) (240 312) ( +241 230) (242 273) (243 240) (244 295) (245 305) (246 307) (247 320) (248 322) (249 248) (250 339) ( +251 223) (252 254) (253 359) (254 331) (8481 12288) (8482 12289) (8483 12290) (8484 65292) (8485 65294 +) (8491 12441) (8492 12442) (8499 12541) (8500 12542) (8501 12445) (8502 12446) (8503 12291) (8504 +20189) (8505 12293) (8506 12294) (8507 43472) (8508 12540) (8510 8208) (8512 8918) (8513 8919) (8514 +8741) (8515 8873) (8516 8230) (8517 8229) (8518 8920) (8519 8921) (8520 10220) (8521 10221) (8522 +10214) (8523 10215) (8524 12308) (8525 12309) (8526 8922) (8527 8923) (8528 8826) (8529 8827) (8530 +8828) (8531 8829) (8532 8926) (8533 8927) (8534 12300) (8535 12301) (8536 12302) (8537 12303) (8538 +12304) (8539 12305) (8540 10949) (8541 10950) (8542 8912) (8543 8913) (8544 10901) (8545 10902) (8546 +8800) (8547 10885) (8548 10886) (8549 8804) (8550 8805) (8551 8734) (8552 8756) (8553 9794) (8554 9792 +) (8555 8244) (8556 8242) (8557 8243) (8558 8451) (8559 8874) (8560 8806) (8561 8807) (8562 10877) ( +8563 10878) (8564 8922) (8565 8923) (8566 8741) (8567 8861) (8568 8859) (8569 9734) (8570 9733) (8571 +9675) (8572 9679) (8573 9678) (8574 9671) (8609 8830) (8610 8831) (8611 10935) (8612 10936) (8613 8995 +) (8614 8994) (8615 124) (8616 8785) (8617 8791) (8618 8790) (8619 8796) (8620 8916) (8621 8720) (8622 + 10016) (8623 9671) (8624 8769) (8625 8936) (8626 8937) (8627 10937) (8628 10938) (8629 8740) (8630 +8742) (8631 8876) (8632 8877) (8633 8878) (8634 8879) (8635 8938) (8636 8939) (8637 8940) (8638 8941) +(8639 8772) (8640 8777) (8641 10955) (8642 10956) (8643 8840) (8644 8841) (8645 8842) (8646 8843) ( +8647 10955) (8648 10956) (8649 8814) (8650 8815) (8651 8780) (8652 8775) (8656 8832) (8657 8833) (8658 + 8928) (8659 8929) (8660 10933) (8661 10934) (8662 8928) (8665 8820) (8666 8821) (8672 8816) (8673 +8817) (8674 10887) (8675 10888) (8676 8934) (8677 8935) (8678 8816) (8679 8817) (8686 8930) (8687 8931 +) (8688 8816) (8689 8817) (8690 8808) (8691 8809) (8692 8808) (8693 8809) (8737 9670) (8738 9633) ( +8739 9632) (8740 9651) (8741 9650) (8742 9661) (8743 9660) (8744 8251) (8745 12306) (8746 8216) (8747 +8242) (8748 8243) (8750 12307) (8751 8862) (8752 8863) (8753 8864) (8754 8865) (8756 8813) (8760 12298 +) (8761 12299) (8764 8258) (8765 8485) (8766 8241) (8768 8647) (8769 8649) (8770 8648) (8771 8650) ( +8772 8666) (8773 8667) (8774 8606) (8775 8608) (8776 8639) (8777 8643) (8778 8638) (8779 8642) (8780 +8610) (8781 8611) (8782 8619) (8783 8620) (8784 8624) (8785 8625) (8786 8621) (8787 8888) (8788 8788) +(8789 8789) (8790 8636) (8791 8637) (8792 8640) (8793 8641) (8794 8618) (8795 8617) (8796 10229) (8797 + 10230) (8798 10232) (8799 10233) (8800 8657) (8801 8659) (8802 8786) (8803 8787) (8804 8781) (8805 +10927) (8806 10928) (8807 10231) (8808 10234) (8809 10234) (8810 8748) (8811 8614) (8812 8904) (8813 +11089) (8814 9838) (8815 8995) (8816 9653) (8817 8810) (8818 8811) (8819 8853) (8820 8854) (8821 8855) + (8822 8856) (8823 8764) (8824 8776) (8825 8733) (8827 9663) (8828 8487) (8829 8768) (8830 9711) (8865 + (38 818)) (8866 8801) (8867 9049) (8868 9080) (8869 9079) (8870 8472) (8871 8709) (8872 8476) (8873 +8465) (8874 8868) (8875 8846) (8876 8871) (8877 8852) (8878 8851) (8879 8846) (8880 8849) (8881 8850) +(8882 8743) (8883 8744) (8884 9652) (8885 9662) (8886 8852) (8887 8720) (8888 8738) (8889 8717) (8890 +8951) (8891 9657) (8892 9667) (8893 8857) (8894 8765) (8896 94) (8897 (65 818)) (8898 (66 818)) (8899 +(67 818)) (8900 (68 818)) (8901 (69 818)) (8902 (70 818)) (8903 (71 818)) (8904 (72 818)) (8905 (73 +818)) (8906 (74 818)) (8907 (75 818)) (8908 (76 818)) (8909 (77 818)) (8910 (78 818)) (8911 (79 818)) +(8912 (80 818)) (8913 (81 818)) (8914 (82 818)) (8915 (83 818)) (8916 (84 818)) (8917 (85 818)) (8918 +(86 818)) (8919 (87 818)) (8920 (88 818)) (8921 (89 818)) (8922 (90 818)) (8923 9122) (8924 9125) ( +8927 9647) (8935 8474) (8936 8461) (8938 8853) (8939 8855) (8940 8857) (8941 8356) (8942 8626) (8943 +8627) (8944 8729) (8945 8988) (8946 8989) (8947 8990) (8948 8991) (8949 8858) (8994 168) (8995 180) ( +8996 175) (8997 728) (8998 729) (8999 39) (9000 730) (9001 733) (9002 731) (9003 711) (9004 184) (9008 + 183) (9009 832) (9010 833) (9011 770) (9012 771) (9013 772) (9014 774) (9015 775) (9016 776) (9018 +778) (9019 807) (9021 779) (9022 808) (9023 780) (9024 398) (9025 385) (9026 394) (9027 408) (9028 416 +) (9029 431) (9030 399) (9031 418) (9032 437) (9036 415) (9038 400) (9039 404) (9040 406) (9041 390) ( +9042 425) (9043 434) (9044 439) (9045 440) (9046 391) (9047 401) (9048 420) (9049 428) (9050 435) ( +9053 413) (9056 96) (9057 595) (9058 599) (9059 409) (9060 417) (9061 432) (9062 477) (9063 419) (9064 + 438) (9065 447) (9066 410) (9068 629) (9077 441) (9078 392) (9079 402) (9080 421) (9081 429) (9082 +436) (9086 8254) (9121 703) (9122 8216) (9124 450) (9125 451) (9126 448) (9127 449) (9129 384) (9130 +403) (9131 405) (9132 9837) (9134 8471) (9135 8485) (9136 700) (9137 699) (9138 8218) (9139 865) (9144 + 8407) (9145 824) (9146 770) (9147 771) (9148 9839) (9149 697) (9150 698) (9151 785) (9152 777) (9153 +823) (9154 8417) (9155 773) (9157 768) (9158 769) (9160 8406) (9161 776) (9162 781) (9163 789) (9164 +786) (9166 795) (9167 821) (9168 782) (9169 808) (9170 807) (9171 806) (9172 805) (9173 814) (9174 803 +) (9175 804) (9176 816) (9177 819) (9178 809) (9179 813) (9180 817) (9181 65056) (9182 65057) (9183 +65059) (9184 8401) (9186 783) (9200 831) (9201 784) (9204 788) (9205 790) (9206 791) (9207 792) (9208 +793) (9209 794) (9210 815) (9211 822) (9212 825) (9213 826) (9214 827) (9249 12353) (9250 12354) (9251 + 12355) (9252 12356) (9253 12357) (9254 12358) (9255 12359) (9256 12360) (9257 12361) (9258 12362) ( +9259 12363) (9260 12364) (9261 12365) (9262 12366) (9263 12367) (9264 12368) (9265 12369) (9266 12370) + (9267 12371) (9268 12372) (9269 12373) (9270 12374) (9271 12375) (9272 12376) (9273 12377) (9274 +12378) (9275 12379) (9276 12380) (9277 12381) (9278 12382) (9279 12383) (9280 12384) (9281 12385) ( +9282 12386) (9283 12387) (9284 12388) (9285 12389) (9286 12390) (9287 12391) (9288 12392) (9289 12393) + (9290 12394) (9291 12395) (9292 12396) (9293 12397) (9294 12398) (9295 12399) (9296 12400) (9297 +12401) (9298 12402) (9299 12403) (9300 12404) (9301 12405) (9302 12406) (9303 12407) (9304 12408) ( +9305 12409) (9306 12410) (9307 12411) (9308 12412) (9309 12413) (9310 12414) (9311 12415) (9312 12416) + (9313 12417) (9314 12418) (9315 12419) (9316 12420) (9317 12421) (9318 12422) (9319 12423) (9320 +12424) (9321 12425) (9322 12426) (9323 12427) (9324 12428) (9325 12429) (9326 12430) (9327 12431) ( +9328 12432) (9329 12433) (9330 12434) (9331 12435) (9377 12549) (9378 12550) (9379 12551) (9380 12552) + (9381 12553) (9382 12554) (9383 12555) (9384 12556) (9385 12557) (9386 12558) (9387 12559) (9388 +12560) (9389 12561) (9390 12562) (9391 12563) (9392 12564) (9393 12565) (9394 12566) (9395 12567) ( +9396 12568) (9397 12569) (9398 12570) (9399 12571) (9400 12572) (9401 12573) (9402 12574) (9403 12575) + (9404 12576) (9405 12577) (9406 12578) (9407 12579) (9408 12580) (9409 12581) (9410 12582) (9411 +12583) (9412 12584) (9413 12585) (9414 714) (9415 711) (9416 715) (9417 729) (9418 713) (9419 12587) ( +9420 12586) (9421 12588) (9505 12449) (9506 12450) (9507 12451) (9508 12452) (9509 12453) (9510 12454) + (9511 12455) (9512 12456) (9513 12457) (9514 12458) (9515 12459) (9516 12460) (9517 12461) (9518 +12462) (9519 12463) (9520 12464) (9521 12465) (9522 12466) (9523 12467) (9524 12468) (9525 12469) ( +9526 12470) (9527 12471) (9528 12472) (9529 12473) (9530 12474) (9531 12475) (9532 12476) (9533 12477) + (9534 12478) (9535 12479) (9536 12480) (9537 12481) (9538 12482) (9539 12483) (9540 12484) (9541 +12485) (9542 12486) (9543 12487) (9544 12488) (9545 12489) (9546 12490) (9547 12491) (9548 12492) ( +9549 12493) (9550 12494) (9551 12495) (9552 12496) (9553 12497) (9554 12498) (9555 12499) (9556 12500) + (9557 12501) (9558 12502) (9559 12503) (9560 12504) (9561 12505) (9562 12506) (9563 12507) (9564 +12508) (9565 12509) (9566 12510) (9567 12511) (9568 12512) (9569 12513) (9570 12514) (9571 12515) ( +9572 12516) (9573 12517) (9574 12518) (9575 12519) (9576 12520) (9577 12521) (9578 12522) (9579 12523) + (9580 12524) (9581 12525) (9582 12526) (9583 12527) (9584 12528) (9585 12529) (9586 12530) (9587 +12531) (9588 12532) (9589 12533) (9590 12534) (9591 12535) (9592 12536) (9593 12537) (9594 12538) ( +9595 12539) (9762 894) (9763 835) (9764 900) (9765 787) (9766 788) (9767 837) (9769 8158) (9770 8157) +(9771 901) (9772 8159) (9773 8128) (9774 8189) (9775 8175) (9776 1010) (9777 900) (9778 890) (9779 +8125) (9780 884) (9781 885) (9782 8174) (9783 8173) (9785 8142) (9786 8141) (9787 903) (9788 8143) ( +9789 8129) (9790 8127) (9791 8190) (9792 990) (9793 913) (9794 914) (9796 915) (9797 916) (9798 917) ( +9799 986) (9800 988) (9801 918) (9802 919) (9803 920) (9804 921) (9805 922) (9806 923) (9807 924) ( +9808 925) (9809 926) (9810 927) (9811 928) (9812 984) (9813 929) (9814 931) (9816 932) (9817 933) ( +9818 934) (9819 935) (9820 936) (9821 937) (9822 992) (9824 991) (9825 945) (9826 946) (9827 976) ( +9828 947) (9829 948) (9830 949) (9831 987) (9832 989) (9833 950) (9834 951) (9835 952) (9836 953) ( +9837 954) (9838 955) (9839 956) (9840 957) (9841 958) (9842 959) (9843 960) (9844 985) (9845 961) ( +9846 963) (9847 962) (9848 964) (9849 965) (9850 966) (9851 967) (9852 968) (9853 969) (9854 993) ( +9904 1001) (9905 1003) (9906 1005) (9907 1007) (9920 836) (9921 8158) (9922 8142) (9923 8159) (9924 +8143) (9925 769) (9926 768) (9927 834) (9928 8158) (9929 8157) (9930 8142) (9931 8141) (9932 776) ( +9933 901) (9934 8173) (9935 8129) (9936 902) (9937 904) (9938 905) (9939 906) (9940 908) (9941 910) ( +9942 911) (9943 938) (9944 939) (9945 (938 769)) (9946 (939 769)) (9948 994) (9949 996) (9950 998) ( +9952 979) (9953 980) (9968 940) (9969 941) (9970 942) (9971 943) (9972 972) (9973 973) (9974 974) ( +9975 970) (9976 971) (9977 912) (9978 944) (9979 1011) (9980 995) (9981 997) (9982 999) (10017 1040) ( +10018 1041) (10019 1042) (10020 1043) (10021 1044) (10022 1045) (10023 1025) (10024 1046) (10025 1047) + (10026 1048) (10027 1049) (10028 1050) (10029 1051) (10030 1052) (10031 1053) (10032 1054) (10033 +1055) (10034 1056) (10035 1057) (10036 1058) (10037 1059) (10038 1060) (10039 1061) (10040 1062) ( +10041 1063) (10042 1064) (10043 1065) (10044 1066) (10045 1067) (10046 1068) (10047 1069) (10048 1070) + (10049 1071) (10050 1168) (10051 1026) (10052 1027) (10053 1028) (10054 1029) (10055 1030) (10056 +1031) (10057 1032) (10058 1033) (10059 1034) (10060 1035) (10061 1036) (10062 1038) (10065 1072) ( +10066 1073) (10067 1074) (10068 1075) (10069 1076) (10070 1077) (10071 1105) (10072 1078) (10073 1079) + (10074 1080) (10075 1081) (10076 1082) (10077 1083) (10078 1084) (10079 1085) (10080 1086) (10081 +1087) (10082 1088) (10083 1089) (10084 1090) (10085 1091) (10086 1092) (10087 1093) (10088 1094) ( +10089 1095) (10090 1096) (10091 1097) (10092 1098) (10093 1099) (10094 1100) (10095 1101) (10096 1102) + (10097 1103) (10098 1169) (10099 1106) (10100 1107) (10101 1108) (10102 1109) (10103 1110) (10104 +1111) (10105 1112) (10106 1113) (10107 1114) (10108 1115) (10109 1116) (10110 1118) (10145 1039) ( +10146 1122) (10147 1138) (10148 1140) (10149 1130) (10150 1306) (10151 1308) (10152 1198) (10153 (1040 + 769)) (10154 1234) (10155 1232) (10156 1236) (10157 1170) (10158 1172) (10159 (1045 769)) (10160 1238 +) (10161 1244) (10162 1174) (10163 1246) (10164 1176) (10165 (1048 769)) (10166 1252) (10167 1250) ( +10168 1178) (10170 1180) (10171 1184) (10172 1182) (10173 1186) (10174 1188) (10175 (1054 769)) (10176 + 1254) (10178 1190) (10179 1194) (10181 1196) (10182 1204) (10183 (1059 769)) (10184 1264) (10185 1266 +) (10187 1262) (10188 1202) (10189 1276) (10190 1268) (10191 1216) (10193 1119) (10194 1123) (10195 +1139) (10196 1141) (10197 1131) (10198 1307) (10199 1309) (10200 1199) (10201 (1072 769)) (10202 1235) + (10203 1233) (10204 1237) (10205 1171) (10206 1173) (10207 (1077 769)) (10208 1239) (10209 1245) ( +10210 1175) (10211 1247) (10212 1177) (10213 (1080 769)) (10214 1253) (10215 1251) (10216 1179) (10218 + 1181) (10219 1185) (10220 1183) (10221 1187) (10222 1189) (10223 (1086 769)) (10224 1255) (10226 1191 +) (10227 1195) (10229 1197) (10230 1205) (10231 (1091 769)) (10232 1265) (10233 1267) (10235 1263) ( +10236 1203) (10237 1277) (10238 1269) (10273 9472) (10274 9474) (10275 9484) (10276 9488) (10277 9496) + (10278 9492) (10279 9500) (10280 9516) (10281 9508) (10282 9524) (10283 9532) (10284 9473) (10285 +9475) (10286 9487) (10287 9491) (10288 9499) (10289 9495) (10290 9507) (10291 9523) (10292 9515) ( +10293 9531) (10294 9547) (10295 9504) (10296 9519) (10297 9512) (10298 9527) (10299 9535) (10300 9501) + (10301 9520) (10302 9509) (10303 9528) (10304 9538) (10305 9550) (10306 9551) (10307 9545) (10308 +9543) (10309 9544) (10310 9546) (10311 9548) (10313 9486) (10314 9490) (10315 9498) (10316 9494) ( +10317 9485) (10318 9489) (10319 9497) (10320 9569) (10321 9570) (10322 9558) (10323 9557) (10324 9571) + (10325 9553) (10326 9559) (10327 9565) (10328 9564) (10329 9563) (10330 9566) (10331 9567) (10332 +9562) (10333 9556) (10334 9577) (10335 9574) (10336 9568) (10337 9552) (10338 9580) (10339 9575) ( +10340 9576) (10341 9572) (10342 9573) (10343 9561) (10344 9560) (10345 9554) (10346 9555) (10347 9579) + (10348 9578) (10363 9493) (10444 9502) (10445 9503) (10446 9505) (10447 9506) (10448 9476) (10449 +9477) (10450 9478) (10451 9479) (10452 9480) (10453 9481) (10454 9482) (10455 9483) (10456 9549) ( +10457 9581) (10458 9582) (10459 9583) (10460 9584) (10461 9585) (10462 9586) (10463 9608) (10530 5792) + (10532 5794) (10535 5798) (10539 5800) (10546 5809) (10549 5810) (10551 5812) (10554 5815) (10555 +5813) (10557 5817) (10559 5818) (10560 5819) (10564 5820) (10567 5822) (10570 5823) (10571 5825) ( +10572 5827) (10582 5831) (10585 5832) (10607 5839) (10608 5840) (10610 5842) (10615 5846) (10616 5847) + (10618 5848) (10620 5849) (10622 5850) (10623 5852) (10658 5853) (10659 5855) (10661 5805) (10662 +5806) (10663 5854) (10664 5841) (10665 5829) (10666 5807) (10667 5801) (10669 5873) (10671 5802) ( +10673 5803) (10674 5796) (10677 5795) (10678 5856) (10680 5857) (10721 66352) (10722 66353) (10723 +66354) (10724 66355) (10725 66356) (10726 66357) (10727 66358) (10728 66359) (10729 66360) (10730 ( +66361 776)) (10731 66361) (10732 66362) (10733 66363) (10734 66364) (10735 66365) (10736 66366) (10737 + 66367) (10738 66368) (10739 66369) (10740 66370) (10741 66371) (10742 66372) (10743 66373) (10744 +66374) (10745 66375) (10746 66376) (10747 66377) (10748 66378) (10785 1206) (10786 1227) (10787 1208) +(10788 (1069 769)) (10790 (1070 769)) (10792 (1071 769)) (10794 (1066 769)) (10795 1272) (10796 (1067 +769)) (10797 (769 1028)) (10798 1240) (10799 1212) (10800 1214) (10801 1192) (10802 (1198 769)) (10803 + 1200) (10807 (1025 769)) (10808 1242) (10809 1248) (10810 1219) (10811 1258) (10816 1170) (10817 1256 +) (10818 1217) (10819 1210) (10822 1223) (10827 1142) (10833 1207) (10834 1228) (10835 1209) (10836 ( +1101 769)) (10838 (1102 769)) (10840 (1103 769)) (10842 (1098 769)) (10843 1273) (10844 (1099 769)) ( +10845 (1108 769)) (10846 1241) (10847 1213) (10848 1215) (10849 1193) (10850 (1199 769)) (10851 1201) +(10855 (1105 769)) (10856 1243) (10857 1249) (10858 1220) (10859 1259) (10864 1171) (10865 1257) ( +10866 1218) (10867 1211) (10870 1224) (10875 1143) (10914 1146) (10920 1120) (10924 1124) (10927 1126) + (10929 1128) (10930 1132) (10931 1134) (10932 1136) (10934 1152) (10943 1150) (10944 1148) (10951 +1144) (10952 1156) (10957 1154) (10962 1147) (10967 1145) (10968 1121) (10972 1125) (10975 1127) ( +10977 1129) (10978 1133) (10979 1135) (10980 1137) (10982 1153) (10991 1151) (10992 1149) (10999 1155) + (11809 9472) (11810 9135) (11811 9473) (11827 65079) (11828 65080) (12068 65075) (12070 65073) (12075 + 8942) (12076 65072) (12077 65077) (12078 65078) (12079 65081) (12080 65082) (12081 65079) (12082 +65080) (12089 65089) (12090 65090) (12091 65091) (12092 65092) (12093 65083) (12094 65084) (12096 +12353) (12097 12357) (12098 12357) (12099 12359) (12100 12361) (12101 12387) (12102 12419) (12103 +12421) (12104 12423) (12105 12430) (12106 12449) (12107 12451) (12108 12453) (12109 12455) (12110 +12457) (12111 12483) (12112 12515) (12113 12517) (12114 12519) (12115 12526) (12116 12533) (12117 +12534) (12130 12307) (12193 65087) (12194 65088) (12216 65076) (12224 12832) (12225 12833) (12226 +12834) (12227 12835) (12228 12836) (12229 12837) (12230 12838) (12231 12839) (12232 12840) (12233 +12841) (12257 12337) (12258 12338) (12264 65085) (12265 65086) (12273 12339) (12274 12340) (12275 +12341) (12321 20124) (12322 21782) (12323 23043) (12324 38463) (12325 21696) (12326 24859) (12327 +25384) (12328 23030) (12329 36898) (12330 33909) (12331 33564) (12332 31312) (12333 24746) (12334 +25569) (12335 28197) (12336 26093) (12337 33894) (12338 33446) (12339 39925) (12340 26771) (12341 +22311) (12342 26017) (12343 25201) (12344 23451) (12345 22992) (12346 34427) (12347 39156) (12348 +32098) (12349 32190) (12350 39822) (12351 25110) (12352 31903) (12353 34999) (12354 23433) (12355 +24245) (12356 25353) (12357 26263) (12358 26696) (12359 38343) (12360 38797) (12361 26447) (12362 +20197) (12363 20234) (12364 20301) (12365 20381) (12366 20553) (12367 22258) (12368 22839) (12369 +22996) (12370 23041) (12371 23561) (12372 24799) (12373 24847) (12374 24944) (12375 26131) (12376 +26885) (12377 28858) (12378 30031) (12379 30064) (12380 31227) (12381 32173) (12382 32239) (12383 +32963) (12384 33806) (12385 34915) (12386 35586) (12387 36949) (12388 36986) (12389 21307) (12390 +20117) (12391 20133) (12392 22495) (12393 32946) (12394 37057) (12395 30959) (12396 19968) (12397 +22769) (12398 28322) (12399 36920) (12400 31282) (12401 33576) (12402 33419) (12403 39983) (12404 +20801) (12405 21360) (12406 21693) (12407 21729) (12408 22240) (12409 23035) (12410 24341) (12411 +39154) (12412 28139) (12413 32996) (12414 34093) (12577 38498) (12578 38512) (12579 38560) (12580 +38907) (12581 21515) (12582 21491) (12583 23431) (12584 28879) (12585 32701) (12586 36802) (12587 +38632) (12588 21359) (12589 40284) (12590 31418) (12591 19985) (12592 30867) (12593 33276) (12594 +28198) (12595 22040) (12596 21764) (12597 27421) (12598 34074) (12599 39995) (12600 23013) (12601 +21417) (12602 28006) (12603 29916) (12604 38287) (12605 22082) (12606 20113) (12607 36939) (12608 +38642) (12609 33615) (12610 39180) (12611 21473) (12612 21942) (12613 23344) (12614 24433) (12615 +26144) (12616 26355) (12617 26628) (12618 27704) (12619 27891) (12620 27945) (12621 29787) (12622 +30408) (12623 31310) (12624 38964) (12625 33521) (12626 34907) (12627 35424) (12628 37613) (12629 +28082) (12630 30123) (12631 30410) (12632 39365) (12633 24742) (12634 35585) (12635 36234) (12636 +38322) (12637 27022) (12638 21421) (12639 20870) (12640 22290) (12641 22576) (12642 22852) (12643 +23476) (12644 24310) (12645 24616) (12646 25513) (12647 25588) (12648 27839) (12649 28436) (12650 +28814) (12651 28948) (12652 29017) (12653 29141) (12654 29503) (12655 32257) (12656 33398) (12657 +33489) (12658 34199) (12659 36960) (12660 37467) (12661 40219) (12662 22633) (12663 26044) (12664 +27738) (12665 29989) (12666 20985) (12667 22830) (12668 22885) (12669 24448) (12670 24540) (12833 +25276) (12834 26106) (12835 27178) (12836 27431) (12837 27572) (12838 29579) (12839 32705) (12840 +35158) (12841 40236) (12842 40206) (12843 40644) (12844 23713) (12845 27798) (12846 33659) (12847 +20740) (12848 23627) (12849 25014) (12850 33222) (12851 26742) (12852 29281) (12853 20057) (12854 +20474) (12855 21368) (12856 24681) (12857 28201) (12858 31311) (12859 38899) (12860 19979) (12861 +21270) (12862 20206) (12863 20309) (12864 20285) (12865 20385) (12866 20339) (12867 21152) (12868 +21487) (12869 22025) (12870 22799) (12871 23233) (12872 23478) (12873 23521) (12874 31185) (12875 +26247) (12876 26524) (12877 26550) (12878 27468) (12879 27827) (12880 28779) (12881 29634) (12882 +31117) (12883 31166) (12884 31292) (12885 31623) (12886 33457) (12887 33499) (12888 33540) (12889 +33655) (12890 33775) (12891 33747) (12892 34662) (12893 35506) (12894 22057) (12895 36008) (12896 +36838) (12897 36942) (12898 38686) (12899 34442) (12900 20420) (12901 23784) (12902 25105) (12903 +29273) (12904 30011) (12905 33253) (12906 33469) (12907 34558) (12908 36032) (12909 38597) (12910 +39187) (12911 39381) (12912 20171) (12913 20250) (12914 35299) (12915 22238) (12916 22602) (12917 +22730) (12918 24315) (12919 24555) (12920 24618) (12921 24724) (12922 24674) (12923 25040) (12924 +25106) (12925 25296) (12926 25913) (13089 39745) (13090 26214) (13091 26800) (13092 28023) (13093 +28784) (13094 30028) (13095 30342) (13096 32117) (13097 33445) (13098 34809) (13099 38283) (13100 +38542) (13101 35997) (13102 20977) (13103 21182) (13104 22806) (13105 21683) (13106 23475) (13107 +23830) (13108 24936) (13109 27010) (13110 28079) (13111 30861) (13112 33995) (13113 34903) (13114 +35442) (13115 37799) (13116 39608) (13117 28012) (13118 39336) (13119 34521) (13120 22435) (13121 +26623) (13122 34510) (13123 37390) (13124 21123) (13125 22151) (13126 21508) (13127 24275) (13128 +25313) (13129 25785) (13130 26684) (13131 26680) (13132 27579) (13133 29554) (13134 30906) (13135 +31339) (13136 35226) (13137 35282) (13138 36203) (13139 36611) (13140 37101) (13141 38307) (13142 +38548) (13143 38761) (13144 23398) (13145 23731) (13146 27005) (13147 38989) (13148 38990) (13149 +25499) (13150 31520) (13151 27179) (13152 27263) (13153 26806) (13154 39949) (13155 28511) (13156 +21106) (13157 21917) (13158 24688) (13159 25324) (13160 27963) (13161 28167) (13162 28369) (13163 +33883) (13164 35088) (13165 36676) (13166 19988) (13167 39993) (13168 21494) (13169 26907) (13170 +27194) (13171 38788) (13172 26666) (13173 20828) (13174 31427) (13175 33970) (13176 37340) (13177 +37772) (13178 22107) (13179 40232) (13180 26658) (13181 33541) (13182 33841) (13345 31909) (13346 +21000) (13347 33477) (13348 29926) (13349 20094) (13350 20355) (13351 20896) (13352 23506) (13353 +21002) (13354 21208) (13355 21223) (13356 24059) (13357 21914) (13358 22570) (13359 23014) (13360 +23436) (13361 23448) (13362 23515) (13363 24178) (13364 24185) (13365 24739) (13366 24863) (13367 +24931) (13368 25022) (13369 25563) (13370 25954) (13371 26577) (13372 26707) (13373 26874) (13374 +27454) (13375 27475) (13376 27735) (13377 28450) (13378 28567) (13379 28485) (13380 29872) (13381 +29976) (13382 30435) (13383 30475) (13384 31487) (13385 31649) (13386 31777) (13387 32233) (13388 +32566) (13389 32752) (13390 32925) (13391 33382) (13392 33694) (13393 35251) (13394 35532) (13395 +36011) (13396 36996) (13397 37969) (13398 38291) (13399 38289) (13400 38306) (13401 38501) (13402 +38867) (13403 39208) (13404 33304) (13405 20024) (13406 21547) (13407 23736) (13408 24012) (13409 +29609) (13410 30284) (13411 30524) (13412 23721) (13413 32747) (13414 36107) (13415 38593) (13416 +38929) (13417 38996) (13418 39000) (13419 20225) (13420 20238) (13421 21361) (13422 21916) (13423 +22120) (13424 22522) (13425 22855) (13426 23305) (13427 23492) (13428 23696) (13429 24076) (13430 +24190) (13431 24524) (13432 25582) (13433 26426) (13434 26071) (13435 26082) (13436 26399) (13437 +26827) (13438 26820) (13601 27231) (13602 24112) (13603 27589) (13604 27671) (13605 27773) (13606 +30079) (13607 31048) (13608 23395) (13609 31232) (13610 32000) (13611 24509) (13612 35215) (13613 +35352) (13614 36020) (13615 36215) (13616 36556) (13617 36637) (13618 39138) (13619 39438) (13620 +39740) (13621 20096) (13622 20605) (13623 20736) (13624 22931) (13625 23452) (13626 25135) (13627 +25216) (13628 25836) (13629 27450) (13630 29344) (13631 30097) (13632 31047) (13633 32681) (13634 +34811) (13635 35516) (13636 35696) (13637 25516) (13638 33738) (13639 38816) (13640 21513) (13641 +21507) (13642 21931) (13643 26708) (13644 27224) (13645 35440) (13646 30759) (13647 26485) (13648 +40653) (13649 21364) (13650 23458) (13651 33050) (13652 34384) (13653 36870) (13654 19992) (13655 +20037) (13656 20167) (13657 20241) (13658 21450) (13659 21560) (13660 23470) (13661 24339) (13662 +24613) (13663 25937) (13664 26429) (13665 27714) (13666 27762) (13667 27875) (13668 28792) (13669 +29699) (13670 31350) (13671 31406) (13672 31496) (13673 32026) (13674 31998) (13675 32102) (13676 +26087) (13677 29275) (13678 21435) (13679 23621) (13680 24040) (13681 25298) (13682 25312) (13683 +25369) (13684 28192) (13685 34394) (13686 35377) (13687 36317) (13688 37624) (13689 28417) (13690 +31142) (13691 39770) (13692 20136) (13693 20139) (13694 20140) (13857 20379) (13858 20384) (13859 +20689) (13860 20807) (13861 31478) (13862 20849) (13863 20982) (13864 21332) (13865 21281) (13866 +21375) (13867 21483) (13868 21932) (13869 22659) (13870 23777) (13871 24375) (13872 24394) (13873 +24623) (13874 24656) (13875 24685) (13876 25375) (13877 25945) (13878 27211) (13879 27841) (13880 +29378) (13881 29421) (13882 30703) (13883 33016) (13884 33029) (13885 33288) (13886 34126) (13887 +37111) (13888 37857) (13889 38911) (13890 39255) (13891 39514) (13892 20208) (13893 20957) (13894 +23597) (13895 26241) (13896 26989) (13897 23616) (13898 26354) (13899 26997) (13900 29577) (13901 +26704) (13902 31873) (13903 20677) (13904 21220) (13905 22343) (13906 24062) (13907 37670) (13908 +26020) (13909 27427) (13910 27453) (13911 29748) (13912 31105) (13913 31165) (13914 31563) (13915 +32202) (13916 33465) (13917 33740) (13918 34943) (13919 35167) (13920 35641) (13921 36817) (13922 +37329) (13923 21535) (13924 37504) (13925 20061) (13926 20534) (13927 21477) (13928 21306) (13929 +29399) (13930 29590) (13931 30697) (13932 33510) (13933 36527) (13934 39366) (13935 39368) (13936 +39378) (13937 20855) (13938 24858) (13939 34398) (13940 21936) (13941 31354) (13942 20598) (13943 +23507) (13944 36935) (13945 38533) (13946 20018) (13947 27355) (13948 37351) (13949 23633) (13950 +23624) (14113 25496) (14114 31391) (14115 27795) (14116 38772) (14117 36705) (14118 31402) (14119 +29066) (14120 38536) (14121 31874) (14122 26647) (14123 32368) (14124 26705) (14125 37740) (14126 +21234) (14127 21531) (14128 34219) (14129 35347) (14130 32676) (14131 36557) (14132 37089) (14133 +21350) (14134 34952) (14135 31041) (14136 20418) (14137 20670) (14138 21009) (14139 20804) (14140 +21843) (14141 22317) (14142 29674) (14143 22411) (14144 22865) (14145 24418) (14146 24452) (14147 +24693) (14148 24950) (14149 24935) (14150 25001) (14151 25522) (14152 25658) (14153 25964) (14154 +26223) (14155 26690) (14156 28179) (14157 30054) (14158 31293) (14159 31995) (14160 32076) (14161 +32153) (14162 32331) (14163 32619) (14164 33550) (14165 33610) (14166 34509) (14167 35336) (14168 +35427) (14169 35686) (14170 36605) (14171 38938) (14172 40335) (14173 33464) (14174 36814) (14175 +39912) (14176 21127) (14177 25119) (14178 25731) (14179 28608) (14180 38553) (14181 26689) (14182 +20625) (14183 27424) (14184 27770) (14185 28500) (14186 31348) (14187 32080) (14188 34880) (14189 +35363) (14190 26376) (14191 20214) (14192 20537) (14193 20518) (14194 20581) (14195 20860) (14196 +21048) (14197 21091) (14198 21927) (14199 22287) (14200 22533) (14201 23244) (14202 24314) (14203 +25010) (14204 25080) (14205 25331) (14206 25458) (14369 26908) (14370 27177) (14371 29309) (14372 +29356) (14373 29486) (14374 30740) (14375 30831) (14376 32121) (14377 30476) (14378 32937) (14379 +35211) (14380 35609) (14381 36066) (14382 36562) (14383 36963) (14384 37749) (14385 38522) (14386 +38997) (14387 39443) (14388 40568) (14389 20803) (14390 21407) (14391 21427) (14392 24187) (14393 +24358) (14394 28187) (14395 28304) (14396 29572) (14397 29694) (14398 32067) (14399 33335) (14400 +35328) (14401 35578) (14402 38480) (14403 20046) (14404 20491) (14405 21476) (14406 21628) (14407 +22266) (14408 22993) (14409 23396) (14410 24049) (14411 24235) (14412 24359) (14413 25144) (14414 +25925) (14415 26543) (14416 28246) (14417 29392) (14418 31946) (14419 34996) (14420 32929) (14421 +32993) (14422 33776) (14423 34382) (14424 35463) (14425 36328) (14426 37431) (14427 38599) (14428 +39015) (14429 40723) (14430 20116) (14431 20114) (14432 20237) (14433 21320) (14434 21577) (14435 +21566) (14436 23087) (14437 24460) (14438 24481) (14439 24735) (14440 26791) (14441 27278) (14442 +29786) (14443 30849) (14444 35486) (14445 35492) (14446 35703) (14447 37264) (14448 20062) (14449 +39881) (14450 20132) (14451 20348) (14452 20399) (14453 20505) (14454 20502) (14455 20809) (14456 +20844) (14457 21151) (14458 21177) (14459 21246) (14460 21402) (14461 21475) (14462 21521) (14625 +21518) (14626 21897) (14627 22353) (14628 22434) (14629 22909) (14630 23380) (14631 23389) (14632 +23439) (14633 24037) (14634 24039) (14635 24055) (14636 24184) (14637 24195) (14638 24218) (14639 +24247) (14640 24344) (14641 24658) (14642 24908) (14643 25239) (14644 25304) (14645 25511) (14646 +25915) (14647 26114) (14648 26179) (14649 26356) (14650 26477) (14651 26657) (14652 26775) (14653 +27083) (14654 27743) (14655 27946) (14656 28009) (14657 28207) (14658 28317) (14659 30002) (14660 +30343) (14661 30828) (14662 31295) (14663 31968) (14664 32005) (14665 32024) (14666 32094) (14667 +32177) (14668 32789) (14669 32771) (14670 32943) (14671 32945) (14672 33108) (14673 33167) (14674 +33322) (14675 33618) (14676 34892) (14677 34913) (14678 35611) (14679 36002) (14680 36092) (14681 +37066) (14682 37237) (14683 37489) (14684 30783) (14685 37628) (14686 38308) (14687 38477) (14688 +38917) (14689 39321) (14690 39640) (14691 40251) (14692 21083) (14693 21163) (14694 21495) (14695 +21512) (14696 22741) (14697 25335) (14698 28640) (14699 35946) (14700 36703) (14701 40633) (14702 +20811) (14703 21051) (14704 21578) (14705 22269) (14706 31296) (14707 37239) (14708 40288) (14709 +40658) (14710 29508) (14711 28425) (14712 33136) (14713 29969) (14714 24573) (14715 24794) (14716 +39592) (14717 29403) (14718 36796) (14881 27492) (14882 38915) (14883 20170) (14884 22256) (14885 +22372) (14886 22718) (14887 23130) (14888 24680) (14889 25031) (14890 26127) (14891 26118) (14892 +26681) (14893 26801) (14894 28151) (14895 30165) (14896 32058) (14897 33390) (14898 39746) (14899 +20123) (14900 20304) (14901 21449) (14902 21766) (14903 23919) (14904 24038) (14905 24046) (14906 +26619) (14907 27801) (14908 29811) (14909 30722) (14910 35408) (14911 37782) (14912 35039) (14913 +22352) (14914 24231) (14915 25387) (14916 20661) (14917 20652) (14918 20877) (14919 26368) (14920 +21705) (14921 22622) (14922 22971) (14923 23472) (14924 24425) (14925 25165) (14926 25505) (14927 +26685) (14928 27507) (14929 28168) (14930 28797) (14931 37319) (14932 29312) (14933 30741) (14934 +30758) (14935 31085) (14936 25998) (14937 32048) (14938 33756) (14939 35009) (14940 36617) (14941 +38555) (14942 21092) (14943 22312) (14944 26448) (14945 32618) (14946 36001) (14947 20916) (14948 +22338) (14949 38442) (14950 22586) (14951 27018) (14952 32948) (14953 21682) (14954 23822) (14955 +22524) (14956 30869) (14957 40442) (14958 20316) (14959 21066) (14960 21643) (14961 25662) (14962 +26152) (14963 26388) (14964 26613) (14965 31364) (14966 31574) (14967 32034) (14968 37679) (14969 +26716) (14970 39853) (14971 31545) (14972 21273) (14973 20874) (14974 21047) (15137 23519) (15138 +25334) (15139 25774) (15140 25830) (15141 26413) (15142 27578) (15143 34217) (15144 38609) (15145 +30352) (15146 39894) (15147 25420) (15148 37638) (15149 39851) (15150 30399) (15151 26194) (15152 +19977) (15153 20632) (15154 21442) (15155 23665) (15156 24808) (15157 25746) (15158 25955) (15159 +26719) (15160 29158) (15161 29642) (15162 29987) (15163 31639) (15164 32386) (15165 34453) (15166 +35715) (15167 36059) (15168 37240) (15169 39184) (15170 26028) (15171 26283) (15172 27531) (15173 +20181) (15174 20180) (15175 20282) (15176 20351) (15177 21050) (15178 21496) (15179 21490) (15180 +21987) (15181 22235) (15182 22763) (15183 22987) (15184 22985) (15185 23039) (15186 23376) (15187 +23629) (15188 24066) (15189 24107) (15190 24535) (15191 24605) (15192 25351) (15193 25903) (15194 +23388) (15195 26031) (15196 26045) (15197 26088) (15198 26525) (15199 27490) (15200 27515) (15201 +27663) (15202 29509) (15203 31049) (15204 31169) (15205 31992) (15206 32025) (15207 32043) (15208 +32930) (15209 33026) (15210 33267) (15211 35222) (15212 35422) (15213 35433) (15214 35430) (15215 +35468) (15216 35566) (15217 36039) (15218 36060) (15219 38604) (15220 39164) (15221 27503) (15222 +20107) (15223 20284) (15224 20365) (15225 20816) (15226 23383) (15227 23546) (15228 24904) (15229 +25345) (15230 26178) (15393 27425) (15394 28363) (15395 27835) (15396 29246) (15397 29885) (15398 +30164) (15399 30913) (15400 31034) (15401 32780) (15402 32819) (15403 33258) (15404 33940) (15405 +36766) (15406 27728) (15407 40575) (15408 24335) (15409 35672) (15410 40235) (15411 31482) (15412 +36600) (15413 23437) (15414 38635) (15415 19971) (15416 21489) (15417 22519) (15418 22833) (15419 +23241) (15420 23460) (15421 24713) (15422 28287) (15423 28422) (15424 30142) (15425 36074) (15426 +23455) (15427 34048) (15428 31712) (15429 20594) (15430 26612) (15431 33437) (15432 23649) (15433 +34122) (15434 32286) (15435 33294) (15436 20889) (15437 23556) (15438 25448) (15439 36198) (15440 +26012) (15441 29038) (15442 31038) (15443 32023) (15444 32773) (15445 35613) (15446 36554) (15447 +36974) (15448 34503) (15449 37034) (15450 20511) (15451 21242) (15452 23610) (15453 26451) (15454 +28796) (15455 29237) (15456 37196) (15457 37320) (15458 37675) (15459 33509) (15460 23490) (15461 +24369) (15462 24825) (15463 20027) (15464 21462) (15465 23432) (15466 25163) (15467 26417) (15468 +27530) (15469 29417) (15470 29664) (15471 31278) (15472 33131) (15473 36259) (15474 37202) (15475 +39318) (15476 20754) (15477 21463) (15478 21610) (15479 23551) (15480 25480) (15481 27193) (15482 +32172) (15483 38656) (15484 22234) (15485 21454) (15486 21608) (15649 23447) (15650 23601) (15651 +24030) (15652 20462) (15653 24833) (15654 25342) (15655 27954) (15656 31168) (15657 31179) (15658 +32066) (15659 32333) (15660 32722) (15661 33261) (15662 33311) (15663 33936) (15664 34886) (15665 +35186) (15666 35728) (15667 36468) (15668 36655) (15669 36913) (15670 37195) (15671 37228) (15672 +38598) (15673 37276) (15674 20160) (15675 20303) (15676 20805) (15677 21313) (15678 24467) (15679 +25102) (15680 26580) (15681 27713) (15682 28171) (15683 29539) (15684 32294) (15685 37325) (15686 +37507) (15687 21460) (15688 22809) (15689 23487) (15690 28113) (15691 31069) (15692 32302) (15693 +31899) (15694 22654) (15695 29087) (15696 20986) (15697 34899) (15698 36848) (15699 20426) (15700 +23803) (15701 26149) (15702 30636) (15703 31459) (15704 33308) (15705 39423) (15706 20934) (15707 +24490) (15708 26092) (15709 26991) (15710 27529) (15711 28147) (15712 28310) (15713 28516) (15714 +30462) (15715 32020) (15716 24033) (15717 36981) (15718 37255) (15719 38918) (15720 20966) (15721 +21021) (15722 25152) (15723 26257) (15724 26329) (15725 28186) (15726 24246) (15727 32210) (15728 +32626) (15729 26360) (15730 34223) (15731 34295) (15732 35576) (15733 21161) (15734 21465) (15735 +22899) (15736 24207) (15737 24464) (15738 24661) (15739 37604) (15740 38500) (15741 20663) (15742 +20767) (15905 21213) (15906 21280) (15907 21319) (15908 21484) (15909 21736) (15910 21830) (15911 +21809) (15912 22039) (15913 22888) (15914 22974) (15915 23100) (15916 23477) (15917 23558) (15918 +23567) (15919 23569) (15920 23578) (15921 24196) (15922 24202) (15923 24288) (15924 24432) (15925 +25215) (15926 25220) (15927 25307) (15928 25484) (15929 25463) (15930 26119) (15931 26124) (15932 +26157) (15933 26230) (15934 26494) (15935 26786) (15936 27167) (15937 27189) (15938 27836) (15939 +28040) (15940 28169) (15941 28248) (15942 28988) (15943 28966) (15944 29031) (15945 30151) (15946 +30465) (15947 30813) (15948 30977) (15949 31077) (15950 31216) (15951 31456) (15952 31505) (15953 +31911) (15954 32057) (15955 32918) (15956 33750) (15957 33931) (15958 34121) (15959 34909) (15960 +35059) (15961 35359) (15962 35388) (15963 35412) (15964 35443) (15965 35937) (15966 36062) (15967 +37284) (15968 37478) (15969 37758) (15970 37912) (15971 38556) (15972 38808) (15973 19978) (15974 +19976) (15975 19998) (15976 20055) (15977 20887) (15978 21104) (15979 22478) (15980 22580) (15981 +22732) (15982 23330) (15983 24120) (15984 24773) (15985 25854) (15986 26465) (15987 26454) (15988 +27972) (15989 29366) (15990 30067) (15991 31331) (15992 33976) (15993 35698) (15994 37304) (15995 +37664) (15996 22065) (15997 22516) (15998 39166) (16161 25325) (16162 26893) (16163 27542) (16164 +29165) (16165 32340) (16166 32887) (16167 33394) (16168 35302) (16169 39135) (16170 34645) (16171 +36785) (16172 23611) (16173 20280) (16174 20449) (16175 20405) (16176 21767) (16177 23072) (16178 +23517) (16179 23529) (16180 24515) (16181 24910) (16182 25391) (16183 26032) (16184 26187) (16185 +26862) (16186 27035) (16187 28024) (16188 28145) (16189 30003) (16190 30137) (16191 30495) (16192 +31070) (16193 31206) (16194 32051) (16195 33251) (16196 33455) (16197 34218) (16198 35242) (16199 +35386) (16200 36523) (16201 36763) (16202 36914) (16203 37341) (16204 38663) (16205 20154) (16206 +20161) (16207 20995) (16208 22645) (16209 22764) (16210 23563) (16211 29978) (16212 23613) (16213 +33102) (16214 35338) (16215 36805) (16216 38499) (16217 38765) (16218 31525) (16219 35535) (16220 +38920) (16221 37218) (16222 22259) (16223 21416) (16224 36887) (16225 21561) (16226 22402) (16227 +24101) (16228 25512) (16229 27700) (16230 28810) (16231 30561) (16232 31883) (16233 32736) (16234 +34928) (16235 36930) (16236 37204) (16237 37648) (16238 37656) (16239 38543) (16240 29790) (16241 +39620) (16242 23815) (16243 23913) (16244 25968) (16245 26530) (16246 36264) (16247 38619) (16248 +25454) (16249 26441) (16250 26905) (16251 33733) (16252 38935) (16253 38592) (16254 35070) (16417 +28548) (16418 25722) (16419 23544) (16420 19990) (16421 28716) (16422 30045) (16423 26159) (16424 +20932) (16425 21046) (16426 21218) (16427 22995) (16428 24449) (16429 24615) (16430 25104) (16431 +25919) (16432 25972) (16433 26143) (16434 26228) (16435 26866) (16436 26646) (16437 27491) (16438 +28165) (16439 29298) (16440 29983) (16441 30427) (16442 31934) (16443 32854) (16444 22768) (16445 +35069) (16446 35199) (16447 35488) (16448 35475) (16449 35531) (16450 36893) (16451 37266) (16452 +38738) (16453 38745) (16454 25993) (16455 31246) (16456 33030) (16457 38587) (16458 24109) (16459 +24796) (16460 25114) (16461 26021) (16462 26132) (16463 26512) (16464 30707) (16465 31309) (16466 +31821) (16467 32318) (16468 33034) (16469 36012) (16470 36196) (16471 36321) (16472 36447) (16473 +30889) (16474 20999) (16475 25305) (16476 25509) (16477 25666) (16478 25240) (16479 35373) (16480 +31363) (16481 31680) (16482 35500) (16483 38634) (16484 32118) (16485 33292) (16486 34633) (16487 +20185) (16488 20808) (16489 21315) (16490 21344) (16491 23459) (16492 23554) (16493 23574) (16494 +24029) (16495 25126) (16496 25159) (16497 25776) (16498 26643) (16499 26676) (16500 27849) (16501 +27973) (16502 27927) (16503 26579) (16504 28508) (16505 29006) (16506 29053) (16507 26059) (16508 +31359) (16509 31661) (16510 32218) (16673 32330) (16674 32680) (16675 33146) (16676 33307) (16677 +33337) (16678 34214) (16679 35438) (16680 36046) (16681 36341) (16682 36984) (16683 36983) (16684 +37549) (16685 37521) (16686 38275) (16687 39854) (16688 21069) (16689 21892) (16690 28472) (16691 +28982) (16692 20840) (16693 31109) (16694 32341) (16695 33203) (16696 31950) (16697 22092) (16698 +22609) (16699 23720) (16700 25514) (16701 26366) (16702 26365) (16703 26970) (16704 29401) (16705 +30095) (16706 30094) (16707 30990) (16708 31062) (16709 31199) (16710 31895) (16711 32032) (16712 +32068) (16713 34311) (16714 35380) (16715 38459) (16716 36961) (16717 40736) (16718 20711) (16719 +21109) (16720 21452) (16721 21474) (16722 20489) (16723 21930) (16724 22766) (16725 22863) (16726 +29245) (16727 23435) (16728 23652) (16729 21277) (16730 24803) (16731 24819) (16732 25436) (16733 +25475) (16734 25407) (16735 25531) (16736 25805) (16737 26089) (16738 26361) (16739 24035) (16740 +27085) (16741 27133) (16742 28437) (16743 29157) (16744 20105) (16745 30185) (16746 30456) (16747 +31379) (16748 31967) (16749 32207) (16750 32156) (16751 32865) (16752 33609) (16753 33624) (16754 +33900) (16755 33980) (16756 34299) (16757 35013) (16758 36208) (16759 36865) (16760 36973) (16761 +37783) (16762 38684) (16763 39442) (16764 20687) (16765 22679) (16766 24974) (16929 33235) (16930 +34101) (16931 36104) (16932 36896) (16933 20419) (16934 20596) (16935 21063) (16936 21363) (16937 +24687) (16938 25417) (16939 26463) (16940 28204) (16941 36275) (16942 36895) (16943 20439) (16944 +23646) (16945 36042) (16946 26063) (16947 32154) (16948 21330) (16949 34966) (16950 20854) (16951 +25539) (16952 23384) (16953 23403) (16954 23562) (16955 25613) (16956 26449) (16957 36956) (16958 +20182) (16959 22810) (16960 22826) (16961 27760) (16962 35409) (16963 21822) (16964 22549) (16965 +22949) (16966 24816) (16967 25171) (16968 26561) (16969 33333) (16970 26965) (16971 38464) (16972 +39364) (16973 39464) (16974 20307) (16975 22534) (16976 23550) (16977 32784) (16978 23729) (16979 +24111) (16980 24453) (16981 24608) (16982 24907) (16983 25140) (16984 26367) (16985 27888) (16986 +28382) (16987 32974) (16988 33151) (16989 33492) (16990 34955) (16991 36024) (16992 36864) (16993 +36910) (16994 38538) (16995 40667) (16996 39899) (16997 20195) (16998 21488) (16999 22823) (17000 +31532) (17001 37261) (17002 38988) (17003 40441) (17004 28381) (17005 28711) (17006 21331) (17007 +21828) (17008 23429) (17009 25176) (17010 25246) (17011 25299) (17012 27810) (17013 28655) (17014 +29730) (17015 35351) (17016 37944) (17017 28609) (17018 35582) (17019 33592) (17020 20967) (17021 +34552) (17022 21482) (17185 21481) (17186 20294) (17187 36948) (17188 36784) (17189 22890) (17190 +33073) (17191 24061) (17192 31466) (17193 36799) (17194 26842) (17195 35895) (17196 29432) (17197 +40008) (17198 27197) (17199 35504) (17200 20025) (17201 21336) (17202 22022) (17203 22374) (17204 +25285) (17205 25506) (17206 26086) (17207 27470) (17208 28129) (17209 28251) (17210 28845) (17211 +30701) (17212 31471) (17213 31658) (17214 32187) (17215 32829) (17216 32966) (17217 34507) (17218 +35477) (17219 37723) (17220 22243) (17221 22727) (17222 24382) (17223 26029) (17224 26262) (17225 +27264) (17226 27573) (17227 30007) (17228 35527) (17229 20516) (17230 30693) (17231 22320) (17232 +24347) (17233 24677) (17234 26234) (17235 27744) (17236 30196) (17237 31258) (17238 32622) (17239 +33268) (17240 34584) (17241 36933) (17242 39347) (17243 31689) (17244 30044) (17245 31481) (17246 +31569) (17247 33988) (17248 36880) (17249 31209) (17250 31378) (17251 33590) (17252 23265) (17253 +30528) (17254 20013) (17255 20210) (17256 23449) (17257 24544) (17258 25277) (17259 26172) (17260 +26609) (17261 27880) (17262 34411) (17263 34935) (17264 35387) (17265 37198) (17266 37619) (17267 +39376) (17268 27159) (17269 28710) (17270 29482) (17271 33511) (17272 33879) (17273 36015) (17274 +19969) (17275 20806) (17276 20939) (17277 21899) (17278 23541) (17441 24086) (17442 24115) (17443 +24193) (17444 24340) (17445 24373) (17446 24427) (17447 24500) (17448 25074) (17449 25361) (17450 +26274) (17451 26397) (17452 28526) (17453 29266) (17454 30010) (17455 30522) (17456 32884) (17457 +33081) (17458 33144) (17459 34678) (17460 35519) (17461 35548) (17462 36229) (17463 36339) (17464 +37530) (17465 38263) (17466 38914) (17467 40165) (17468 21189) (17469 25431) (17470 30452) (17471 +26389) (17472 27784) (17473 29645) (17474 36035) (17475 37806) (17476 38515) (17477 27941) (17478 +22684) (17479 26894) (17480 27084) (17481 36861) (17482 37786) (17483 30171) (17484 36890) (17485 +22618) (17486 26626) (17487 25524) (17488 27131) (17489 20291) (17490 28460) (17491 26584) (17492 +36795) (17493 34086) (17494 32180) (17495 37716) (17496 26943) (17497 28528) (17498 22378) (17499 +22775) (17500 23340) (17501 32044) (17502 29226) (17503 21514) (17504 37347) (17505 40372) (17506 +20141) (17507 20302) (17508 20572) (17509 20597) (17510 21059) (17511 35998) (17512 21576) (17513 +22564) (17514 23450) (17515 24093) (17516 24213) (17517 24237) (17518 24311) (17519 24351) (17520 +24716) (17521 25269) (17522 25402) (17523 25552) (17524 26799) (17525 27712) (17526 30855) (17527 +31118) (17528 31243) (17529 32224) (17530 33351) (17531 35330) (17532 35558) (17533 36420) (17534 +36883) (17697 37048) (17698 37165) (17699 37336) (17700 40718) (17701 27877) (17702 25688) (17703 +25826) (17704 25973) (17705 28404) (17706 30340) (17707 31515) (17708 36969) (17709 37841) (17710 +28346) (17711 21746) (17712 24505) (17713 25764) (17714 36685) (17715 36845) (17716 37444) (17717 +20856) (17718 22635) (17719 22825) (17720 23637) (17721 24215) (17722 28155) (17723 32399) (17724 +29980) (17725 36028) (17726 36578) (17727 39003) (17728 28857) (17729 20253) (17730 27583) (17731 +28593) (17732 30000) (17733 38651) (17734 20814) (17735 21520) (17736 22581) (17737 22615) (17738 +22956) (17739 23648) (17740 24466) (17741 26007) (17742 26460) (17743 28193) (17744 30331) (17745 +33759) (17746 36077) (17747 36884) (17748 37117) (17749 37709) (17750 30757) (17751 30778) (17752 +21162) (17753 24230) (17754 22303) (17755 22900) (17756 24594) (17757 20498) (17758 20826) (17759 +20908) (17760 20941) (17761 20992) (17762 21776) (17763 22612) (17764 22616) (17765 22871) (17766 +23445) (17767 23798) (17768 23947) (17769 24764) (17770 25237) (17771 25645) (17772 26481) (17773 +26691) (17774 26812) (17775 26847) (17776 30423) (17777 28120) (17778 28271) (17779 28059) (17780 +28783) (17781 29128) (17782 24403) (17783 30168) (17784 31095) (17785 31561) (17786 31572) (17787 +31570) (17788 31958) (17789 32113) (17790 21040) (17953 33891) (17954 34153) (17955 34276) (17956 +35342) (17957 35588) (17958 35910) (17959 36367) (17960 36867) (17961 36879) (17962 37913) (17963 +38518) (17964 38957) (17965 39472) (17966 38360) (17967 20685) (17968 21205) (17969 21516) (17970 +22530) (17971 23566) (17972 24999) (17973 25758) (17974 27934) (17975 30643) (17976 31461) (17977 +33012) (17978 33796) (17979 36947) (17980 37509) (17981 23776) (17982 40199) (17983 21311) (17984 +24471) (17985 24499) (17986 28060) (17987 29305) (17988 30563) (17989 31167) (17990 31716) (17991 +27602) (17992 29420) (17993 35501) (17994 26627) (17995 27233) (17996 20984) (17997 31361) (17998 +26932) (17999 23626) (18000 40182) (18001 33515) (18002 23493) (18003 37193) (18004 28702) (18005 +22136) (18006 23663) (18007 24775) (18008 25958) (18009 27788) (18010 35930) (18011 36929) (18012 +38931) (18013 21585) (18014 26311) (18015 37389) (18016 22856) (18017 37027) (18018 20869) (18019 +20045) (18020 20970) (18021 34201) (18022 35598) (18023 28760) (18024 25466) (18025 37707) (18026 +26978) (18027 39348) (18028 32260) (18029 30071) (18030 21335) (18031 26976) (18032 36575) (18033 +38627) (18034 27741) (18035 20108) (18036 23612) (18037 24336) (18038 36841) (18039 21250) (18040 +36049) (18041 32905) (18042 34425) (18043 24319) (18044 26085) (18045 20083) (18046 20837) (18209 +22914) (18210 23615) (18211 38894) (18212 20219) (18213 22922) (18214 24525) (18215 35469) (18216 +28641) (18217 31152) (18218 31074) (18219 23527) (18220 33905) (18221 29483) (18222 29105) (18223 +24180) (18224 24565) (18225 25467) (18226 25754) (18227 29123) (18228 31896) (18229 20035) (18230 +24316) (18231 20043) (18232 22492) (18233 22178) (18234 24745) (18235 28611) (18236 32013) (18237 +33021) (18238 33075) (18239 33215) (18240 36786) (18241 35223) (18242 34468) (18243 24052) (18244 +25226) (18245 25773) (18246 35207) (18247 26487) (18248 27874) (18249 27966) (18250 29750) (18251 +30772) (18252 23110) (18253 32629) (18254 33453) (18255 39340) (18256 20467) (18257 24259) (18258 +25309) (18259 25490) (18260 25943) (18261 26479) (18262 30403) (18263 29260) (18264 32972) (18265 +32954) (18266 36649) (18267 37197) (18268 20493) (18269 22521) (18270 23186) (18271 26757) (18272 +26995) (18273 29028) (18274 29437) (18275 36023) (18276 22770) (18277 36064) (18278 38506) (18279 +36889) (18280 34687) (18281 31204) (18282 30695) (18283 33833) (18284 20271) (18285 21093) (18286 +21338) (18287 25293) (18288 26575) (18289 27850) (18290 30333) (18291 31636) (18292 31893) (18293 +33334) (18294 34180) (18295 36843) (18296 26333) (18297 28448) (18298 29190) (18299 32283) (18300 +33707) (18301 39361) (18302 40614) (18465 20989) (18466 31665) (18467 30834) (18468 31672) (18469 +32903) (18470 31560) (18471 27368) (18472 24161) (18473 32908) (18474 30033) (18475 30048) (18476 +20843) (18477 37474) (18478 28300) (18479 30330) (18480 37271) (18481 39658) (18482 20240) (18483 +32624) (18484 25244) (18485 31567) (18486 38309) (18487 40169) (18488 22138) (18489 22617) (18490 +34532) (18491 38588) (18492 20276) (18493 21028) (18494 21322) (18495 21453) (18496 21467) (18497 +24070) (18498 25644) (18499 26001) (18500 26495) (18501 27710) (18502 27726) (18503 29256) (18504 +29359) (18505 29677) (18506 30036) (18507 32321) (18508 33324) (18509 34281) (18510 36009) (18511 +31684) (18512 37318) (18513 29033) (18514 38930) (18515 39151) (18516 25405) (18517 26217) (18518 +30058) (18519 30436) (18520 30928) (18521 34115) (18522 34542) (18523 21290) (18524 21329) (18525 +21542) (18526 22915) (18527 24199) (18528 24444) (18529 24754) (18530 25161) (18531 25209) (18532 +25259) (18533 26000) (18534 27604) (18535 27852) (18536 30130) (18537 30382) (18538 30865) (18539 +31192) (18540 32203) (18541 32631) (18542 32933) (18543 34987) (18544 35513) (18545 36027) (18546 +36991) (18547 38750) (18548 39131) (18549 27147) (18550 31800) (18551 20633) (18552 23614) (18553 +24494) (18554 26503) (18555 27608) (18556 29749) (18557 30473) (18558 32654) (18721 40763) (18722 +26570) (18723 31255) (18724 21305) (18725 30091) (18726 39661) (18727 24422) (18728 33181) (18729 +33777) (18730 32920) (18731 24380) (18732 24517) (18733 30050) (18734 31558) (18735 36924) (18736 +26727) (18737 23019) (18738 23195) (18739 32016) (18740 30334) (18741 35628) (18742 20469) (18743 +24426) (18744 27161) (18745 27703) (18746 28418) (18747 29922) (18748 31080) (18749 34920) (18750 +35413) (18751 35961) (18752 24287) (18753 25551) (18754 30149) (18755 31186) (18756 33495) (18757 +37672) (18758 37618) (18759 33948) (18760 34541) (18761 39981) (18762 21697) (18763 24428) (18764 +25996) (18765 27996) (18766 28693) (18767 36007) (18768 36051) (18769 38971) (18770 25935) (18771 +29942) (18772 19981) (18773 20184) (18774 22496) (18775 22827) (18776 23142) (18777 23500) (18778 +20904) (18779 24067) (18780 24220) (18781 24598) (18782 25206) (18783 25975) (18784 26023) (18785 +26222) (18786 28014) (18787 29238) (18788 31526) (18789 33104) (18790 33178) (18791 33433) (18792 +35676) (18793 36000) (18794 36070) (18795 36212) (18796 38428) (18797 38468) (18798 20398) (18799 +25771) (18800 27494) (18801 33310) (18802 33889) (18803 34154) (18804 37096) (18805 23553) (18806 +26963) (18807 39080) (18808 33914) (18809 34135) (18810 20239) (18811 21103) (18812 24489) (18813 +24133) (18814 26381) (18977 31119) (18978 33145) (18979 35079) (18980 35206) (18981 28149) (18982 +24343) (18983 25173) (18984 27832) (18985 20175) (18986 29289) (18987 39826) (18988 20998) (18989 +21563) (18990 22132) (18991 22707) (18992 24996) (18993 25198) (18994 28954) (18995 22894) (18996 +31881) (18997 31966) (18998 32027) (18999 38640) (19000 25991) (19001 32862) (19002 19993) (19003 +20341) (19004 20853) (19005 22592) (19006 24163) (19007 24179) (19008 24330) (19009 26564) (19010 +20006) (19011 34109) (19012 38281) (19013 38491) (19014 31859) (19015 38913) (19016 20731) (19017 +22721) (19018 30294) (19019 30887) (19020 21029) (19021 30629) (19022 34065) (19023 31622) (19024 +20559) (19025 22793) (19026 29255) (19027 31687) (19028 32232) (19029 36794) (19030 36820) (19031 +36941) (19032 20415) (19033 21193) (19034 23081) (19035 24321) (19036 38829) (19037 20445) (19038 +33303) (19039 37610) (19040 22275) (19041 25429) (19042 27497) (19043 29995) (19044 35036) (19045 +36628) (19046 31298) (19047 21215) (19048 22675) (19049 24917) (19050 25098) (19051 26286) (19052 +27597) (19053 31807) (19054 33769) (19055 20515) (19056 20472) (19057 21253) (19058 21574) (19059 +22577) (19060 22857) (19061 23453) (19062 23792) (19063 23791) (19064 23849) (19065 24214) (19066 +25265) (19067 25447) (19068 25918) (19069 26041) (19070 26379) (19233 27861) (19234 27873) (19235 +28921) (19236 30770) (19237 32299) (19238 32990) (19239 33459) (19240 33804) (19241 34028) (19242 +34562) (19243 35090) (19244 35370) (19245 35914) (19246 37030) (19247 37586) (19248 39165) (19249 +40179) (19250 40300) (19251 20047) (19252 20129) (19253 20621) (19254 21078) (19255 22346) (19256 +22952) (19257 24125) (19258 24536) (19259 24537) (19260 25151) (19261 26292) (19262 26395) (19263 +26576) (19264 26834) (19265 20882) (19266 32033) (19267 32938) (19268 33192) (19269 35584) (19270 +35980) (19271 36031) (19272 37502) (19273 38450) (19274 21536) (19275 38956) (19276 21271) (19277 +20693) (19278 21340) (19279 22696) (19280 25778) (19281 26420) (19282 29287) (19283 30566) (19284 +31302) (19285 37350) (19286 21187) (19287 27809) (19288 27526) (19289 22528) (19290 24140) (19291 +22868) (19292 26412) (19293 32763) (19294 20961) (19295 30406) (19296 25705) (19297 30952) (19298 +39764) (19299 40635) (19300 22475) (19301 22969) (19302 26151) (19303 26522) (19304 27598) (19305 +21737) (19306 27097) (19307 24149) (19308 33180) (19309 26517) (19310 39850) (19311 26622) (19312 +40018) (19313 26717) (19314 20134) (19315 20451) (19316 21448) (19317 25273) (19318 26411) (19319 +27819) (19320 36804) (19321 20397) (19322 32365) (19323 40639) (19324 19975) (19325 24930) (19326 +28288) (19489 28459) (19490 34067) (19491 21619) (19492 26410) (19493 39749) (19494 24051) (19495 +31637) (19496 23724) (19497 23494) (19498 34588) (19499 28234) (19500 34001) (19501 31252) (19502 +33032) (19503 22937) (19504 31885) (19505 27665) (19506 30496) (19507 21209) (19508 22818) (19509 +28961) (19510 29279) (19511 30683) (19512 38695) (19513 40289) (19514 26891) (19515 23167) (19516 +23064) (19517 20901) (19518 21517) (19519 21629) (19520 26126) (19521 30431) (19522 36855) (19523 +37528) (19524 40180) (19525 23018) (19526 29277) (19527 28357) (19528 20813) (19529 26825) (19530 +32191) (19531 32236) (19532 38754) (19533 40634) (19534 25720) (19535 27169) (19536 33538) (19537 +22916) (19538 23391) (19539 27611) (19540 29467) (19541 30450) (19542 32178) (19543 32791) (19544 +33945) (19545 20786) (19546 26408) (19547 40665) (19548 30446) (19549 26466) (19550 21247) (19551 +39173) (19552 23588) (19553 25147) (19554 31870) (19555 36016) (19556 21839) (19557 24758) (19558 +32011) (19559 38272) (19560 21249) (19561 20063) (19562 20918) (19563 22812) (19564 29242) (19565 +32822) (19566 37326) (19567 24357) (19568 30690) (19569 21380) (19570 24441) (19571 32004) (19572 +34220) (19573 35379) (19574 36493) (19575 38742) (19576 26611) (19577 34222) (19578 37971) (19579 +24841) (19580 24840) (19581 27833) (19582 30290) (19745 35565) (19746 36664) (19747 21807) (19748 +20305) (19749 20778) (19750 21191) (19751 21451) (19752 23461) (19753 24189) (19754 24736) (19755 +24962) (19756 25558) (19757 26377) (19758 26586) (19759 28263) (19760 28044) (19761 29494) (19762 +29495) (19763 30001) (19764 31056) (19765 35029) (19766 35480) (19767 36938) (19768 37009) (19769 +37109) (19770 38596) (19771 34701) (19772 22805) (19773 20104) (19774 20313) (19775 19982) (19776 +35465) (19777 36671) (19778 38928) (19779 20653) (19780 24188) (19781 22934) (19782 23481) (19783 +24248) (19784 25562) (19785 25594) (19786 25793) (19787 26332) (19788 26954) (19789 27096) (19790 +27915) (19791 28342) (19792 29076) (19793 29992) (19794 31407) (19795 32650) (19796 32768) (19797 +33865) (19798 33993) (19799 35201) (19800 35617) (19801 36362) (19802 36965) (19803 38525) (19804 +39178) (19805 24958) (19806 25233) (19807 27442) (19808 27779) (19809 28020) (19810 32716) (19811 +32764) (19812 28096) (19813 32645) (19814 34746) (19815 35064) (19816 26469) (19817 33713) (19818 +38972) (19819 38647) (19820 27931) (19821 32097) (19822 33853) (19823 37226) (19824 20081) (19825 +21365) (19826 23888) (19827 27396) (19828 28651) (19829 34253) (19830 34349) (19831 35239) (19832 +21033) (19833 21519) (19834 23653) (19835 26446) (19836 26792) (19837 29702) (19838 29827) (20001 +30178) (20002 35023) (20003 35041) (20004 37324) (20005 38626) (20006 38520) (20007 24459) (20008 +29575) (20009 31435) (20010 33870) (20011 25504) (20012 30053) (20013 21129) (20014 27969) (20015 +28316) (20016 29705) (20017 30041) (20018 30827) (20019 31890) (20020 38534) (20021 31452) (20022 +40845) (20023 20406) (20024 24942) (20025 26053) (20026 34396) (20027 20102) (20028 20142) (20029 +20698) (20030 20001) (20031 20940) (20032 23534) (20033 26009) (20034 26753) (20035 28092) (20036 +29471) (20037 30274) (20038 30637) (20039 31260) (20040 31975) (20041 33391) (20042 35538) (20043 +36988) (20044 37327) (20045 38517) (20046 38936) (20047 21147) (20048 32209) (20049 20523) (20050 +21400) (20051 26519) (20052 28107) (20053 29136) (20054 29747) (20055 33256) (20056 36650) (20057 +38563) (20058 40023) (20059 40607) (20060 29792) (20061 22593) (20062 28057) (20063 32047) (20064 +39006) (20065 20196) (20066 20278) (20067 20363) (20068 20919) (20069 21169) (20070 23994) (20071 +24604) (20072 29618) (20073 31036) (20074 33491) (20075 37428) (20076 38583) (20077 38646) (20078 +38666) (20079 40599) (20080 40802) (20081 26278) (20082 27508) (20083 21015) (20084 21155) (20085 +28872) (20086 35010) (20087 24265) (20088 24651) (20089 24976) (20090 28451) (20091 29001) (20092 +31806) (20093 32244) (20094 32879) (20257 34030) (20258 36899) (20259 37676) (20260 21570) (20261 +39791) (20262 27347) (20263 28809) (20264 36034) (20265 36335) (20266 38706) (20267 21172) (20268 +23105) (20269 24266) (20270 24324) (20271 26391) (20272 27004) (20273 27028) (20274 28010) (20275 +28431) (20276 29282) (20277 29436) (20278 31725) (20279 32769) (20280 32894) (20281 34635) (20282 +37070) (20283 20845) (20284 40595) (20285 31108) (20286 32907) (20287 37682) (20288 35542) (20289 +20525) (20290 21644) (20291 35441) (20292 27498) (20293 36036) (20294 33031) (20295 24785) (20296 +26528) (20297 40434) (20298 20121) (20299 20120) (20300 39952) (20301 35435) (20302 34241) (20303 +34152) (20304 26880) (20305 28286) (20306 30871) (20307 33109) (20513 24332) (20514 19984) (20515 +19989) (20516 20010) (20517 20017) (20518 20022) (20519 20028) (20520 20031) (20521 20034) (20522 +20054) (20523 20056) (20524 20098) (20525 20101) (20526 35947) (20527 20106) (20528 33298) (20529 +24333) (20530 20110) (20531 20126) (20532 20127) (20533 20128) (20534 20130) (20535 20144) (20536 +20147) (20537 20150) (20538 20174) (20539 20173) (20540 20164) (20541 20166) (20542 20162) (20543 +20183) (20544 20190) (20545 20205) (20546 20191) (20547 20215) (20548 20233) (20549 20314) (20550 +20272) (20551 20315) (20552 20317) (20553 20311) (20554 20295) (20555 20342) (20556 20360) (20557 +20367) (20558 20376) (20559 20347) (20560 20329) (20561 20336) (20562 20369) (20563 20335) (20564 +20358) (20565 20374) (20566 20760) (20567 20436) (20568 20447) (20569 20430) (20570 20440) (20571 +20443) (20572 20433) (20573 20442) (20574 20432) (20575 20452) (20576 20453) (20577 20506) (20578 +20520) (20579 20500) (20580 20522) (20581 20517) (20582 20485) (20583 20252) (20584 20470) (20585 +20513) (20586 20521) (20587 20524) (20588 20478) (20589 20463) (20590 20497) (20591 20486) (20592 +20547) (20593 20551) (20594 26371) (20595 20565) (20596 20560) (20597 20552) (20598 20570) (20599 +20566) (20600 20588) (20601 20600) (20602 20608) (20603 20634) (20604 20613) (20605 20660) (20606 +20658) (20769 20681) (20770 20682) (20771 20659) (20772 20674) (20773 20694) (20774 20702) (20775 +20709) (20776 20717) (20777 20707) (20778 20718) (20779 20729) (20780 20725) (20781 20745) (20782 +20737) (20783 20738) (20784 20758) (20785 20757) (20786 20756) (20787 20762) (20788 20769) (20789 +20794) (20790 20791) (20791 20796) (20792 20795) (20793 20799) (20794 20800) (20795 20818) (20796 +20812) (20797 20820) (20798 20834) (20799 31480) (20800 20841) (20801 20842) (20802 20846) (20803 +20864) (20804 20866) (20805 22232) (20806 20876) (20807 20873) (20808 20879) (20809 20881) (20810 +20883) (20811 20885) (20812 20886) (20813 20900) (20814 20902) (20815 20898) (20816 20905) (20817 +20906) (20818 20907) (20819 20915) (20820 20913) (20821 20914) (20822 20912) (20823 20917) (20824 +20925) (20825 20933) (20826 20937) (20827 20955) (20828 20960) (20829 34389) (20830 20969) (20831 +20973) (20832 20976) (20833 20981) (20834 20990) (20835 20996) (20836 21003) (20837 21012) (20838 +21006) (20839 21031) (20840 21034) (20841 21038) (20842 21043) (20843 21049) (20844 21071) (20845 +21060) (20846 21067) (20847 21068) (20848 21086) (20849 21076) (20850 21098) (20851 21108) (20852 +21097) (20853 21107) (20854 21119) (20855 21117) (20856 21133) (20857 21140) (20858 21138) (20859 +21105) (20860 21128) (20861 21137) (20862 36776) (21025 36775) (21026 21164) (21027 21165) (21028 +21180) (21029 21173) (21030 21185) (21031 21197) (21032 21207) (21033 21214) (21034 21219) (21035 +21222) (21036 39149) (21037 21216) (21038 21235) (21039 21237) (21040 21240) (21041 21241) (21042 +21254) (21043 21256) (21044 30008) (21045 21261) (21046 21264) (21047 21263) (21048 21269) (21049 +21274) (21050 21283) (21051 21295) (21052 21297) (21053 21299) (21054 21304) (21055 21312) (21056 +21318) (21057 21317) (21058 19991) (21059 21321) (21060 21325) (21061 20950) (21062 21342) (21063 +21353) (21064 21358) (21065 22808) (21066 21371) (21067 21367) (21068 21378) (21069 21398) (21070 +21408) (21071 21414) (21072 21413) (21073 21422) (21074 21424) (21075 21430) (21076 21443) (21077 +31762) (21078 38617) (21079 21471) (21080 26364) (21081 29166) (21082 21486) (21083 21480) (21084 +21485) (21085 21498) (21086 21505) (21087 21565) (21088 21568) (21089 21548) (21090 21549) (21091 +21564) (21092 21550) (21093 21558) (21094 21545) (21095 21533) (21096 21582) (21097 21647) (21098 +21621) (21099 21646) (21100 21599) (21101 21617) (21102 21623) (21103 21616) (21104 21650) (21105 +21627) (21106 21632) (21107 21622) (21108 21636) (21109 21648) (21110 21638) (21111 21703) (21112 +21666) (21113 21688) (21114 21669) (21115 21676) (21116 21700) (21117 21704) (21118 21672) (21281 +21675) (21282 21698) (21283 21668) (21284 21694) (21285 21692) (21286 21720) (21287 21733) (21288 +21734) (21289 21775) (21290 21780) (21291 21757) (21292 21742) (21293 21741) (21294 21754) (21295 +21730) (21296 21817) (21297 21824) (21298 21859) (21299 21836) (21300 21806) (21301 21852) (21302 +21829) (21303 21846) (21304 21847) (21305 21816) (21306 21811) (21307 21853) (21308 21913) (21309 +21888) (21310 21679) (21311 21898) (21312 21919) (21313 21883) (21314 21886) (21315 21912) (21316 +21918) (21317 21934) (21318 21884) (21319 21891) (21320 21929) (21321 21895) (21322 21928) (21323 +21978) (21324 21957) (21325 21983) (21326 21956) (21327 21980) (21328 21988) (21329 21972) (21330 +22036) (21331 22007) (21332 22038) (21333 22014) (21334 22013) (21335 22043) (21336 22009) (21337 +22094) (21338 22096) (21339 29151) (21340 22068) (21341 22070) (21342 22066) (21343 22072) (21344 +22123) (21345 22116) (21346 22063) (21347 22124) (21348 22122) (21349 22150) (21350 22144) (21351 +22154) (21352 22176) (21353 22164) (21354 22159) (21355 22181) (21356 22190) (21357 22198) (21358 +22196) (21359 22210) (21360 22204) (21361 22209) (21362 22211) (21363 22208) (21364 22216) (21365 +22222) (21366 22225) (21367 22227) (21368 22231) (21369 22254) (21370 22265) (21371 22272) (21372 +22271) (21373 22276) (21374 22281) (21537 22280) (21538 22283) (21539 22285) (21540 22291) (21541 +22296) (21542 22294) (21543 21959) (21544 22300) (21545 22310) (21546 22327) (21547 22328) (21548 +22350) (21549 22331) (21550 22336) (21551 22351) (21552 22377) (21553 22464) (21554 22408) (21555 +22369) (21556 22399) (21557 22409) (21558 22419) (21559 22432) (21560 22451) (21561 22436) (21562 +22442) (21563 22448) (21564 22467) (21565 22470) (21566 22484) (21567 22482) (21568 22483) (21569 +22538) (21570 22486) (21571 22499) (21572 22539) (21573 22553) (21574 22557) (21575 22642) (21576 +22561) (21577 22626) (21578 22603) (21579 22640) (21580 27584) (21581 22610) (21582 22589) (21583 +22649) (21584 22661) (21585 22713) (21586 22687) (21587 22699) (21588 22714) (21589 22750) (21590 +22715) (21591 22712) (21592 22702) (21593 22725) (21594 22739) (21595 22737) (21596 22743) (21597 +22745) (21598 22744) (21599 22757) (21600 22748) (21601 22756) (21602 22751) (21603 22767) (21604 +22778) (21605 22777) (21606 22779) (21607 22780) (21608 22781) (21609 22786) (21610 22794) (21611 +22800) (21612 22811) (21613 26790) (21614 22821) (21615 22828) (21616 22829) (21617 22834) (21618 +22840) (21619 22846) (21620 31442) (21621 22869) (21622 22864) (21623 22862) (21624 22874) (21625 +22872) (21626 22882) (21627 22880) (21628 22887) (21629 22892) (21630 22889) (21793 22904) (21794 +22913) (21795 22941) (21796 20318) (21797 20395) (21798 22947) (21799 22962) (21800 22982) (21801 +23016) (21802 23004) (21803 22925) (21804 23001) (21805 23002) (21806 23077) (21807 23071) (21808 +23057) (21809 23068) (21810 23049) (21811 23066) (21812 23104) (21813 23148) (21814 23113) (21815 +23093) (21816 23094) (21817 23138) (21818 23146) (21819 23194) (21820 23228) (21821 23230) (21822 +23243) (21823 23234) (21824 23229) (21825 23267) (21826 23255) (21827 23270) (21828 23273) (21829 +23254) (21830 23290) (21831 23291) (21832 23308) (21833 23307) (21834 23318) (21835 23346) (21836 +23248) (21837 23338) (21838 23350) (21839 23358) (21840 23363) (21841 23365) (21842 23360) (21843 +23377) (21844 23381) (21845 23386) (21846 23387) (21847 23397) (21848 23401) (21849 23408) (21850 +23411) (21851 23413) (21852 23416) (21853 25992) (21854 23418) (21855 23424) (21856 23427) (21857 +23462) (21858 23480) (21859 23491) (21860 23495) (21861 23497) (21862 23508) (21863 23504) (21864 +23524) (21865 23526) (21866 23522) (21867 23518) (21868 23525) (21869 23531) (21870 23536) (21871 +23542) (21872 23539) (21873 23557) (21874 23559) (21875 23560) (21876 23565) (21877 23571) (21878 +23584) (21879 23586) (21880 23592) (21881 23608) (21882 23609) (21883 23617) (21884 23622) (21885 +23630) (21886 23635) (22049 23632) (22050 23631) (22051 23409) (22052 23660) (22053 23662) (22054 +20066) (22055 23670) (22056 23673) (22057 23692) (22058 23697) (22059 23700) (22060 22939) (22061 +23723) (22062 23739) (22063 23734) (22064 23740) (22065 23735) (22066 23749) (22067 23742) (22068 +23751) (22069 23769) (22070 23785) (22071 23805) (22072 23802) (22073 23789) (22074 23948) (22075 +23786) (22076 23819) (22077 23829) (22078 23831) (22079 23900) (22080 23839) (22081 23835) (22082 +23825) (22083 23828) (22084 23842) (22085 23834) (22086 23833) (22087 23832) (22088 23884) (22089 +23890) (22090 23886) (22091 23883) (22092 23916) (22093 23923) (22094 23926) (22095 23943) (22096 +23940) (22097 23938) (22098 23970) (22099 23965) (22100 23980) (22101 23982) (22102 23997) (22103 +23952) (22104 23991) (22105 23996) (22106 24009) (22107 24013) (22108 24019) (22109 24018) (22110 +24022) (22111 24027) (22112 24043) (22113 24050) (22114 24053) (22115 24075) (22116 24090) (22117 +24089) (22118 24081) (22119 24091) (22120 24118) (22121 24119) (22122 24132) (22123 24131) (22124 +24128) (22125 24142) (22126 24151) (22127 24148) (22128 24159) (22129 24162) (22130 24164) (22131 +24135) (22132 24181) (22133 24182) (22134 24186) (22135 40636) (22136 24191) (22137 24224) (22138 +24257) (22139 24258) (22140 24264) (22141 24272) (22142 24271) (22305 24278) (22306 24291) (22307 +24285) (22308 24282) (22309 24283) (22310 24290) (22311 24289) (22312 24296) (22313 24297) (22314 +24300) (22315 24305) (22316 24307) (22317 24304) (22318 24308) (22319 24312) (22320 24318) (22321 +24323) (22322 24329) (22323 24413) (22324 24412) (22325 24331) (22326 24337) (22327 24342) (22328 +24361) (22329 24365) (22330 24376) (22331 24385) (22332 24392) (22333 24396) (22334 24398) (22335 +24367) (22336 24401) (22337 24406) (22338 24407) (22339 24409) (22340 24417) (22341 24429) (22342 +24435) (22343 24439) (22344 24451) (22345 24450) (22346 24447) (22347 24458) (22348 24456) (22349 +24465) (22350 24455) (22351 24478) (22352 24473) (22353 24472) (22354 24480) (22355 24488) (22356 +24493) (22357 24508) (22358 24534) (22359 24571) (22360 24548) (22361 24568) (22362 24561) (22363 +24541) (22364 24755) (22365 24575) (22366 24609) (22367 24672) (22368 24601) (22369 24592) (22370 +24617) (22371 24590) (22372 24625) (22373 24603) (22374 24597) (22375 24619) (22376 24614) (22377 +24591) (22378 24634) (22379 24666) (22380 24641) (22381 24682) (22382 24695) (22383 24671) (22384 +24650) (22385 24646) (22386 24653) (22387 24675) (22388 24643) (22389 24676) (22390 24642) (22391 +24684) (22392 24683) (22393 24665) (22394 24705) (22395 24717) (22396 24807) (22397 24707) (22398 +24730) (22561 24708) (22562 24731) (22563 24726) (22564 24727) (22565 24722) (22566 24743) (22567 +24715) (22568 24801) (22569 24760) (22570 24800) (22571 24787) (22572 24756) (22573 24560) (22574 +24765) (22575 24774) (22576 24757) (22577 24792) (22578 24909) (22579 24853) (22580 24838) (22581 +24822) (22582 24823) (22583 24832) (22584 24820) (22585 24826) (22586 24835) (22587 24865) (22588 +24827) (22589 24817) (22590 24845) (22591 24846) (22592 24903) (22593 24894) (22594 24872) (22595 +24871) (22596 24906) (22597 24895) (22598 24892) (22599 24876) (22600 24884) (22601 24893) (22602 +24898) (22603 24900) (22604 24947) (22605 24951) (22606 24920) (22607 24921) (22608 24922) (22609 +24939) (22610 24948) (22611 24943) (22612 24933) (22613 24945) (22614 24927) (22615 24925) (22616 +24915) (22617 24949) (22618 24985) (22619 24982) (22620 24967) (22621 25004) (22622 24980) (22623 +24986) (22624 24970) (22625 24977) (22626 25003) (22627 25006) (22628 25036) (22629 25034) (22630 +25033) (22631 25079) (22632 25032) (22633 25027) (22634 25030) (22635 25018) (22636 25035) (22637 +32633) (22638 25037) (22639 25062) (22640 25059) (22641 25078) (22642 25082) (22643 25076) (22644 +25087) (22645 25085) (22646 25084) (22647 25086) (22648 25088) (22649 25096) (22650 25097) (22651 +25101) (22652 25100) (22653 25108) (22654 25115) (22817 25118) (22818 25121) (22819 25130) (22820 +25134) (22821 25136) (22822 25138) (22823 25139) (22824 25153) (22825 25166) (22826 25182) (22827 +25187) (22828 25179) (22829 25184) (22830 25192) (22831 25212) (22832 25218) (22833 25225) (22834 +25214) (22835 25234) (22836 25235) (22837 25238) (22838 25300) (22839 25219) (22840 25236) (22841 +25303) (22842 25297) (22843 25275) (22844 25295) (22845 25343) (22846 25286) (22847 25812) (22848 +25288) (22849 25308) (22850 25292) (22851 25290) (22852 25282) (22853 25287) (22854 25243) (22855 +25289) (22856 25356) (22857 25326) (22858 25329) (22859 25383) (22860 25346) (22861 25352) (22862 +25327) (22863 25333) (22864 25424) (22865 25406) (22866 25421) (22867 25628) (22868 25423) (22869 +25494) (22870 25486) (22871 25472) (22872 25515) (22873 25462) (22874 25507) (22875 25487) (22876 +25481) (22877 25503) (22878 25525) (22879 25451) (22880 25449) (22881 25534) (22882 25577) (22883 +25536) (22884 25542) (22885 25571) (22886 25545) (22887 25554) (22888 25590) (22889 25540) (22890 +25622) (22891 25652) (22892 25606) (22893 25619) (22894 25638) (22895 25654) (22896 25885) (22897 +25623) (22898 25640) (22899 25615) (22900 25703) (22901 25711) (22902 25718) (22903 25678) (22904 +25898) (22905 25749) (22906 25747) (22907 25765) (22908 25769) (22909 25736) (22910 25788) (23073 +25818) (23074 25810) (23075 25797) (23076 25799) (23077 25787) (23078 25816) (23079 25794) (23080 +25841) (23081 25831) (23082 33289) (23083 25824) (23084 25825) (23085 25260) (23086 25827) (23087 +25839) (23088 25900) (23089 25846) (23090 25844) (23091 25842) (23092 25850) (23093 25856) (23094 +25853) (23095 25880) (23096 25884) (23097 25861) (23098 25892) (23099 25891) (23100 25899) (23101 +25908) (23102 25909) (23103 25911) (23104 25910) (23105 25912) (23106 30027) (23107 25928) (23108 +25942) (23109 25941) (23110 25933) (23111 25944) (23112 25950) (23113 25949) (23114 25970) (23115 +25976) (23116 25986) (23117 25987) (23118 35722) (23119 26011) (23120 26015) (23121 26027) (23122 +26039) (23123 26051) (23124 26054) (23125 26049) (23126 26052) (23127 26060) (23128 26066) (23129 +26075) (23130 26073) (23131 26080) (23132 26081) (23133 26097) (23134 26482) (23135 26122) (23136 +26115) (23137 26107) (23138 26483) (23139 26165) (23140 26166) (23141 26164) (23142 26140) (23143 +26191) (23144 26180) (23145 26185) (23146 26177) (23147 26206) (23148 26205) (23149 26212) (23150 +26215) (23151 26216) (23152 26207) (23153 26210) (23154 26224) (23155 26243) (23156 26248) (23157 +26254) (23158 26249) (23159 26244) (23160 26264) (23161 26269) (23162 26305) (23163 26297) (23164 +26313) (23165 26302) (23166 26300) (23329 26308) (23330 26296) (23331 26326) (23332 26330) (23333 +26336) (23334 26175) (23335 26342) (23336 26345) (23337 26352) (23338 26357) (23339 26359) (23340 +26383) (23341 26390) (23342 26398) (23343 26406) (23344 26407) (23345 38712) (23346 26414) (23347 +26431) (23348 26422) (23349 26433) (23350 26424) (23351 26423) (23352 26438) (23353 26462) (23354 +26464) (23355 26457) (23356 26467) (23357 26468) (23358 26505) (23359 26480) (23360 26537) (23361 +26492) (23362 26474) (23363 26508) (23364 26507) (23365 26534) (23366 26529) (23367 26501) (23368 +26551) (23369 26607) (23370 26548) (23371 26604) (23372 26547) (23373 26601) (23374 26552) (23375 +26596) (23376 26590) (23377 26589) (23378 26594) (23379 26606) (23380 26553) (23381 26574) (23382 +26566) (23383 26599) (23384 27292) (23385 26654) (23386 26694) (23387 26665) (23388 26688) (23389 +26701) (23390 26674) (23391 26702) (23392 26803) (23393 26667) (23394 26713) (23395 26723) (23396 +26743) (23397 26751) (23398 26783) (23399 26767) (23400 26797) (23401 26772) (23402 26781) (23403 +26779) (23404 26755) (23405 27310) (23406 26809) (23407 26740) (23408 26805) (23409 26784) (23410 +26810) (23411 26895) (23412 26765) (23413 26750) (23414 26881) (23415 26826) (23416 26888) (23417 +26840) (23418 26914) (23419 26918) (23420 26849) (23421 26892) (23422 26829) (23585 26836) (23586 +26855) (23587 26837) (23588 26934) (23589 26898) (23590 26884) (23591 26839) (23592 26851) (23593 +26917) (23594 26873) (23595 26848) (23596 26863) (23597 26920) (23598 26922) (23599 26906) (23600 +26915) (23601 26913) (23602 26822) (23603 27001) (23604 26999) (23605 26972) (23606 27000) (23607 +26987) (23608 26964) (23609 27006) (23610 26990) (23611 26937) (23612 26996) (23613 26941) (23614 +26969) (23615 26928) (23616 26977) (23617 26974) (23618 26973) (23619 27009) (23620 26986) (23621 +27058) (23622 27054) (23623 27088) (23624 27071) (23625 27073) (23626 27091) (23627 27070) (23628 +27086) (23629 23528) (23630 27082) (23631 27101) (23632 27067) (23633 27075) (23634 27047) (23635 +27182) (23636 27025) (23637 27040) (23638 27036) (23639 27029) (23640 27060) (23641 27102) (23642 +27112) (23643 27138) (23644 27163) (23645 27135) (23646 27402) (23647 27129) (23648 27122) (23649 +27111) (23650 27141) (23651 27057) (23652 27166) (23653 27117) (23654 27156) (23655 27115) (23656 +27146) (23657 27154) (23658 27329) (23659 27171) (23660 27155) (23661 27204) (23662 27148) (23663 +27250) (23664 27190) (23665 27256) (23666 27207) (23667 27234) (23668 27225) (23669 27238) (23670 +27208) (23671 27192) (23672 27170) (23673 27280) (23674 27277) (23675 27296) (23676 27268) (23677 +27298) (23678 27299) (23841 27287) (23842 34327) (23843 27323) (23844 27331) (23845 27330) (23846 +27320) (23847 27315) (23848 27308) (23849 27358) (23850 27345) (23851 27359) (23852 27306) (23853 +27354) (23854 27370) (23855 27387) (23856 27397) (23857 34326) (23858 27386) (23859 27410) (23860 +27414) (23861 39729) (23862 27423) (23863 27448) (23864 27447) (23865 30428) (23866 27449) (23867 +39150) (23868 27463) (23869 27459) (23870 27465) (23871 27472) (23872 27481) (23873 27476) (23874 +27483) (23875 27487) (23876 27489) (23877 27512) (23878 27513) (23879 27519) (23880 27520) (23881 +27524) (23882 27523) (23883 27533) (23884 27544) (23885 27541) (23886 27550) (23887 27556) (23888 +27562) (23889 27563) (23890 27567) (23891 27570) (23892 27569) (23893 27571) (23894 27575) (23895 +27580) (23896 27590) (23897 27595) (23898 27603) (23899 27615) (23900 27628) (23901 27627) (23902 +27635) (23903 27631) (23904 40638) (23905 27656) (23906 27667) (23907 27668) (23908 27675) (23909 +27684) (23910 27683) (23911 27742) (23912 27733) (23913 27746) (23914 27754) (23915 27778) (23916 +27789) (23917 27802) (23918 27777) (23919 27803) (23920 27774) (23921 27752) (23922 27763) (23923 +27794) (23924 27792) (23925 27844) (23926 27889) (23927 27859) (23928 27837) (23929 27863) (23930 +27845) (23931 27869) (23932 27822) (23933 27825) (23934 27838) (24097 27834) (24098 27867) (24099 +27887) (24100 27865) (24101 27882) (24102 27935) (24103 34893) (24104 27958) (24105 27947) (24106 +27965) (24107 27960) (24108 27929) (24109 27957) (24110 27955) (24111 27922) (24112 27916) (24113 +28003) (24114 28051) (24115 28004) (24116 27994) (24117 28025) (24118 27993) (24119 28046) (24120 +28053) (24121 28644) (24122 28037) (24123 28153) (24124 28181) (24125 28170) (24126 28085) (24127 +28103) (24128 28134) (24129 28088) (24130 28102) (24131 28140) (24132 28126) (24133 28108) (24134 +28136) (24135 28114) (24136 28101) (24137 28154) (24138 28121) (24139 28132) (24140 28117) (24141 +28138) (24142 28142) (24143 28205) (24144 28270) (24145 28206) (24146 28185) (24147 28274) (24148 +28255) (24149 28222) (24150 28195) (24151 28267) (24152 28203) (24153 28278) (24154 28237) (24155 +28191) (24156 28227) (24157 28218) (24158 28238) (24159 28196) (24160 28415) (24161 28189) (24162 +28216) (24163 28290) (24164 28330) (24165 28312) (24166 28361) (24167 28343) (24168 28371) (24169 +28349) (24170 28335) (24171 28356) (24172 28338) (24173 28372) (24174 28373) (24175 28303) (24176 +28325) (24177 28354) (24178 28319) (24179 28481) (24180 28433) (24181 28748) (24182 28396) (24183 +28408) (24184 28414) (24185 28479) (24186 28402) (24187 28465) (24188 28399) (24189 28466) (24190 +28364) (24353 28478) (24354 28435) (24355 28407) (24356 28550) (24357 28538) (24358 28536) (24359 +28545) (24360 28544) (24361 28527) (24362 28507) (24363 28659) (24364 28525) (24365 28546) (24366 +28540) (24367 28504) (24368 28558) (24369 28561) (24370 28610) (24371 28518) (24372 28595) (24373 +28579) (24374 28577) (24375 28580) (24376 28601) (24377 28614) (24378 28586) (24379 28639) (24380 +28629) (24381 28652) (24382 28628) (24383 28632) (24384 28657) (24385 28654) (24386 28635) (24387 +28681) (24388 28683) (24389 28666) (24390 28689) (24391 28673) (24392 28687) (24393 28670) (24394 +28699) (24395 28698) (24396 28532) (24397 28701) (24398 28696) (24399 28703) (24400 28720) (24401 +28734) (24402 28722) (24403 28753) (24404 28771) (24405 28825) (24406 28818) (24407 28847) (24408 +28913) (24409 28844) (24410 28856) (24411 28851) (24412 28846) (24413 28895) (24414 28875) (24415 +28893) (24416 28889) (24417 28937) (24418 28925) (24419 28956) (24420 28953) (24421 29029) (24422 +29013) (24423 29064) (24424 29030) (24425 29026) (24426 29004) (24427 29014) (24428 29036) (24429 +29071) (24430 29179) (24431 29060) (24432 29077) (24433 29096) (24434 29100) (24435 29143) (24436 +29113) (24437 29118) (24438 29138) (24439 29129) (24440 29140) (24441 29134) (24442 29152) (24443 +29164) (24444 29159) (24445 29173) (24446 29180) (24609 29177) (24610 29183) (24611 29197) (24612 +29200) (24613 29211) (24614 29224) (24615 29229) (24616 29228) (24617 29232) (24618 29234) (24619 +29243) (24620 29244) (24621 29247) (24622 29248) (24623 29254) (24624 29259) (24625 29272) (24626 +29300) (24627 29310) (24628 29314) (24629 29313) (24630 29319) (24631 29330) (24632 29334) (24633 +29346) (24634 29351) (24635 29369) (24636 29362) (24637 29379) (24638 29382) (24639 29380) (24640 +29390) (24641 29394) (24642 29410) (24643 29408) (24644 29409) (24645 29433) (24646 29431) (24647 +20495) (24648 29463) (24649 29450) (24650 29468) (24651 29462) (24652 29469) (24653 29492) (24654 +29487) (24655 29481) (24656 29477) (24657 29502) (24658 29518) (24659 29519) (24660 40664) (24661 +29527) (24662 29546) (24663 29544) (24664 29552) (24665 29560) (24666 29557) (24667 29563) (24668 +29562) (24669 29640) (24670 29619) (24671 29646) (24672 29627) (24673 29632) (24674 29669) (24675 +29678) (24676 29662) (24677 29858) (24678 29701) (24679 29807) (24680 29733) (24681 29688) (24682 +29746) (24683 29754) (24684 29781) (24685 29759) (24686 29791) (24687 29785) (24688 29761) (24689 +29788) (24690 29801) (24691 29808) (24692 29795) (24693 29802) (24694 29814) (24695 29822) (24696 +29835) (24697 29854) (24698 29863) (24699 29898) (24700 29903) (24701 29908) (24702 29681) (24865 +29920) (24866 29923) (24867 29927) (24868 29929) (24869 29934) (24870 29938) (24871 29936) (24872 +29937) (24873 29944) (24874 29943) (24875 29956) (24876 29955) (24877 29957) (24878 29964) (24879 +29966) (24880 29965) (24881 29973) (24882 29971) (24883 29982) (24884 29990) (24885 29996) (24886 +30012) (24887 30020) (24888 30029) (24889 30026) (24890 30025) (24891 30043) (24892 30022) (24893 +30042) (24894 30057) (24895 30052) (24896 30055) (24897 30059) (24898 30061) (24899 30072) (24900 +30070) (24901 30086) (24902 30087) (24903 30068) (24904 30090) (24905 30089) (24906 30082) (24907 +30100) (24908 30106) (24909 30109) (24910 30117) (24911 30115) (24912 30146) (24913 30131) (24914 +30147) (24915 30133) (24916 30141) (24917 30136) (24918 30140) (24919 30129) (24920 30157) (24921 +30154) (24922 30162) (24923 30169) (24924 30179) (24925 30174) (24926 30206) (24927 30207) (24928 +30204) (24929 30209) (24930 30192) (24931 30202) (24932 30194) (24933 30195) (24934 30219) (24935 +30221) (24936 30217) (24937 30239) (24938 30247) (24939 30240) (24940 30241) (24941 30242) (24942 +30244) (24943 30260) (24944 30256) (24945 30267) (24946 30279) (24947 30280) (24948 30278) (24949 +30300) (24950 30296) (24951 30305) (24952 30306) (24953 30312) (24954 30313) (24955 30314) (24956 +30311) (24957 30316) (24958 30320) (25121 30322) (25122 30326) (25123 30328) (25124 30332) (25125 +30336) (25126 30339) (25127 30344) (25128 30347) (25129 30350) (25130 30358) (25131 30355) (25132 +30361) (25133 30362) (25134 30384) (25135 30388) (25136 30392) (25137 30393) (25138 30394) (25139 +30402) (25140 30413) (25141 30422) (25142 30418) (25143 30430) (25144 30433) (25145 30437) (25146 +30439) (25147 30442) (25148 34351) (25149 30459) (25150 30472) (25151 30471) (25152 30468) (25153 +30505) (25154 30500) (25155 30494) (25156 30501) (25157 30502) (25158 30491) (25159 30519) (25160 +30520) (25161 30535) (25162 30554) (25163 30568) (25164 30571) (25165 30555) (25166 30565) (25167 +30591) (25168 30590) (25169 30585) (25170 30606) (25171 30603) (25172 30609) (25173 30624) (25174 +30622) (25175 30640) (25176 30646) (25177 30649) (25178 30655) (25179 30652) (25180 30653) (25181 +30651) (25182 30663) (25183 30669) (25184 30679) (25185 30682) (25186 30684) (25187 30691) (25188 +30702) (25189 30716) (25190 30732) (25191 30738) (25192 31014) (25193 30752) (25194 31018) (25195 +30789) (25196 30862) (25197 30836) (25198 30854) (25199 30844) (25200 30874) (25201 30860) (25202 +30883) (25203 30901) (25204 30890) (25205 30895) (25206 30929) (25207 30918) (25208 30923) (25209 +30932) (25210 30910) (25211 30908) (25212 30917) (25213 30922) (25214 30956) (25377 30951) (25378 +30938) (25379 30973) (25380 30964) (25381 30983) (25382 30994) (25383 30993) (25384 31001) (25385 +31020) (25386 31019) (25387 31040) (25388 31072) (25389 31063) (25390 31071) (25391 31066) (25392 +31061) (25393 31059) (25394 31098) (25395 31103) (25396 31114) (25397 31133) (25398 31143) (25399 +40779) (25400 31146) (25401 31150) (25402 31155) (25403 31161) (25404 31162) (25405 31177) (25406 +31189) (25407 31207) (25408 31212) (25409 31201) (25410 31203) (25411 31240) (25412 31245) (25413 +31256) (25414 31257) (25415 31264) (25416 31263) (25417 31104) (25418 31281) (25419 31291) (25420 +31294) (25421 31287) (25422 31299) (25423 31319) (25424 31305) (25425 31329) (25426 31330) (25427 +31337) (25428 40861) (25429 31344) (25430 31353) (25431 31357) (25432 31368) (25433 31383) (25434 +31381) (25435 31384) (25436 31382) (25437 31401) (25438 31432) (25439 31408) (25440 31414) (25441 +31429) (25442 31428) (25443 31423) (25444 36995) (25445 31431) (25446 31434) (25447 31437) (25448 +31439) (25449 31445) (25450 31443) (25451 31449) (25452 31450) (25453 31453) (25454 31457) (25455 +31458) (25456 31462) (25457 31469) (25458 31472) (25459 31490) (25460 31503) (25461 31498) (25462 +31494) (25463 31539) (25464 31512) (25465 31513) (25466 31518) (25467 31541) (25468 31528) (25469 +31542) (25470 31568) (25633 31610) (25634 31492) (25635 31565) (25636 31499) (25637 31564) (25638 +31557) (25639 31605) (25640 31589) (25641 31604) (25642 31591) (25643 31600) (25644 31601) (25645 +31596) (25646 31598) (25647 31645) (25648 31640) (25649 31647) (25650 31629) (25651 31644) (25652 +31642) (25653 31627) (25654 31634) (25655 31631) (25656 31581) (25657 31641) (25658 31691) (25659 +31681) (25660 31692) (25661 31695) (25662 31668) (25663 31686) (25664 31709) (25665 31721) (25666 +31761) (25667 31764) (25668 31718) (25669 31717) (25670 31840) (25671 31744) (25672 31751) (25673 +31763) (25674 31731) (25675 31735) (25676 31767) (25677 31757) (25678 31734) (25679 31779) (25680 +31783) (25681 31786) (25682 31775) (25683 31799) (25684 31787) (25685 31805) (25686 31820) (25687 +31811) (25688 31828) (25689 31823) (25690 31808) (25691 31824) (25692 31832) (25693 31839) (25694 +31844) (25695 31830) (25696 31845) (25697 31852) (25698 31861) (25699 31875) (25700 31888) (25701 +31908) (25702 31917) (25703 31906) (25704 31915) (25705 31905) (25706 31912) (25707 31923) (25708 +31922) (25709 31921) (25710 31918) (25711 31929) (25712 31933) (25713 31936) (25714 31941) (25715 +31938) (25716 31960) (25717 31954) (25718 31964) (25719 31970) (25720 39739) (25721 31983) (25722 +31986) (25723 31988) (25724 31990) (25725 31994) (25726 32006) (25889 32002) (25890 32028) (25891 +32021) (25892 32010) (25893 32069) (25894 32075) (25895 32046) (25896 32050) (25897 32063) (25898 +32053) (25899 32070) (25900 32115) (25901 32086) (25902 32078) (25903 32114) (25904 32104) (25905 +32110) (25906 32079) (25907 32099) (25908 32147) (25909 32137) (25910 32091) (25911 32143) (25912 +32125) (25913 32155) (25914 32186) (25915 32174) (25916 32163) (25917 32181) (25918 32199) (25919 +32189) (25920 32171) (25921 32317) (25922 32162) (25923 32175) (25924 32220) (25925 32184) (25926 +32159) (25927 32176) (25928 32216) (25929 32221) (25930 32228) (25931 32222) (25932 32251) (25933 +32242) (25934 32225) (25935 32261) (25936 32266) (25937 32291) (25938 32289) (25939 32274) (25940 +32305) (25941 32287) (25942 32265) (25943 32267) (25944 32290) (25945 32326) (25946 32358) (25947 +32315) (25948 32309) (25949 32313) (25950 32323) (25951 32311) (25952 32306) (25953 32314) (25954 +32359) (25955 32349) (25956 32342) (25957 32350) (25958 32345) (25959 32346) (25960 32377) (25961 +32362) (25962 32361) (25963 32380) (25964 32379) (25965 32387) (25966 32213) (25967 32381) (25968 +36782) (25969 32383) (25970 32392) (25971 32393) (25972 32396) (25973 32402) (25974 32400) (25975 +32403) (25976 32404) (25977 32406) (25978 32398) (25979 32411) (25980 32412) (25981 32568) (25982 +32570) (26145 32581) (26146 32588) (26147 32589) (26148 32590) (26149 32592) (26150 32593) (26151 +32597) (26152 32596) (26153 32600) (26154 32607) (26155 32608) (26156 32616) (26157 32617) (26158 +32615) (26159 32632) (26160 32642) (26161 32646) (26162 32643) (26163 32648) (26164 32647) (26165 +32652) (26166 32660) (26167 32670) (26168 32669) (26169 32666) (26170 32675) (26171 32687) (26172 +32690) (26173 32697) (26174 32686) (26175 32694) (26176 32696) (26177 35697) (26178 32709) (26179 +32710) (26180 32714) (26181 32725) (26182 32724) (26183 32737) (26184 32742) (26185 32745) (26186 +32755) (26187 32761) (26188 39132) (26189 32774) (26190 32772) (26191 32779) (26192 32786) (26193 +32792) (26194 32793) (26195 32796) (26196 32801) (26197 32808) (26198 32831) (26199 32827) (26200 +32842) (26201 32838) (26202 32850) (26203 32856) (26204 32858) (26205 32863) (26206 32866) (26207 +32872) (26208 32883) (26209 32882) (26210 32880) (26211 32886) (26212 32889) (26213 32893) (26214 +32895) (26215 32900) (26216 32902) (26217 32901) (26218 32923) (26219 32915) (26220 32922) (26221 +32941) (26222 20880) (26223 32940) (26224 32987) (26225 32997) (26226 32985) (26227 32989) (26228 +32964) (26229 32986) (26230 32982) (26231 33033) (26232 33007) (26233 33009) (26234 33051) (26235 +33065) (26236 33059) (26237 33071) (26238 33099) (26401 38539) (26402 33094) (26403 33086) (26404 +33107) (26405 33105) (26406 33020) (26407 33137) (26408 33134) (26409 33125) (26410 33126) (26411 +33140) (26412 33155) (26413 33160) (26414 33162) (26415 33152) (26416 33154) (26417 33184) (26418 +33173) (26419 33188) (26420 33187) (26421 33119) (26422 33171) (26423 33193) (26424 33200) (26425 +33205) (26426 33214) (26427 33208) (26428 33213) (26429 33216) (26430 33218) (26431 33210) (26432 +33225) (26433 33229) (26434 33233) (26435 33241) (26436 33240) (26437 33224) (26438 33242) (26439 +33247) (26440 33248) (26441 33255) (26442 33274) (26443 33275) (26444 33278) (26445 33281) (26446 +33282) (26447 33285) (26448 33287) (26449 33290) (26450 33293) (26451 33296) (26452 33302) (26453 +33321) (26454 33323) (26455 33336) (26456 33331) (26457 33344) (26458 33369) (26459 33368) (26460 +33373) (26461 33370) (26462 33375) (26463 33380) (26464 33378) (26465 33384) (26466 33386) (26467 +33387) (26468 33326) (26469 33393) (26470 33399) (26471 33400) (26472 33406) (26473 33421) (26474 +33426) (26475 33451) (26476 33439) (26477 33467) (26478 33452) (26479 33505) (26480 33507) (26481 +33503) (26482 33490) (26483 33524) (26484 33523) (26485 33530) (26486 33683) (26487 33539) (26488 +33531) (26489 33529) (26490 33502) (26491 33542) (26492 33500) (26493 33545) (26494 33497) (26657 +33589) (26658 33588) (26659 33558) (26660 33586) (26661 33585) (26662 33600) (26663 33593) (26664 +33616) (26665 33605) (26666 33583) (26667 33579) (26668 33559) (26669 33560) (26670 33669) (26671 +33690) (26672 33706) (26673 33695) (26674 33698) (26675 33686) (26676 33571) (26677 33678) (26678 +33671) (26679 33674) (26680 33660) (26681 33717) (26682 33651) (26683 33653) (26684 33696) (26685 +33673) (26686 33704) (26687 33780) (26688 33811) (26689 33771) (26690 33742) (26691 33789) (26692 +33795) (26693 33752) (26694 33803) (26695 33729) (26696 33783) (26697 33799) (26698 33760) (26699 +33778) (26700 33805) (26701 33826) (26702 33824) (26703 33725) (26704 33848) (26705 34054) (26706 +33787) (26707 33901) (26708 33834) (26709 33852) (26710 34138) (26711 33924) (26712 33911) (26713 +33899) (26714 33965) (26715 33902) (26716 33922) (26717 33897) (26718 33862) (26719 33836) (26720 +33903) (26721 33913) (26722 33845) (26723 33994) (26724 33890) (26725 33977) (26726 33983) (26727 +33951) (26728 34009) (26729 33997) (26730 33979) (26731 34010) (26732 34000) (26733 33985) (26734 +33990) (26735 34006) (26736 33953) (26737 34081) (26738 34047) (26739 34036) (26740 34071) (26741 +34072) (26742 34092) (26743 34079) (26744 34069) (26745 34068) (26746 34044) (26747 34112) (26748 +34147) (26749 34136) (26750 34120) (26913 34113) (26914 34306) (26915 34123) (26916 34133) (26917 +34176) (26918 34212) (26919 34184) (26920 34193) (26921 34186) (26922 34216) (26923 34157) (26924 +34196) (26925 34203) (26926 34282) (26927 34183) (26928 34204) (26929 34167) (26930 34174) (26931 +34192) (26932 34249) (26933 34234) (26934 34255) (26935 34233) (26936 34256) (26937 34261) (26938 +34269) (26939 34277) (26940 34268) (26941 34297) (26942 34314) (26943 34323) (26944 34315) (26945 +34302) (26946 34298) (26947 34310) (26948 34338) (26949 34330) (26950 34352) (26951 34367) (26952 +34381) (26953 20053) (26954 34388) (26955 34399) (26956 34407) (26957 34417) (26958 34451) (26959 +34467) (26960 34473) (26961 34474) (26962 34443) (26963 34444) (26964 34486) (26965 34479) (26966 +34500) (26967 34502) (26968 34480) (26969 34505) (26970 34851) (26971 34475) (26972 34516) (26973 +34526) (26974 34537) (26975 34540) (26976 34527) (26977 34523) (26978 34543) (26979 34578) (26980 +34566) (26981 34568) (26982 34560) (26983 34563) (26984 34555) (26985 34577) (26986 34569) (26987 +34573) (26988 34553) (26989 34570) (26990 34612) (26991 34623) (26992 34615) (26993 34619) (26994 +34597) (26995 34601) (26996 34586) (26997 34656) (26998 34655) (26999 34680) (27000 34636) (27001 +34638) (27002 34676) (27003 34647) (27004 34664) (27005 34670) (27006 34649) (27169 34643) (27170 +34659) (27171 34666) (27172 34821) (27173 34722) (27174 34719) (27175 34690) (27176 34735) (27177 +34763) (27178 34749) (27179 34752) (27180 34768) (27181 38614) (27182 34731) (27183 34756) (27184 +34739) (27185 34759) (27186 34758) (27187 34747) (27188 34799) (27189 34802) (27190 34784) (27191 +34831) (27192 34829) (27193 34814) (27194 34806) (27195 34807) (27196 34830) (27197 34770) (27198 +34833) (27199 34838) (27200 34837) (27201 34850) (27202 34849) (27203 34865) (27204 34870) (27205 +34873) (27206 34855) (27207 34875) (27208 34884) (27209 34882) (27210 34898) (27211 34905) (27212 +34910) (27213 34914) (27214 34923) (27215 34945) (27216 34942) (27217 34974) (27218 34933) (27219 +34941) (27220 34997) (27221 34930) (27222 34946) (27223 34967) (27224 34962) (27225 34990) (27226 +34969) (27227 34978) (27228 34957) (27229 34980) (27230 34992) (27231 35007) (27232 34993) (27233 +35011) (27234 35012) (27235 35028) (27236 35032) (27237 35033) (27238 35037) (27239 35065) (27240 +35074) (27241 35068) (27242 35060) (27243 35048) (27244 35058) (27245 35076) (27246 35084) (27247 +35082) (27248 35091) (27249 35139) (27250 35102) (27251 35109) (27252 35114) (27253 35115) (27254 +35137) (27255 35140) (27256 35131) (27257 35126) (27258 35128) (27259 35148) (27260 35101) (27261 +35168) (27262 35166) (27425 35174) (27426 35172) (27427 35181) (27428 35178) (27429 35183) (27430 +35188) (27431 35191) (27432 35198) (27433 35203) (27434 35208) (27435 35210) (27436 35219) (27437 +35224) (27438 35233) (27439 35241) (27440 35238) (27441 35244) (27442 35247) (27443 35250) (27444 +35258) (27445 35261) (27446 35263) (27447 35264) (27448 35290) (27449 35292) (27450 35293) (27451 +35303) (27452 35316) (27453 35320) (27454 35331) (27455 35350) (27456 35344) (27457 35340) (27458 +35355) (27459 35357) (27460 35365) (27461 35382) (27462 35393) (27463 35419) (27464 35410) (27465 +35398) (27466 35400) (27467 35452) (27468 35437) (27469 35436) (27470 35426) (27471 35461) (27472 +35458) (27473 35460) (27474 35496) (27475 35489) (27476 35473) (27477 35493) (27478 35494) (27479 +35482) (27480 35491) (27481 35524) (27482 35533) (27483 35522) (27484 35546) (27485 35563) (27486 +35571) (27487 35559) (27488 35556) (27489 35569) (27490 35604) (27491 35552) (27492 35554) (27493 +35575) (27494 35550) (27495 35547) (27496 35596) (27497 35591) (27498 35610) (27499 35553) (27500 +35606) (27501 35600) (27502 35607) (27503 35616) (27504 35635) (27505 38827) (27506 35622) (27507 +35627) (27508 35646) (27509 35624) (27510 35649) (27511 35660) (27512 35663) (27513 35662) (27514 +35657) (27515 35670) (27516 35675) (27517 35674) (27518 35691) (27681 35679) (27682 35692) (27683 +35695) (27684 35700) (27685 35709) (27686 35712) (27687 35724) (27688 35726) (27689 35730) (27690 +35731) (27691 35734) (27692 35737) (27693 35738) (27694 35898) (27695 35905) (27696 35903) (27697 +35912) (27698 35916) (27699 35918) (27700 35920) (27701 35925) (27702 35938) (27703 35948) (27704 +35960) (27705 35962) (27706 35970) (27707 35977) (27708 35973) (27709 35978) (27710 35981) (27711 +35982) (27712 35988) (27713 35964) (27714 35992) (27715 25117) (27716 36013) (27717 36010) (27718 +36029) (27719 36018) (27720 36019) (27721 36014) (27722 36022) (27723 36040) (27724 36033) (27725 +36068) (27726 36067) (27727 36058) (27728 36093) (27729 36090) (27730 36091) (27731 36100) (27732 +36101) (27733 36106) (27734 36103) (27735 36111) (27736 36109) (27737 36112) (27738 40782) (27739 +36115) (27740 36045) (27741 36116) (27742 36118) (27743 36199) (27744 36205) (27745 36209) (27746 +36211) (27747 36225) (27748 36249) (27749 36290) (27750 36286) (27751 36282) (27752 36303) (27753 +36314) (27754 36310) (27755 36300) (27756 36315) (27757 36299) (27758 36330) (27759 36331) (27760 +36319) (27761 36323) (27762 36348) (27763 36360) (27764 36361) (27765 36351) (27766 36381) (27767 +36382) (27768 36368) (27769 36383) (27770 36418) (27771 36405) (27772 36400) (27773 36404) (27774 +36426) (27937 36423) (27938 36425) (27939 36428) (27940 36432) (27941 36424) (27942 36441) (27943 +36452) (27944 36448) (27945 36394) (27946 36451) (27947 36437) (27948 36470) (27949 36466) (27950 +36476) (27951 36481) (27952 36487) (27953 36485) (27954 36484) (27955 36491) (27956 36490) (27957 +36499) (27958 36497) (27959 36500) (27960 36505) (27961 36522) (27962 36513) (27963 36524) (27964 +36528) (27965 36550) (27966 36529) (27967 36542) (27968 36549) (27969 36552) (27970 36555) (27971 +36571) (27972 36579) (27973 36604) (27974 36603) (27975 36587) (27976 36606) (27977 36618) (27978 +36613) (27979 36629) (27980 36626) (27981 36633) (27982 36627) (27983 36636) (27984 36639) (27985 +36635) (27986 36620) (27987 36646) (27988 36659) (27989 36667) (27990 36665) (27991 36677) (27992 +36674) (27993 36670) (27994 36684) (27995 36681) (27996 36678) (27997 36686) (27998 36695) (27999 +36700) (28000 36706) (28001 36707) (28002 36708) (28003 36764) (28004 36767) (28005 36771) (28006 +36781) (28007 36783) (28008 36791) (28009 36826) (28010 36837) (28011 36834) (28012 36842) (28013 +36847) (28014 36999) (28015 36852) (28016 36869) (28017 36857) (28018 36858) (28019 36881) (28020 +36885) (28021 36897) (28022 36877) (28023 36894) (28024 36886) (28025 36875) (28026 36903) (28027 +36918) (28028 36917) (28029 36921) (28030 36856) (28193 36943) (28194 36944) (28195 36945) (28196 +36946) (28197 36878) (28198 36937) (28199 36926) (28200 36950) (28201 36952) (28202 36958) (28203 +36968) (28204 36975) (28205 36982) (28206 38568) (28207 36978) (28208 36994) (28209 36989) (28210 +36993) (28211 36992) (28212 37002) (28213 37001) (28214 37007) (28215 37032) (28216 37039) (28217 +37041) (28218 37045) (28219 37090) (28220 37092) (28221 25160) (28222 37083) (28223 37122) (28224 +37138) (28225 37145) (28226 37170) (28227 37168) (28228 37194) (28229 37206) (28230 37208) (28231 +37219) (28232 37221) (28233 37225) (28234 37235) (28235 37234) (28236 37259) (28237 37257) (28238 +37250) (28239 37282) (28240 37291) (28241 37295) (28242 37290) (28243 37301) (28244 37300) (28245 +37306) (28246 37312) (28247 37313) (28248 37321) (28249 37323) (28250 37328) (28251 37334) (28252 +37343) (28253 37345) (28254 37339) (28255 37372) (28256 37365) (28257 37366) (28258 37406) (28259 +37375) (28260 37396) (28261 37420) (28262 37397) (28263 37393) (28264 37470) (28265 37463) (28266 +37445) (28267 37449) (28268 37476) (28269 37448) (28270 37525) (28271 37439) (28272 37451) (28273 +37456) (28274 37532) (28275 37526) (28276 37523) (28277 37531) (28278 37466) (28279 37583) (28280 +37561) (28281 37559) (28282 37609) (28283 37647) (28284 37626) (28285 37700) (28286 37678) (28449 +37657) (28450 37666) (28451 37658) (28452 37667) (28453 37690) (28454 37685) (28455 37691) (28456 +37724) (28457 37728) (28458 37756) (28459 37742) (28460 37718) (28461 37808) (28462 37804) (28463 +37805) (28464 37780) (28465 37817) (28466 37846) (28467 37847) (28468 37864) (28469 37861) (28470 +37848) (28471 37827) (28472 37853) (28473 37840) (28474 37832) (28475 37860) (28476 37914) (28477 +37908) (28478 37907) (28479 37891) (28480 37895) (28481 37904) (28482 37942) (28483 37931) (28484 +37941) (28485 37921) (28486 37946) (28487 37953) (28488 37970) (28489 37956) (28490 37979) (28491 +37984) (28492 37986) (28493 37982) (28494 37994) (28495 37417) (28496 38000) (28497 38005) (28498 +38007) (28499 38013) (28500 37978) (28501 38012) (28502 38014) (28503 38017) (28504 38015) (28505 +38274) (28506 38279) (28507 38282) (28508 38292) (28509 38294) (28510 38296) (28511 38297) (28512 +38304) (28513 38312) (28514 38311) (28515 38317) (28516 38332) (28517 38331) (28518 38329) (28519 +38334) (28520 38346) (28521 28662) (28522 38339) (28523 38349) (28524 38348) (28525 38357) (28526 +38356) (28527 38358) (28528 38364) (28529 38369) (28530 38373) (28531 38370) (28532 38433) (28533 +38440) (28534 38446) (28535 38447) (28536 38466) (28537 38476) (28538 38479) (28539 38475) (28540 +38519) (28541 38492) (28542 38494) (28705 38493) (28706 38495) (28707 38502) (28708 38514) (28709 +38508) (28710 38541) (28711 38552) (28712 38549) (28713 38551) (28714 38570) (28715 38567) (28716 +38577) (28717 38578) (28718 38576) (28719 38580) (28720 38582) (28721 38584) (28722 38585) (28723 +38606) (28724 38603) (28725 38601) (28726 38605) (28727 35149) (28728 38620) (28729 38669) (28730 +38613) (28731 38649) (28732 38660) (28733 38662) (28734 38664) (28735 38675) (28736 38670) (28737 +38673) (28738 38671) (28739 38678) (28740 38681) (28741 38692) (28742 38698) (28743 38704) (28744 +38713) (28745 38717) (28746 38718) (28747 38724) (28748 38726) (28749 38728) (28750 38722) (28751 +38729) (28752 38748) (28753 38752) (28754 38756) (28755 38758) (28756 38760) (28757 21202) (28758 +38763) (28759 38769) (28760 38777) (28761 38789) (28762 38780) (28763 38785) (28764 38778) (28765 +38790) (28766 38795) (28767 38799) (28768 38800) (28769 38812) (28770 38824) (28771 38822) (28772 +38819) (28773 38835) (28774 38836) (28775 38851) (28776 38854) (28777 38856) (28778 38859) (28779 +38876) (28780 38893) (28781 40783) (28782 38898) (28783 31455) (28784 38902) (28785 38901) (28786 +38927) (28787 38924) (28788 38968) (28789 38948) (28790 38945) (28791 38967) (28792 38973) (28793 +38982) (28794 38991) (28795 38987) (28796 39019) (28797 39023) (28798 39024) (28961 39025) (28962 +39028) (28963 39027) (28964 39082) (28965 39087) (28966 39089) (28967 39094) (28968 39108) (28969 +39107) (28970 39110) (28971 39145) (28972 39147) (28973 39171) (28974 39177) (28975 39186) (28976 +39188) (28977 39192) (28978 39201) (28979 39197) (28980 39198) (28981 39204) (28982 39200) (28983 +39212) (28984 39214) (28985 39229) (28986 39230) (28987 39234) (28988 39241) (28989 39237) (28990 +39248) (28991 39243) (28992 39249) (28993 39250) (28994 39244) (28995 39253) (28996 39319) (28997 +39320) (28998 39333) (28999 39341) (29000 39342) (29001 39356) (29002 39391) (29003 39387) (29004 +39389) (29005 39384) (29006 39377) (29007 39405) (29008 39406) (29009 39409) (29010 39410) (29011 +39419) (29012 39416) (29013 39425) (29014 39439) (29015 39429) (29016 39394) (29017 39449) (29018 +39467) (29019 39479) (29020 39493) (29021 39490) (29022 39488) (29023 39491) (29024 39486) (29025 +39509) (29026 39501) (29027 39515) (29028 39511) (29029 39519) (29030 39522) (29031 39525) (29032 +39524) (29033 39529) (29034 39531) (29035 39530) (29036 39597) (29037 39600) (29038 39612) (29039 +39616) (29040 39631) (29041 39633) (29042 39635) (29043 39636) (29044 39646) (29045 39647) (29046 +39650) (29047 39651) (29048 39654) (29049 39663) (29050 39659) (29051 39662) (29052 39668) (29053 +39665) (29054 39671) (29217 39675) (29218 39686) (29219 39704) (29220 39706) (29221 39711) (29222 +39714) (29223 39715) (29224 39717) (29225 39719) (29226 39720) (29227 39721) (29228 39722) (29229 +39726) (29230 39727) (29231 39730) (29232 39748) (29233 39747) (29234 39759) (29235 39757) (29236 +39758) (29237 39761) (29238 39768) (29239 39796) (29240 39827) (29241 39811) (29242 39825) (29243 +39830) (29244 39831) (29245 39839) (29246 39840) (29247 39848) (29248 39860) (29249 39872) (29250 +39882) (29251 39865) (29252 39878) (29253 39887) (29254 39889) (29255 39890) (29256 39907) (29257 +39906) (29258 39908) (29259 39892) (29260 39905) (29261 39994) (29262 39922) (29263 39921) (29264 +39920) (29265 39957) (29266 39956) (29267 39945) (29268 39955) (29269 39948) (29270 39942) (29271 +39944) (29272 39954) (29273 39946) (29274 39940) (29275 39982) (29276 39963) (29277 39973) (29278 +39972) (29279 39969) (29280 39984) (29281 40007) (29282 39986) (29283 40006) (29284 39998) (29285 +40026) (29286 40032) (29287 40039) (29288 40054) (29289 40056) (29290 40167) (29291 40172) (29292 +40176) (29293 40201) (29294 40200) (29295 40171) (29296 40195) (29297 40198) (29298 40234) (29299 +40230) (29300 40367) (29301 40227) (29302 40223) (29303 40260) (29304 40213) (29305 40210) (29306 +40257) (29307 40255) (29308 40254) (29309 40262) (29310 40264) (29473 40285) (29474 40286) (29475 +40292) (29476 40273) (29477 40272) (29478 40281) (29479 40306) (29480 40329) (29481 40327) (29482 +40363) (29483 40303) (29484 40314) (29485 40346) (29486 40356) (29487 40361) (29488 40370) (29489 +40388) (29490 40385) (29491 40379) (29492 40376) (29493 40378) (29494 40390) (29495 40399) (29496 +40386) (29497 40409) (29498 40403) (29499 40440) (29500 40422) (29501 40429) (29502 40431) (29503 +40445) (29504 40474) (29505 40475) (29506 40478) (29507 40565) (29508 40569) (29509 40573) (29510 +40577) (29511 40584) (29512 40587) (29513 40588) (29514 40594) (29515 40597) (29516 40593) (29517 +40605) (29518 40613) (29519 40617) (29520 40632) (29521 40618) (29522 40621) (29523 38753) (29524 +40652) (29525 40654) (29526 40655) (29527 40656) (29528 40660) (29529 40668) (29530 40670) (29531 +40669) (29532 40672) (29533 40677) (29534 40680) (29535 40687) (29536 40692) (29537 40694) (29538 +40695) (29539 40697) (29540 40699) (29541 40700) (29542 40701) (29543 40711) (29544 40712) (29545 +30391) (29546 40725) (29547 40737) (29548 40748) (29549 40766) (29550 40778) (29551 40786) (29552 +40788) (29553 40803) (29554 40799) (29555 40800) (29556 40801) (29557 40806) (29558 40807) (29559 +40812) (29560 40810) (29561 40823) (29562 40818) (29563 40822) (29564 40853) (29565 40860) (29566 +40864) (29740 13027) (29741 13024) (29742 13047) (29743 13030) (29744 12956) (29745 12957) (29746 +12960) (29747 12949) (29748 (22679 8413)) (29749 (28187 8413)) (29750 (22522 8413)) (29751 (35519 8413 +)) (29752 12957) (29753 12950) (29754 12953) (29755 12958) (29756 12938) (29757 12939) (29758 12940) ( +29759 12941) (29760 12848) (29761 12842) (29762 12843) (29763 12844) (29764 12845) (29765 12846) ( +29766 12847) (29767 12864) (29768 12855) (29769 12850) (29770 12851) (29771 12852) (29772 12853) ( +29773 12854) (29774 12856) (29775 12857) (29776 13182) (29777 13181) (29778 13180) (29779 13179) ( +29808 9332) (29809 9333) (29810 9334) (29811 9335) (29812 9336) (29813 9337) (29814 9338) (29815 9339) + (29816 9340) (29817 9341) (29818 9342) (29819 12292) (29857 12896) (29858 12897) (29859 12898) (29860 + 12899) (29861 12900) (29862 12901) (29863 12902) (29864 12903) (29865 12904) (29866 12905) (29867 +12906) (29868 12907) (29869 12908) (29870 12909) (29871 12910) (29872 12911) (29873 12912) (29874 +12913) (29875 12914) (29876 12915) (29877 12916) (29878 12917) (29879 12918) (29880 12919) (29881 +12920) (29882 12921) (29883 12922) (29884 12923) (29888 12800) (29889 12801) (29890 12802) (29891 +12803) (29892 12804) (29893 12805) (29894 12806) (29895 12807) (29896 12808) (29897 12809) (29898 +12810) (29899 12811) (29900 12812) (29901 12813) (29902 12814) (29903 12815) (29904 12816) (29905 +12817) (29906 12818) (29907 12819) (29908 12820) (29909 12821) (29910 12822) (29911 12823) (29912 +12824) (29913 12825) (29914 12826) (29915 12827) (29916 12828) (29921 9372) (29922 9373) (29923 9374) +(29924 9375) (29925 9376) (29926 9377) (29927 9378) (29928 9379) (29929 9380) (29930 9381) (29931 9382 +) (29932 9383) (29933 9384) (29934 9385) (29935 9386) (29936 9387) (29937 9388) (29938 9389) (29939 +9390) (29940 9391) (29941 9392) (29942 9393) (29943 9394) (29944 9395) (29945 9396) (29946 9397) ( +29947 9343) (29948 9344) (29949 9345) (29950 9346) (29985 23383) (29985 22575) (29986 24590) (29986 +27079) (29987 24555) (29987 36953) (29988 24107) (29988 29796) (29989 34389) (29989 20956) (29990 +30456) (29990 29081) (29991 27963) (29992 35242) (29993 28023) (29994 38651) (29995 27597) (29996 +26524) (29997 31435) (29998 21407) (29999 21512) (30000 26360) (30001 20837) (30002 20006) (30003 +24179) (30004 26989) (30005 22577) (30006 36523) (30007 24066) (30008 34987) (30009 35377) (30010 +35531) (30011 23569) (30012 38291) (30013 39636) (30014 20303) (30015 36554) (30016 36557) (30017 +37002) (30018 37325) (30019 21152) (30020 22294) (30021 25110) (30022 27425) (30023 27599) (30024 +32317) (30025 28779) (30026 25991) (30027 23401) (30028 19990) (30029 23433) (30030 25918) (30031 +27231) (30032 20839) (30033 38364) (30034 21033) (30035 20687) (30036 29702) (30037 27604) (30038 +24859) (30039 29579) (30040 21029) (30041 22827) (30042 33287) (30043 20809) (30044 33457) (30045 +33775) (30046 35506) (30047 32946) (30048 25925) (30049 24517) (30050 26781) (30051 23229) (30052 +24351) (30053 29238) (30054 36890) (30055 34920) (30056 37329) (30057 23531) (30058 24049) (30059 +25165) (30060 27827) (30061 30465) (30062 21488) (30063 27714) (30064 25910) (30065 33836) (30066 +19988) (30067 20309) (30068 20195) (30069 20849) (30070 21463) (30071 39080) (30072 27743) (30073 +25343) (30074 38627) (30075 30028) (30076 20449) (30077 26395) (30078 31354) (30113 27515) (30114 +29677) (30115 39340) (30116 26399) (30117 38750) (30118 27193) (30119 21450) (30120 32080) (30121 +34399) (30122 24118) (30123 20803) (30124 20132) (30125 35442) (30126 26410) (30127 32681) (30128 +24220) (30129 23436) (30130 35542) (30131 37666) (30132 39131) (30133 21629) (30134 24373) (30135 +21729) (30136 25976) (30137 26519) (30138 25509) (30139 23616) (30140 21451) (30141 21916) (30142 +28165) (30143 27915) (30144 27138) (30145 23130) (30146 31038) (30147 26089) (30148 24067) (30149 +26997) (30150 30524) (30151 21966) (30152 29986) (30153 21578) (30154 21733) (30155 33288) (30156 +21214) (30157 37941) (30158 21462) (30159 31639) (30160 26356) (30161 20853) (30162 36896) (30163 +31572) (30164 25214) (30165 32631) (30166 22833) (30167 36939) (30168 24418) (30169 26131) (30170 +32675) (30171 24230) (30172 21322) (30173 34915) (30174 33509) (30175 33267) (30176 35696) (30177 +36817) (30178 29031) (30179 35722) (30180 22992) (30181 26381) (30182 21063) (30183 39006) (30184 +33521) (30185 29699) (30186 21315) (30187 24448) (30188 35611) (30189 35336) (30190 25136) (30191 +26408) (30192 31505) (30193 21151) (30194 33289) (30195 36319) (30196 31070) (30197 27770) (30198 +27969) (30199 29105) (30200 21531) (30201 31350) (30202 32004) (30203 38587) (30204 30452) (30205 +21476) (30206 40643) (30256 (48 8415)) (30257 (49 8415)) (30258 (50 8415)) (30259 (51 8415)) (30260 ( +52 8415)) (30261 (53 8415)) (30262 (54 8415)) (30263 (55 8415)) (30264 (56 8415)) (30265 (57 8415)) ( +30273 9398) (30274 9399) (30275 9400) (30276 9401) (30277 9402) (30278 9403) (30279 9404) (30280 9405) + (30281 9406) (30282 9407) (30283 9408) (30284 9409) (30285 9410) (30286 9411) (30287 9412) (30288 +9413) (30289 9414) (30290 9415) (30291 9416) (30292 9417) (30293 9418) (30294 9419) (30295 9420) ( +30296 9421) (30297 9422) (30298 9423) (30299 9322) (30300 9323) (30301 9324) (30302 9325) (30303 9326) + (30305 9424) (30306 9425) (30307 9426) (30308 9427) (30309 9428) (30310 9429) (30311 9430) (30312 +9431) (30313 9432) (30314 9433) (30315 9434) (30316 9435) (30317 9436) (30318 9437) (30319 9438) ( +30320 9439) (30321 9440) (30322 9441) (30323 9442) (30324 9443) (30325 9444) (30326 9445) (30327 9446) + (30328 9447) (30329 9448) (30330 9449) (30331 9327) (30332 9328) (30333 9329) (30334 9330) (30395 +9331) (30396 9450) (57381 1642) (57388 1548) (57390 1748) (57392 1632) (57393 1633) (57394 1634) ( +57395 1635) (57396 1636) (57397 1637) (57398 1638) (57399 1639) (57400 1640) (57401 1641) (57403 1563) + (57407 1567) (57409 1569) (57410 1570) (57411 1571) (57412 1572) (57413 1573) (57414 1574) (57415 +1575) (57416 1576) (57417 1577) (57418 1578) (57419 1579) (57420 1580) (57421 1581) (57422 1582) ( +57423 1583) (57424 1584) (57425 1585) (57426 1586) (57427 1587) (57428 1588) (57429 1589) (57430 1590) + (57431 1591) (57432 1592) (57433 1593) (57434 1594) (57440 1600) (57441 1601) (57442 1602) (57443 +1603) (57444 1604) (57445 1605) (57446 1606) (57447 1607) (57448 1608) (57449 1609) (57450 1610) ( +57451 1611) (57452 1612) (57453 1613) (57454 1614) (57455 1615) (57456 1616) (57457 1617) (57458 1618) + (57459 1648) (57460 1649) (57461 1643) (57462 1644) (57505 1700) (57506 1662) (57507 1670) (57508 +1688) (57509 1711) (57510 1728) (57511 1657) (57512 1672) (57513 1681) (57514 1722) (57515 1726) ( +57516 1729) (57517 1731) (57518 1730) (57519 1746) (57521 1660) (57522 1665) (57523 1669) (57524 1673) + (57525 1683) (57526 1686) (57527 1690) (57528 1724) (57529 1744) (57530 1741) (57531 1650) (57532 +1651) (57533 1747) (57534 1749) (57535 64467) (57536 1735) (57537 1734) (57538 1736) (57539 64477) ( +57540 1739) (57541 1733) (57542 1737) (57543 1652) (57544 1653) (57545 1654) (57546 1666) (57547 1655) + (57548 1656) (57549 1661) (57550 1674) (57551 1675) (57552 1707) (57553 1679) (57554 1680) (57555 +1740) (57556 1659) (57557 1664) (57558 1658) (57559 1663) (57560 1702) (57561 1668) (57562 1667) ( +57563 1671) (57564 1677) (57565 1676) (57566 1678) (57567 1705) (57568 1715) (57569 1713) (57570 1723) + (57571 1682) (57572 1684) (57573 1685) (57574 1687) (57575 1689) (57576 1691) (57577 1692) (57578 +1693) (57579 1694) (57580 1695) (57581 1696) (57582 1697) (57583 1698) (57584 1699) (57585 1701) ( +57586 1703) (57587 1704) (57588 1706) (57589 1708) (57590 1709) (57592 1710) (57593 1712) (57594 1714) + (57595 1716) (57596 8206) (57597 8207) (57598 8205) (57634 1438) (57636 8362) (57639 1436) (57644 44) + (57645 8209) (57658 1475) (57659 59) (57664 1488) (57665 1489) (57666 1490) (57667 1491) (57668 1492) + (57669 1493) (57670 1494) (57671 1495) (57672 1496) (57673 1497) (57674 1498) (57675 1499) (57676 +1500) (57677 1501) (57678 1502) (57679 1503) (57680 1504) (57681 1505) (57682 1506) (57683 1507) ( +57684 1508) (57685 1509) (57686 1510) (57687 1511) (57688 1512) (57689 1513) (57690 1514) (57691 64305 +) (57692 64315) (57693 64324) (57694 64298) (57695 64299) (57696 64300) (57697 64301) (57698 64302) ( +57699 64303) (57700 64331) (57701 64332) (57702 64333) (57703 64334) (57704 64335) (57705 64287) ( +57706 64288) (57707 64289) (57708 64290) (57709 64291) (57710 64292) (57711 64293) (57712 64294) ( +57713 64295) (57714 64296) (57715 64297) (57716 1520) (57717 1521) (57718 1522) (57719 64304) (57720 +64306) (57721 64307) (57722 64308) (57723 64309) (57724 64310) (57725 64312) (57726 64313) (57761 +64314) (57762 64316) (57763 64318) (57764 64320) (57765 64321) (57766 64323) (57767 64326) (57768 +64327) (57769 64328) (57770 64329) (57771 64330) (57793 1460) (57794 1461) (57795 1462) (57796 1467) ( +57797 1464) (57798 1463) (57799 1456) (57800 1458) (57801 1457) (57802 1459) (57803 1474) (57804 1473) + (57806 1465) (57807 1468) (57839 1469) (57840 64286) (57841 1471) (57842 1472) (57889 776) (57890 771 +) (57891 774) (57892 775) (57893 865) (57894 820) (57895 801) (57896 802) (57897 805) (57898 812) ( +57899 804) (57900 810) (57901 811) (57902 809) (57903 797) (57904 803) (57905 798) (57906 796) (57907 +799) (57908 800) (57909 860) (57910 724) (57911 725) (57912 (32 799)) (57913 (32 800)) (57914 720) ( +57915 721) (57916 825) (57917 796) (57918 712) (57919 716) (57920 772) (57921 817) (57922 769) (57923 +791) (57924 768) (57925 790) (57926 770) (57927 780) (57928 788) (57929 787) (57930 702) (57937 105) ( +57938 121) (57939 617) (57940 618) (57941 655) (57942 101) (57943 248) (57944 603) (57945 339) (57946 +230) (57947 97) (57948 630) (57949 616) (57950 649) (57951 601) (57952 602) (57953 629) (57954 604) ( +57955 592) (57956 623) (57957 117) (57958 631) (57959 650) (57960 612) (57961 111) (57962 652) (57963 +596) (57964 593) (57965 594) (57966 600) (57967 605) (57968 606) (57969 639) (57970 645) (57971 666) ( +57980 644) (57981 619) (57982 608) (58017 109) (58018 112) (58019 98) (58020 632) (58021 946) (58022 +613) (58023 653) (58024 119) (58025 595) (58026 664) (58027 625) (58028 102) (58029 118) (58030 651) ( +58031 110) (58032 116) (58033 100) (58034 952) (58035 240) (58036 446) (58037 443) (58038 115) (58039 +122) (58040 963) (58041 397) (58042 633) (58043 620) (58044 622) (58045 108) (58046 636) (58047 634) ( +58048 114) (58049 638) (58050 599) (58051 647) (58052 663) (58053 662) (58054 627) (58055 648) (58056 +598) (58057 642) (58058 656) (58059 635) (58060 621) (58061 637) (58062 597) (58063 657) (58064 643) ( +58065 658) (58066 646) (58067 659) (58068 426) (58069 442) (58070 615) (58071 626) (58072 99) (58073 +607) (58074 231) (58075 669) (58076 654) (58077 331) (58078 107) (58079 609) (58080 120) (58081 611) ( +58082 624) (58083 608) (58084 628) (58085 414) (58086 113) (58087 610) (58088 967) (58089 641) (58090 +640) (58091 295) (58092 661) (58093 660) (58094 104) (58095 614) (58096 665) (58097 667) (58098 668) ( +58099 669) (58100 670) (58101 671) (58102 672) (58103 673) (58104 674) (58105 675) (58106 676) (58107 +677) (58108 678) (58109 679) (58110 680) (58146 12645) (58147 12646) (58148 12647) (58149 12648) ( +58150 12649) (58151 12650) (58152 12651) (58153 12652) (58154 12653) (58155 12654) (58156 12655) ( +58157 12656) (58158 12657) (58159 12658) (58160 12659) (58161 12660) (58162 12661) (58163 12662) ( +58164 12663) (58165 12664) (58166 12665) (58167 12666) (58168 12667) (58169 12668) (58170 12669) ( +58171 12670) (58172 12671) (58173 12672) (58174 12673) (58175 12674) (58176 12675) (58177 12676) ( +58178 12677) (58179 12678) (58180 12679) (58181 12680) (58182 12681) (58183 12682) (58184 12683) ( +58185 12684) (58186 12685) (58187 12686) (58273 32) (58274 8361) (58305 4352) (58306 4353) (58307 4522 +) (58308 4354) (58309 4524) (58310 4525) (58311 4355) (58312 4356) (58313 4357) (58314 4528) (58315 +4529) (58316 4530) (58317 4531) (58318 4532) (58319 4533) (58320 4534) (58321 4358) (58322 4359) ( +58323 4360) (58324 4537) (58325 4361) (58326 4362) (58327 4363) (58328 4364) (58329 4365) (58330 4366) + (58331 4367) (58332 4368) (58333 4369) (58334 4370) (58335 (49324 8414)) (58338 4449) (58339 4450) ( +58340 4451) (58341 4452) (58342 4453) (58343 4454) (58346 4455) (58347 4456) (58348 4457) (58349 4458) + (58350 4459) (58351 4460) (58354 4461) (58355 4462) (58356 4463) (58357 4464) (58358 4465) (58359 +4466) (58362 4467) (58363 4468) (58364 4469) (58365 (47784 8414)) (58401 4304) (58402 4305) (58403 +4306) (58404 4307) (58405 4308) (58406 4309) (58407 4310) (58408 4337) (58409 4311) (58410 4312) ( +58411 4313) (58412 4314) (58413 4315) (58414 4316) (58415 4338) (58416 4317) (58417 4318) (58418 4319) + (58419 4320) (58420 4321) (58421 4322) (58422 4323) (58423 4339) (58424 4324) (58425 4325) (58426 +4326) (58427 4327) (58428 4328) (58429 4329) (58430 4330) (58431 4331) (58432 4332) (58433 4333) ( +58434 4334) (58435 4340) (58436 4335) (58437 4336) (58438 4341) (58439 4342) (58446 1417) (58447 4347) + (58449 4256) (58450 4257) (58451 4258) (58452 4259) (58453 4260) (58454 4261) (58455 4262) (58456 +4289) (58457 4263) (58458 4264) (58459 4265) (58460 4266) (58461 4267) (58462 4268) (58463 4290) ( +58464 4269) (58465 4270) (58466 4271) (58467 4272) (58468 4273) (58469 4274) (58470 4275) (58471 4291) + (58472 4276) (58473 4277) (58474 4278) (58475 4279) (58476 4280) (58477 4281) (58478 4282) (58479 +4283) (58480 4284) (58481 4285) (58482 4286) (58483 4292) (58484 4287) (58485 4288) (58486 4293) ( +58529 1329) (58530 1330) (58531 1331) (58532 1332) (58533 1333) (58534 1334) (58535 1335) (58536 1336) + (58537 1337) (58538 1338) (58539 1339) (58540 1340) (58541 1341) (58542 1342) (58543 1343) (58544 +1344) (58545 1345) (58546 1346) (58547 1347) (58548 1348) (58549 1349) (58550 1350) (58551 1351) ( +58552 1352) (58553 1353) (58554 1354) (58555 1355) (58556 1356) (58557 1357) (58558 1358) (58559 1359) + (58560 1360) (58561 1361) (58562 1362) (58563 1363) (58564 1364) (58565 1365) (58566 1366) (58569 +1369) (58570 1417) (58571 1370) (58572 1371) (58573 1372) (58574 1373) (58575 1374) (58576 1375) ( +58577 1377) (58578 1378) (58579 1379) (58580 1380) (58581 1381) (58582 1382) (58583 1383) (58584 1384) + (58585 1385) (58586 1386) (58587 1387) (58588 1388) (58589 1389) (58590 1390) (58591 1391) (58592 +1392) (58593 1393) (58594 1394) (58595 1395) (58596 1396) (58597 1397) (58598 1398) (58599 1399) ( +58600 1400) (58601 1401) (58602 1402) (58603 1403) (58604 1404) (58605 1405) (58606 1406) (58607 1407) + (58608 1408) (58609 1409) (58610 1410) (58611 1411) (58612 1412) (58613 1413) (58614 1414) (58616 +64275) (58617 64276) (58618 64277) (58619 64278) (58620 64279) (58622 1415) (58657 2406) (58658 2407) +(58659 2408) (58660 2409) (58661 2410) (58662 2411) (58663 2412) (58664 2413) (58665 2414) (58666 2415 +) (58671 8360) (58736 2378) (58737 2385) (58738 2386) (58739 2387) (58740 2388) (58741 2405) (58785 +2305) (58786 2306) (58787 2307) (58788 2317) (58789 2309) (58790 2310) (58791 2311) (58792 2312) ( +58793 2313) (58794 2314) (58795 2315) (58796 2400) (58797 2316) (58798 2401) (58800 2319) (58801 2320) + (58802 2321) (58803 2322) (58804 2323) (58805 2324) (58807 2325) (58808 2392) (58809 2326) (58810 +2393) (58811 2327) (58812 2394) (58813 2328) (58814 2329) (58815 2330) (58816 2331) (58817 2332) ( +58818 2395) (58819 2333) (58820 2334) (58821 2335) (58822 2336) (58823 2337) (58824 2396) (58825 2338) + (58826 2397) (58827 2339) (58828 2340) (58829 2341) (58830 2342) (58831 2343) (58832 2344) (58833 +2345) (58834 2346) (58835 2347) (58836 2398) (58837 2348) (58838 2349) (58839 2350) (58840 2351) ( +58841 2399) (58842 2352) (58843 2353) (58844 2354) (58845 2355) (58846 2356) (58847 2357) (58848 2358) + (58849 2359) (58850 2360) (58851 2361) (58854 2366) (58855 2367) (58856 2368) (58857 2369) (58858 +2370) (58859 2371) (58860 2372) (58861 2402) (58862 2403) (58863 2364) (58864 2375) (58865 2376) ( +58866 2373) (58868 2379) (58869 2380) (58870 2374) (58871 2381) (58872 2416) (58873 2365) (58874 2384) + (58875 2404) (58876 2377) (58877 8360) (58878 2381) (58913 2534) (58914 2535) (58915 2536) (58916 +2537) (58917 2538) (58918 2539) (58919 2540) (58920 2541) (58921 2542) (58922 2543) (58928 2547) ( +58929 2548) (58930 2549) (58931 2550) (58932 2552) (58933 2546) (58934 2553) (58935 2551) (59041 2433) + (59042 2434) (59043 2435) (59045 2437) (59046 2438) (59047 2439) (59048 2440) (59049 2441) (59050 +2442) (59051 2443) (59052 2528) (59053 2444) (59054 2529) (59056 2447) (59057 2448) (59060 2451) ( +59061 2452) (59063 2453) (59065 2454) (59067 2455) (59069 2456) (59070 2457) (59071 2458) (59072 2459) + (59073 2460) (59075 2461) (59076 2462) (59077 2463) (59078 2464) (59079 2465) (59080 2524) (59081 +2466) (59082 2525) (59083 2467) (59084 2468) (59085 2469) (59086 2470) (59087 2471) (59088 2472) ( +59090 2474) (59091 2475) (59093 2476) (59094 2477) (59095 2478) (59096 2479) (59097 2527) (59098 2480) + (59099 2544) (59100 2482) (59103 2545) (59104 2486) (59105 2487) (59106 2488) (59107 2489) (59108 +2492) (59109 160) (59110 2494) (59111 2495) (59112 2496) (59113 2497) (59114 2498) (59115 2499) (59116 + 2500) (59117 2530) (59118 2531) (59120 2503) (59121 2504) (59124 2507) (59125 2508) (59127 2509) ( +59130 2554) (59131 2404) (59170 2562) (59173 2565) (59174 2566) (59175 2567) (59176 2568) (59177 2569) + (59178 2570) (59183 2575) (59184 2576) (59187 2579) (59188 2580) (59189 2581) (59190 2582) (59191 +2583) (59192 2584) (59193 2585) (59194 2586) (59195 2587) (59196 2588) (59197 2589) (59198 2590) ( +59199 2591) (59200 2592) (59201 2593) (59202 2594) (59203 2595) (59204 2596) (59205 2597) (59206 2598) + (59207 2599) (59208 2600) (59210 2602) (59211 2603) (59212 2604) (59213 2605) (59214 2606) (59215 +2607) (59216 2608) (59218 2610) (59219 2611) (59221 2613) (59222 2614) (59224 2616) (59225 2617) ( +59228 2620) (59230 2622) (59231 2623) (59232 2624) (59233 2625) (59234 2626) (59239 2631) (59240 2632) + (59243 2635) (59244 2636) (59245 2637) (59257 2649) (59258 2650) (59259 2651) (59260 2652) (59262 +2654) (59425 3585) (59426 3586) (59427 3587) (59428 3588) (59429 3589) (59430 3590) (59431 3591) ( +59432 3592) (59433 3593) (59434 3594) (59435 3595) (59436 3596) (59437 3597) (59438 3598) (59439 3599) + (59440 3600) (59441 3601) (59442 3602) (59443 3603) (59444 3604) (59445 3605) (59446 3606) (59447 +3607) (59448 3608) (59449 3609) (59450 3610) (59451 3611) (59452 3612) (59453 3613) (59454 3614) ( +59455 3615) (59456 3616) (59457 3617) (59458 3618) (59459 3619) (59460 3620) (59461 3621) (59462 3622) + (59463 3623) (59464 3624) (59465 3625) (59466 3626) (59467 3627) (59468 3628) (59469 3629) (59470 +3630) (59471 3631) (59472 3632) (59473 3633) (59474 3634) (59475 3635) (59476 3636) (59477 3637) ( +59478 3638) (59479 3639) (59480 3640) (59481 3641) (59482 3642) (59487 3647) (59488 3648) (59489 3649) + (59490 3650) (59491 3651) (59492 3652) (59493 3653) (59494 3654) (59495 3655) (59496 3656) (59497 +3657) (59498 3658) (59499 3659) (59500 3660) (59501 3661) (59502 3662) (59503 3663) (59504 3664) ( +59505 3665) (59506 3666) (59507 3667) (59508 3668) (59509 3669) (59510 3670) (59511 3671) (59512 3672) + (59513 3673) (59514 3674) (59515 3675) (59553 3713) (59554 3714) (59556 3716) (59559 3719) (59560 +3720) (59562 3722) (59565 3725) (59572 3732) (59573 3733) (59574 3734) (59575 3735) (59577 3737) ( +59578 3738) (59579 3739) (59580 3740) (59581 3741) (59582 3742) (59583 3743) (59585 3745) (59586 3746) + (59587 3747) (59589 3749) (59591 3751) (59594 3754) (59595 3755) (59597 3757) (59598 3758) (59599 +3759) (59600 3760) (59601 3761) (59602 3762) (59603 3763) (59604 3764) (59605 3765) (59606 3766) ( +59607 3767) (59608 3768) (59609 3769) (59611 3771) (59612 3772) (59613 3773) (59616 3776) (59617 3777) + (59618 3778) (59619 3779) (59620 3780) (59621 3773) (59622 3782) (59624 3784) (59625 3785) (59626 +3786) (59627 3787) (59628 3788) (59629 3789) (59632 3792) (59633 3793) (59634 3794) (59635 3795) ( +59636 3796) (59637 3797) (59638 3798) (59639 3799) (59640 3800) (59641 3801) (59644 3804) (59645 3805) + (60193 8473) (60194 8459) (60195 8464) (60196 8779) (60197 8860) (60198 8455) (60199 818) (60200 8253 +) (60201 8984) (60203 8460) (60205 120125) (60206 8645) (60207 8693) (60208 8674) (60209 8803) (60210 +8845) (60211 10941) (60212 10773) (60213 10774) (60214 8751) (60215 8752) (60219 9635) (60220 8259) ( +60221 8524) (60222 9878) (60223 8353) (60224 9608) (60225 9764) (60226 8456) (60228 9775) (60229 9785) + (60230 9855) (60231 9642) (60235 8985) (60236 9700) (60237 9701) (60238 9698) (60239 9699) (60240 +8533) (60241 8534) (60242 8535) (60243 8536) (60244 8537) (60245 8538) (60246 9833) (60249 8749) ( +60250 9702) (60254 8499) (60255 8981) (60262 8721) (60267 9632) (60268 9656) (60269 9666) (60270 8226) + (60271 8495) (60273 8472) (60275 8482) (60276 8482) (60279 9633) (60280 9643) (60281 9702) (60282 +8891) (60283 8493) (60284 8488) (60285 8359) (60326 9676) (60327 9645) (60328 9649) (60330 8480) ( +60331 8402) (60332 8403) (60334 8408) (60335 8410) (60336 8409) (60337 8404) (60338 8405) (60339 8825) + (60340 8824) (60343 8774) (60344 8892) (60345 8893) (60347 8716) (60348 8462) (60350 9769) (60351 +9747) (60353 8754) (60354 8755) (60355 8753) (60356 8887) (60357 8886) (60358 8766) (60359 8763) ( +60363 8669) (60364 8668) (60365 8967) (60368 8489) (60369 8554) (60370 8555) (60383 9694) (60384 9693) + (60385 9695) (60386 9692) (60450 9755) (60451 9754) (60453 9986) (60454 9988) (60455 9742) (60456 +10002) (60458 10003) (60459 65291) (60462 9733) (60463 9734) (60464 42) (60480 64) (60486 10008) ( +60490 9988) (60491 9743) (60492 10001) (60494 9989) (60496 64) (60497 9686) (60531 10133) (60535 9754) + (60600 9312) (60601 9313) (60602 9314) (60603 9315) (60604 9316) (60605 9317) (60606 9318) (60607 +9319) (60608 9320) (60609 9321) (60610 10112) (60611 10113) (60612 10114) (60613 10115) (60614 10116) +(60615 10117) (60616 10118) (60617 10119) (60618 10120) (60619 10121) (60620 10122) (60621 10123) ( +60622 10124) (60623 10125) (60624 10126) (60625 10127) (60626 10128) (60627 10129) (60628 10130) ( +60629 10131) (60640 9679) (60641 9685) (60642 9682) (60643 9681) (60644 9684) (60645 9675) (60661 9680 +) (60662 9683) (60663 10077) (60664 10078) (60665 10072) (60705 9985) (60706 9986) (60707 9987) (60708 + 9988) (60709 9742) (60710 9990) (60711 9991) (60712 9992) (60713 9993) (60714 9755) (60715 9758) ( +60716 9996) (60717 9997) (60718 9998) (60719 9999) (60720 10000) (60721 10001) (60722 10002) (60723 +10004) (60724 10005) (60725 10006) (60727 10008) (60728 10009) (60729 10010) (60730 10011) (60731 +10012) (60732 10013) (60733 10014) (60734 10015) (60735 10017) (60736 10018) (60737 10019) (60738 +10020) (60739 10021) (60740 10022) (60741 10023) (60742 10025) (60743 10026) (60744 10027) (60745 +10028) (60746 10029) (60747 10030) (60748 10031) (60749 10032) (60750 10033) (60751 10034) (60752 +10035) (60753 10036) (60754 10037) (60755 10038) (60756 10039) (60757 10040) (60758 10041) (60759 +10042) (60760 10043) (60761 10044) (60762 10045) (60763 10046) (60764 10047) (60765 10048) (60766 +10049) (60767 10050) (60768 10051) (60769 10052) (60770 10053) (60771 10054) (60772 10055) (60773 +10056) (60774 10057) (60775 10058) (60776 10059) (60777 10061) (60778 10063) (60779 10064) (60780 +10065) (60781 10066) (60782 10070) (60783 9687) (60784 10073) (60785 10074) (60786 10081) (60787 10082 +) (60788 10083) (60789 10084) (60790 10085) (60791 10086) (60792 10087) (60793 10102) (60794 10103) ( +60795 10104) (60796 10105) (60797 10106) (60798 10107) (60833 10108) (60834 10109) (60835 10110) ( +60836 10111) (60837 10132) (60838 10136) (60839 10137) (60840 10138) (60841 10139) (60842 10140) ( +60843 10141) (60844 10142) (60845 10143) (60846 10144) (60847 10146) (60848 10147) (60849 10148) ( +60850 10149) (60851 10150) (60852 10151) (60853 10152) (60854 10153) (60855 10154) (60856 10155) ( +60857 10156) (60858 10157) (60859 10158) (60860 10159) (60861 10161) (60862 10162) (60863 10163) ( +60864 10164) (60865 10165) (60866 10166) (60867 10167) (60868 10168) (60869 10169) (60870 10170) ( +60871 10171) (60872 10172) (60873 10173) (60874 10174) (60899 10075) (60900 10076) (60961 8196) (60962 + 8197) (60963 8202) (60964 8200) (60965 8231) (60966 8974) (60967 8975) (60968 8972) (60969 8973) ( +60970 9646) (60971 8724) (60972 1644) (60973 8722) (60974 1643) (60975 8463) (60976 8812) (60977 8448) + (60979 9743) (60980 8758) (60981 33) (60982 8870) (60983 9007) (60984 9008) (60985 437) (60986 8962) +(60987 8760) (60988 8726) (60989 8793) (60990 8794) (60991 8903) (60992 8454) (60993 9688) (60994 8782 +) (60995 8475) (60996 8466) (60997 8710) (60998 8977) (60999 8248) (61000 8452) (61001 9188) (61002 +9649) (61003 9005) (61004 8978) (61005 8979) (61006 9006) (61007 8982) (61008 8644) (61009 8661) ( +61010 8847) (61011 8848) (61012 402) (61013 9689) (61014 8898) (61015 8899) (61021 8987) (61024 9617) +(61025 9619) (61026 8914) (61027 8915) (61028 8762) (61031 8728) (61032 8770) (61033 8705) (61034 8976 +) (61035 8242) (61036 8822) (61037 8823) (61038 8818) (61039 8819) (61040 8868) (61041 8708) (61042 +8802) (61043 8968) (61044 8970) (61045 124) (61046 8969) (61047 8971) (61048 8778) (61049 8783) (61050 + 8252) (61051 8245) (61052 8739) (61053 8727) (61054 8764) (61089 8890) (61090 8228) (61091 8229) ( +61092 11157) (61093 11013) (61094 11014) (61095 11015) (61096 8680) (61097 8678) (61098 8679) (61099 +8681) (61100 8592) (61101 8593) (61102 8594) (61103 8595) (61104 9654) (61105 9664) (61106 9655) ( +61107 9665) (61108 8901) (61109 8597) (61110 8616) (61111 9074) (61112 9073) (61113 9608) (61114 9604) + (61115 9616) (61116 9612) (61117 9600) (61118 9668) (61119 9658) (61120 9067) (61121 9042) (61122 +9035) (61123 9021) (61124 9033) (61125 9055) (61126 9054) (61127 9017) (61128 9023) (61129 9024) ( +61130 8965) (61131 9828) (61132 9829) (61133 9830) (61134 9831) (61136 9038) (61137 9045) (61138 9053) + (61139 9014) (61140 9019) (61141 9835) (61142 8905) (61143 8906) (61144 8907) (61145 8908) (61146 +8966) (61147 8891) (61148 9015) (61149 8735) (61150 9644) (61151 9787) (61152 9131) (61153 9130) ( +61154 9132) (61155 9133) (61156 9127) (61157 9129) (61158 9128) (61159 9136) (61160 9137) (61161 8911) + (61162 8910) (61163 8884) (61164 8885) (61165 8992) (61166 8993) (61167 9130) (61168 9026) (61170 +8630) (61171 8631) (61172 8634) (61173 8635) (61174 8651) (61175 8602) (61176 8603) (61177 8622) ( +61178 8653) (61179 8655) (61180 8654) (61181 8909) (61182 8769) (61217 160) (61218 8209) (61219 173) ( +61220 8211) (61221 8212) (61222 8210) (61223 39) (61224 8222) (61225 8220) (61226 8249) (61227 8250) ( +61228 8192) (61229 8193) (61230 8199) (61231 8201) (61232 8224) (61233 8225) (61234 9001) (61235 9002) + (61236 9758) (61237 9756) (61238 8866) (61239 8867) (61240 8872) (61241 10980) (61242 12310) (61243 +12311) (61244 8598) (61245 8600) (61246 8599) (61247 8601) (61248 8453) (61249 8240) (61250 8810) ( +61251 8811) (61252 8814) (61253 8815) (61254 8739) (61255 8740) (61256 8741) (61257 8742) (61258 8712) + (61259 8713) (61260 8715) (61261 8656) (61262 8660) (61263 8658) (61264 8652) (61265 8646) (61266 +8596) (61267 8605) (61270 8745) (61271 8746) (61272 8839) (61273 8838) (61274 8835) (61275 8834) ( +61276 8841) (61277 8840) (61278 8837) (61279 8836) (61280 9746) (61281 8709) (61282 8853) (61283 8854) + (61284 8855) (61285 8856) (61286 8226) (61287 8728) (61288 8463) (61289 8467) (61290 172) (61291 166) + (61292 8736) (61293 8737) (61294 8759) (61295 8757) (61296 8869) (61297 8733) (61298 8801) (61299 +8784) (61300 8799) (61301 8747) (61302 8750) (61303 8771) (61304 8773) (61305 8776) (61306 8721) ( +61307 8719) (61308 8730) (61309 8723) (61310 9618) (61345 8354) (61346 402) (61347 8355) (61348 8359) +(61349 8352) (61350 36) (61351 8501) (61352 8470) (61353 8478) (61354 8481) (61355 658) (61356 8450) ( +61357 8469) (61358 8477) (61359 8484) (61360 8968) (61361 8969) (61362 8970) (61363 8971) (61364 8707) + (61365 8704) (61366 8896) (61367 8897) (61368 8718) (61369 8711) (61370 8706) (61371 9280) (61372 +9282) (61373 9281) (61374 9190) (61375 8215) (61376 8978) (61377 8544) (61378 8545) (61379 8546) ( +61380 8547) (61381 8548) (61382 8549) (61383 8550) (61384 8551) (61385 8552) (61386 8553) (61387 9824) + (61388 9825) (61389 9826) (61390 9827) (61391 10003) (61392 10007) (61393 9312) (61394 9313) (61395 +9314) (61396 9315) (61397 9316) (61398 9317) (61399 9318) (61400 9319) (61401 9320) (61402 9321) ( +61403 (8594 8413)) (61404 (8628 8413)) (61405 (8626 8413)) (61406 9774) (61407 9786) (61408 9760) ( +61409 9475) (61410 9473) (61411 9547) (61412 9474) (61413 9472) (61414 9532) (61415 9737) (61416 9789) + (61417 9790) (61418 9791) (61419 9795) (61420 9796) (61421 9797) (61422 9798) (61423 9799) (61424 +9810) (61425 9811) (61426 9800) (61427 9801) (61428 9802) (61429 9803) (61430 9804) (61431 9805) ( +61432 9806) (61433 9807) (61434 9808) (61435 9809) (61436 9742) (61437 8531) (61438 8532) (61473 64256 +) (61474 64259) (61475 64260) (61476 64257) (61477 64258) (61478 64261) (61479 (102 8205 106)) (61480 +(99 8205 116)) (61481 64262) (61552 188) (61553 189) (61554 190) (61555 8531) (61556 8532) (61557 8539 +) (61558 8540) (61559 8541) (61560 8542) (61561 8543) (61608 9227) (61609 9225) (61610 9226) (61611 +9228) (61612 9229) (61613 9252) (61616 9216) (61617 8196) (61618 8197) (61619 8198) (61620 8192) ( +61621 8193) (61622 8200) (61623 8200) (61624 8595) (61625 8594) (61626 8628) (61627 8609) (61628 8592) + (61629 8629) (61630 10550) (61635 8227) (61636 9679) (61639 65533) (61644 (42 773)) (61646 (59 773)) +(61666 10692) (61667 (8230 8414)) (61668 (8594 8414)) (61671 (57 8414)) (61673 (42 8414)) (61676 (43 +8414)) (61677 (45 8414)) (61678 (46 8414)) (61679 (44 8414)) (61686 (947 8414)) (61687 (1103 8414)) ( +61688 (12402 8414)) (61689 (12459 8414)) (61690 (28450 8414)) (61691 (21644 8414)) (61692 183) (61693 +384) (61694 9251) (61729 192) (61730 193) (61731 194) (61732 195) (61733 256) (61734 258) (61735 196) +(61736 197) (61737 260) (61738 262) (61739 264) (61740 266) (61741 199) (61742 268) (61743 270) (61744 + 200) (61745 201) (61746 202) (61747 274) (61748 278) (61749 203) (61750 280) (61751 282) (61752 500) +(61753 284) (61754 286) (61755 288) (61756 290) (61757 292) (61758 204) (61759 461) (61760 206) (61761 + 296) (61762 298) (61763 304) (61764 207) (61765 302) (61766 308) (61767 310) (61768 313) (61769 315) +(61770 317) (61771 323) (61772 209) (61773 325) (61774 327) (61775 210) (61776 211) (61777 212) (61778 + 213) (61779 332) (61780 214) (61781 336) (61782 340) (61783 342) (61784 344) (61785 346) (61786 348) +(61787 350) (61788 352) (61789 354) (61790 356) (61791 217) (61792 218) (61793 219) (61794 360) (61795 + 362) (61796 364) (61797 220) (61798 366) (61799 368) (61800 370) (61801 372) (61802 7922) (61803 221) + (61804 374) (61805 376) (61806 377) (61807 379) (61808 381) (61809 (76 789)) (61810 (84 789)) (61811 +(68 789)) (61812 7884) (61813 562) (61814 482) (61815 (338 772)) (61816 (256 774)) (61817 461) (61818 +276) (61819 (274 803)) (61820 (274 774)) (61821 486) (61822 300) (61857 224) (61858 225) (61859 226) ( +61860 227) (61861 257) (61862 259) (61863 228) (61864 229) (61865 261) (61866 263) (61867 265) (61868 +267) (61869 231) (61870 269) (61871 271) (61872 232) (61873 233) (61874 234) (61875 275) (61876 279) ( +61877 235) (61878 281) (61879 283) (61880 501) (61881 285) (61882 287) (61883 289) (61884 291) (61885 +293) (61886 236) (61887 237) (61888 238) (61889 297) (61890 299) (61892 239) (61893 303) (61894 309) ( +61895 311) (61896 314) (61897 316) (61898 318) (61899 324) (61900 241) (61901 326) (61902 328) (61903 +242) (61904 243) (61905 244) (61906 245) (61907 333) (61908 246) (61909 337) (61910 341) (61911 343) ( +61912 345) (61913 347) (61914 349) (61915 351) (61916 353) (61917 355) (61918 357) (61919 249) (61920 +250) (61921 251) (61922 361) (61923 363) (61924 365) (61925 252) (61926 367) (61927 369) (61928 371) ( +61929 373) (61930 7923) (61931 253) (61932 375) (61933 255) (61934 378) (61935 380) (61936 382) (61937 + (108 789)) (61938 (116 789)) (61939 (100 789)) (61940 7885) (61941 563) (61942 483) (61943 (339 772)) + (61944 (257 774)) (61945 462) (61946 277) (61947 (275 803)) (61948 (275 774)) (61949 487) (61950 301) + (61985 (73 772 774)) (61986 463) (61987 (78 772)) (61988 (77 772)) (61989 465) (61990 334) (61991 ( +332 774)) (61992 (332 803)) (61993 490) (61994 467) (61995 (362 774)) (61996 (89 774)) (61997 (89 772 +774)) (61998 (89 780)) (61999 (68 817)) (62000 (84 817)) (62001 7692) (62002 7716) (62003 7778) (62004 + 7788) (62005 (68 817 803)) (62113 (299 774)) (62114 464) (62115 (110 772)) (62116 (109 772)) (62117 +466) (62118 335) (62119 (333 774)) (62120 (333 803)) (62121 491) (62122 468) (62123 363) (62124 (121 +774)) (62125 (563 774)) (62126 (121 780)) (62127 7695) (62128 7791) (62129 7693) (62130 7717) (62131 +7779) (62132 7789) (62133 (7695 803)) (62241 7937) (62242 7945) (62243 7936) (62244 7944) (62245 8049) + (62246 8123) (62247 8048) (62248 8122) (62249 8118) (62250 (913 771)) (62251 7941) (62252 7949) ( +62253 7939) (62254 7949) (62255 7943) (62256 7951) (62257 7940) (62258 7948) (62259 7938) (62260 7946) + (62261 7942) (62262 7950) (62263 8115) (62264 8124) (62265 8065) (62266 8073) (62267 8064) (62268 +8072) (62269 8116) (62270 (8124 769)) (62271 8114) (62272 (8124 768)) (62273 8119) (62274 (8124 771)) +(62275 8069) (62276 8077) (62277 8067) (62278 8075) (62279 8071) (62280 8079) (62281 8068) (62282 8076 +) (62283 8066) (62284 8074) (62285 8070) (62286 8078) (62287 7953) (62288 7961) (62289 7952) (62290 +7960) (62291 8051) (62292 8137) (62293 8050) (62294 8136) (62295 7957) (62296 7965) (62297 7955) ( +62298 7963) (62299 7956) (62300 7964) (62301 7954) (62302 7962) (62303 7969) (62304 7977) (62305 7968) + (62306 7976) (62307 8053) (62308 8139) (62309 8052) (62310 8138) (62311 8134) (62312 (919 771)) ( +62313 7973) (62314 7981) (62315 7971) (62316 7979) (62317 7975) (62318 7983) (62319 8084) (62320 7980) + (62321 7970) (62322 7978) (62323 7974) (62324 7982) (62325 8131) (62326 8140) (62327 8081) (62328 +8089) (62329 8080) (62330 8088) (62331 8132) (62332 (8140 769)) (62333 8130) (62334 (8140 768)) (62369 + 8135) (62370 (8140 771)) (62371 8085) (62372 8093) (62373 8083) (62374 8091) (62375 8087) (62376 8095 +) (62377 8084) (62378 8092) (62379 8082) (62380 8090) (62381 8086) (62382 8094) (62383 7985) (62384 +7993) (62385 7984) (62386 7992) (62387 8055) (62388 8155) (62389 8054) (62390 8154) (62391 8150) ( +62392 (921 771)) (62393 7989) (62394 7997) (62395 7987) (62396 7995) (62397 7991) (62398 7999) (62399 +7988) (62400 7996) (62401 7986) (62402 7994) (62403 7990) (62404 7998) (62405 (970 769)) (62406 (938 +769)) (62407 (970 768)) (62408 (938 768)) (62409 (970 771)) (62410 (938 771)) (62411 8001) (62412 8009 +) (62413 8000) (62414 8008) (62415 8057) (62416 8185) (62417 8056) (62418 8184) (62419 8005) (62420 +8013) (62421 8003) (62422 8011) (62423 8004) (62424 8012) (62425 8002) (62426 8010) (62427 8017) ( +62428 8025) (62429 8016) (62430 (933 787)) (62431 8059) (62432 8171) (62433 8058) (62434 8170) (62435 +8166) (62436 (933 771)) (62437 8021) (62438 8029) (62439 8019) (62440 8027) (62441 8023) (62442 8031) +(62443 (971 771)) (62444 (939 771)) (62445 8020) (62446 (8171 787)) (62447 8018) (62448 (8170 787)) ( +62449 8022) (62450 (933 787 771)) (62451 (971 769)) (62452 (939 769)) (62453 (971 768)) (62454 (939 +768)) (62455 8033) (62456 8041) (62457 8032) (62458 8040) (62459 8061) (62460 8187) (62461 8060) ( +62462 8186) (62497 8182) (62498 (937 771)) (62499 8037) (62500 8045) (62501 8035) (62502 8043) (62503 +8039) (62504 8047) (62505 8036) (62506 8044) (62507 8034) (62508 8042) (62509 8038) (62510 8046) ( +62511 8179) (62512 8188) (62513 8097) (62514 8105) (62515 8096) (62516 8104) (62517 8180) (62518 (8188 + 769)) (62519 8178) (62520 (8188 768)) (62521 8183) (62522 (8188 771)) (62523 8101) (62524 8107) ( +62525 8099) (62526 8107) (62527 8103) (62528 8111) (62529 8100) (62530 8108) (62531 8098) (62532 8106) + (62533 8102) (62534 8110) (62535 8165) (62536 8172) (62537 8164) (62538 (8127 929)) (62753 65154) ( +62754 65156) (62755 65158) (62756 65160) (62757 65163) (62758 65164) (62759 65162) (62760 65166) ( +62761 65169) (62762 65170) (62763 65168) (62764 65172) (62765 65175) (62766 65176) (62767 65174) ( +62768 65179) (62769 65180) (62770 65178) (62771 65183) (62772 65184) (62773 65182) (62774 65187) ( +62775 65188) (62776 65186) (62777 65191) (62778 65192) (62779 65190) (62780 65194) (62781 65196) ( +62782 65198) (62783 65200) (62784 65203) (62785 65204) (62786 65202) (62787 65207) (62788 65208) ( +62789 65206) (62790 65211) (62791 65212) (62792 65210) (62793 65215) (62794 65216) (62795 65214) ( +62796 65219) (62797 65220) (62798 65218) (62799 65223) (62800 65224) (62801 65222) (62802 65227) ( +62803 65228) (62804 65226) (62805 65231) (62806 65232) (62807 65230) (62808 65235) (62809 65236) ( +62810 65234) (62811 65239) (62812 65240) (62813 65238) (62814 65243) (62815 65244) (62816 65242) ( +62817 65247) (62818 65248) (62819 65246) (62820 65251) (62821 65252) (62822 65250) (62823 65255) ( +62824 65256) (62825 65254) (62826 65259) (62827 65260) (62828 65258) (62829 65262) (62830 65264) ( +62831 65267) (62832 65268) (62833 65266) (62834 65269) (62835 65270) (62836 65271) (62837 65272) ( +62838 65273) (62839 65274) (62840 65275) (62841 65276) (62842 1780) (62843 1780) (62844 1781) (62845 +1782) (62882 64606) (62883 64607) (62884 64608) (62885 64609) (62886 64610) (62887 64364) (62888 64365 +) (62889 64363) (62890 1740) (62891 64562) (62956 64344) (62957 64345) (62958 64343) (62959 64380) ( +62960 64381) (62961 64379) (62962 64395) (62963 1705) (62964 64399) (62965 64404) (62966 64405) (62967 + 64403) (62968 64421) (64812 1644) (64832 978) (64848 7425) (64849 630) (64859 1013) (64860 982) ( +64861 977) (64862 1009) (64863 966) (64864 1008) (64865 7424) (64866 665) (64867 7428) (64868 7429) ( +64869 7431) (64870 42800) (64871 610) (64872 668) (64873 618) (64874 7434) (64875 7435) (64876 671) ( +64877 7437) (64878 628) (64879 7439) (64880 7448) (64881 42927) (64882 640) (64883 42801) (64884 7451) + (64885 7452) (64886 7456) (64887 7457) (64888 120) (64889 655) (64890 7458) (64891 411) (64893 945) ( +64936 8319) (64942 8316) (64944 8304) (64945 185) (64946 178) (64947 179) (64948 8308) (64949 8309) ( +64950 8310) (64951 8311) (64952 8312) (64953 8313) (64958 8314) (64959 8315) (64992 8320) (64993 8321) + (64994 8322) (64995 8323) (64996 8324) (64997 8325) (64998 8326) (64999 8327) (65000 8328) (65001 +8329) (65002 8331) (65003 8330) (65004 8332) (65008 (48 824))))) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (3333 19425 (UTF8.OUTCHARFN 3343 . 6359) (UTF8.SLUG.OUTCHARFN 6361 . 7025) ( +UTF8.INCCODEFN 7027 . 13306) (UTF8.PEEKCCODEFN 13308 . 18441) (\UTF8.BACKCCODEFN 18443 . 19423)) ( +19426 24341 (UTF16BE.OUTCHARFN 19436 . 20455) (UTF16BE.INCCODEFN 20457 . 21799) (UTF16BE.PEEKCCODEFN +21801 . 23145) (\UTF16BE.BACKCCODEFN 23147 . 24339)) (24342 29073 (UTF16LE.OUTCHARFN 24352 . 25468) ( +UTF16LE.INCCODEFN 25470 . 26599) (UTF16LE.PEEKCCODEFN 26601 . 27877) (\UTF16LE.BACKCCODEFN 27879 . +29071)) (29074 32121 (READBOM 29084 . 31153) (WRITEBOM 31155 . 32119)) (32122 36153 ( +MAKE-UNICODE-FORMATS 32132 . 36151)) (36221 40715 (UTF8.BINCODE 36231 . 38919) (\UTF8.FETCHCODE 38921 + . 40713)) (40716 46339 (UTF8.VALIDATE 40726 . 43323) (NUTF8-BYTE1-BYTES 43325 . 44062) ( +NUTF8-CODE-BYTES 44064 . 45121) (NUTF8-STRING-BYTES 45123 . 46015) (N-MCHARS 46017 . 46337)) (46403 +47677 (MTOUCODE 46413 . 46582) (UTOMCODE 46584 . 46781) (MTOUCODE? 46783 . 47162) (UTOMCODE? 47164 . +47675)) (47678 54250 (MTOUSTRING 47688 . 48271) (UTOMSTRING 48273 . 48856) (MTOUTF8STRING 48858 . +53137) (UTF8TOMSTRING 53139 . 54248)) (54308 60016 (XTOUCODE 54318 . 54836) (UTOXCODE 54838 . 55346) ( +XTOUCODE? 55348 . 56409) (UTOXCODE? 56411 . 57494) (XTOUSTRING 57496 . 58191) (UTOXSTRING 58193 . +58936) (XTOUTF8STRING 58938 . 60014)) (60017 65196 (MERGE-UNICODE-TRANSLATION-TABLES 60027 . 62789) ( +UNICODE.UNMAPPED 62791 . 65194)) (68935 69188 (UNICODE-INIT 68945 . 69186))))) +STOP diff --git a/sources/UNICODE-FORMATS.LCOM b/sources/UNICODE-FORMATS.LCOM new file mode 100644 index 00000000..5ee08dff Binary files /dev/null and b/sources/UNICODE-FORMATS.LCOM differ diff --git a/sources/XCLC-TOP-LEVEL b/sources/XCLC-TOP-LEVEL index 1bba7e7d..c4227d82 100644 --- a/sources/XCLC-TOP-LEVEL +++ b/sources/XCLC-TOP-LEVEL @@ -1,20 +1,19 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) -(IL:FILECREATED "19-Sep-2020 22:02:59"  -IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;10| 78326 +(DEFINE-FILE-INFO :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")) :READTABLE "XCL" :BASE 10) - IL:|changes| IL:|to:| (IL:FUNCTIONS START-COMPILATION) +(IL:FILECREATED "25-Feb-2026 23:03:55" IL:|{WMEDLEY}XCLC-TOP-LEVEL.;2| 78162 - IL:|previous| IL:|date:| "19-Sep-2020 21:33:34" -IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) + :EDIT-BY IL:|rmk| + :CHANGES-TO (IL:FUNCTIONS COMPILE-FILE) + + :PREVIOUS-DATE "19-Sep-2020 22:02:59" IL:|{WMEDLEY}XCLC-TOP-LEVEL.;1|) -; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1994, 2020 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-TOP-LEVELCOMS) (IL:RPAQQ IL:XCLC-TOP-LEVELCOMS ( - (IL:* IL:|;;| "Top-level entry points ") + (IL:* IL:|;;| "Top-level entry points ") (IL:STRUCTURES COMPILER-CONTEXT) (IL:VARIABLES *COMPILE-FILE-CONTEXT* *COMPILE-SCAN-CONTEXT* *COMPILE-DEFINER-CONTEXT*) @@ -33,18 +32,18 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (IL:COMS (IL:STRUCTURES ASSEMBLER-ERROR) (IL:FUNCTIONS ASSEMBLER-ERROR)) - (IL:* IL:|;;| "Reading the #, macro") + (IL:* IL:|;;| "Reading the #, macro") (IL:VARIABLES *COMPILER-IS-READING*) (IL:STRUCTURES EVAL-WHEN-LOAD) - (IL:* IL:|;;| "Support for Block Compilation") + (IL:* IL:|;;| "Support for Block Compilation") (IL:VARIABLES *BLOCK-HASH-TABLE* *BLOCKS* *CURRENT-BLOCK*) (IL:STRUCTURES BLOCK-DECL) (IL:FUNCTIONS SET-UP-BLOCK-DECLS) - (IL:* IL:|;;| "Processing of top-level forms in a file") + (IL:* IL:|;;| "Processing of top-level forms in a file") (IL:VARIABLES PASS) (IL:FUNCTIONS CONSTANT-EXPRESSION-P) @@ -60,14 +59,14 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) COMPILE-FILE-PROCESS-FUNCTION) (IL:FUNCTIONS CRACK-DEFMACRO ESTABLISH-MACRO-IN-COMPILER) - (IL:* IL:|;;| "Support for :Process-Entire-File") + (IL:* IL:|;;| "Support for :Process-Entire-File") (IL:VARIABLES *DEFERRED-FORMS* *MAKING-SECOND-PASS* *PREPROCESSING-PHASE*) (IL:FUNCTIONS COMPILE-SCAN-DECLARE\: COMPILE-SCAN-DEFINE-FILE-INFO COMPILE-SCAN-MACROLET COMPILE-SCAN-DEFINER COMPILE-SCAN-LOOSE-FORM COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS) (IL:FUNCTIONS MERGE-FIRST-FORMS) - (IL:* IL:|;;| "for compiling definers") + (IL:* IL:|;;| "for compiling definers") (IL:VARIABLES *LAP-FLG* *AUTOMATIC-SPECIAL-DECLARATIONS*) (IL:FUNCTIONS COMPILE COMPILE-DEFINER) @@ -75,11 +74,11 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (IL:FUNCTIONS COMPILE-DEFINER-DEFINER COMPILE-DEFINER-NAMED-PROGN COMPILE-DEFINER-PROCESS-FUNCTION COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS) - (IL:* IL:|;;| "Arrange for correct compiler to be used.") + (IL:* IL:|;;| "Arrange for correct compiler to be used.") (IL:PROP IL:FILETYPE IL:XCLC-TOP-LEVEL) - (IL:* IL:|;;| "Arrange for the correct makefile environment") + (IL:* IL:|;;| "Arrange for the correct makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-TOP-LEVEL))) @@ -89,9 +88,9 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (DEFSTRUCT (COMPILER-CONTEXT (:FAST-ACCESSORS T) - (:CONC-NAME NIL) - (:COPIER NIL) - (:PREDICATE NIL)) + (:CONC-NAME NIL) + (:COPIER NIL) + (:PREDICATE NIL)) SETF-SYMBOL-FUNCTION-FN DEFINEQ-FN DEFCONSTANT-FN @@ -185,51 +184,50 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (DEFVAR *LOOSE-NAME* NIL) (DEFUN COMPILE-FILE (INPUT-FILE &KEY (OUTPUT-FILE NIL) - (LAP-FILE NIL) - (ERROR-FILE NIL) - (ERRORS-TO-TERMINAL T) - (FILE-MANAGER-FORMAT NIL F-M-F-GIVEN) - (PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN) - (LOAD NIL)) + (LAP-FILE NIL) + (ERROR-FILE NIL) + (ERRORS-TO-TERMINAL T) + (FILE-MANAGER-FORMAT NIL F-M-F-GIVEN) + (PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN) + (LOAD NIL)) (IL:* IL:\; "Edited 25-Feb-2026 21:33 by rmk") -(IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.") +(IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.") -(IL:* IL:|;;;| " :Output-File") +(IL:* IL:|;;;| " :Output-File") - (IL:* IL:|;;| "The name of a file to which binary code should be written.") + (IL:* IL:|;;| "The name of a file to which binary code should be written.") - (IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'") + (IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'") -(IL:* IL:|;;;| ":Lap-File") +(IL:* IL:|;;;| ":Lap-File") - (IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.") + (IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.") - (IL:* IL:|;;| - " If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.") + (IL:* IL:|;;| + " If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.") -(IL:* IL:|;;;| ":Error-FIle") +(IL:* IL:|;;;| ":Error-FIle") - (IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'") + (IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'") -(IL:* IL:|;;;| ":Errors-To-Terminal") +(IL:* IL:|;;;| ":Errors-To-Terminal") - (IL:* IL:|;;| - "True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.") + (IL:* IL:|;;| + "True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.") -(IL:* IL:|;;;| ":File-Manager-Format") +(IL:* IL:|;;;| ":File-Manager-Format") - (IL:* IL:|;;| - "True if the file should be assumed to have been produced by the MAKEFILE function.") + (IL:* IL:|;;| "True if the file should be assumed to have been produced by the MAKEFILE function.") - (IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.") + (IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.") -(IL:* IL:|;;;| ":Process-Entire-File") +(IL:* IL:|;;;| ":Process-Entire-File") - (IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (OMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.") + (IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (OMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.") -(IL:* IL:|;;;| ":Load") +(IL:* IL:|;;;| ":Load") - (IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.") + (IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.") (LET ((*ERROR-OUTPUT* *ERROR-OUTPUT*) (*INPUT-STREAM* NIL) @@ -246,10 +244,10 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (*OUTSTANDING-LOOSE-FORMS* NIL) (*PROCESSED-FUNCTIONS* NIL) (*UNKNOWN-FUNCTIONS* NIL) - (*INPUT-FILECOMS-VARIABLE* NIL) (IL:* IL:\; - "Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.") + (*INPUT-FILECOMS-VARIABLE* NIL) (IL:* IL:\; + "Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.") - (IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.") + (IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.") (IL:SPECVARS T) (IL:LOCALVARS IL:SYSLOCALVARS) @@ -259,11 +257,11 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (IL:NLAML IL:NLAML) (IL:LAMA IL:LAMA) (IL:DONTCOMPILEFNS IL:DONTCOMPILEFNS)) - (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA - IL:NLAML IL:LAMA IL:DONTCOMPILEFNS)) + (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA IL:NLAML + IL:LAMA IL:DONTCOMPILEFNS)) (UNWIND-PROTECT (PROGN - (IL:* IL:|;;| "Set up the input stream.") + (IL:* IL:|;;| "Set up the input stream.") (LET ((PATH (OR (PROBE-FILE INPUT-FILE) (PROBE-FILE (MERGE-PATHNAMES INPUT-FILE ".lisp"))))) @@ -281,19 +279,17 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (T (ERROR "The file \"~A\" is nonexistent or cannot be read.~%" INPUT-FILE )))) - (IL:* IL:|;;| "Set up the FASL output stream.") + (IL:* IL:|;;| "Set up the FASL output stream.") (SETQ FASL-PATHNAME (COND (OUTPUT-FILE (PATHNAME OUTPUT-FILE)) (T (MAKE-PATHNAME :TYPE - (STRING (LOCALLY (DECLARE (SPECIAL - IL:FASL.EXT) - ) + (STRING (LOCALLY (DECLARE (SPECIAL IL:FASL.EXT)) IL:FASL.EXT)) :VERSION :NEWEST :DEFAULTS *INPUT-FILENAME*)))) (SETQ *FASL-HANDLE* (FASL:OPEN-FASL-HANDLE FASL-PATHNAME)) - (IL:* IL:|;;| "Set up the LAP stream.") + (IL:* IL:|;;| "Set up the LAP stream.") (WHEN LAP-FILE (SETQ *LAP-STREAM* (OPEN (IF (EQ LAP-FILE T) @@ -302,7 +298,7 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) LAP-FILE) :DIRECTION :OUTPUT))) - (IL:* IL:|;;| "Set up the error output stream.") + (IL:* IL:|;;| "Set up the error output stream.") (WHEN ERROR-FILE (SETQ ERROR-FILE-STREAM (OPEN (IF (EQ ERROR-FILE T) @@ -317,8 +313,8 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) *ERROR-OUTPUT*) ERROR-FILE-STREAM)) - (IL:* IL:|;;| - "Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.") + (IL:* IL:|;;| + "Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.") (IF (NOT F-M-F-GIVEN) (SETQ FILE-MANAGER-FORMAT (EQ (IL:SKIPSEPRCODES *INPUT-STREAM* IL:FILERDTBL) @@ -326,22 +322,22 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (IF (NOT P-E-F-GIVEN) (SETQ PROCESS-ENTIRE-FILE FILE-MANAGER-FORMAT)) - (IL:* IL:|;;| "Pick the right readtable and do the compilation.") + (IL:* IL:|;;| "Pick the right readtable and do the compilation.") (IL:WITH-READER-ENVIRONMENT (IF FILE-MANAGER-FORMAT - IL:*OLD-INTERLISP-READ-ENVIRONMENT* + IL:*DEFINE-FILE-INFO-ENV* IL:*COMMON-LISP-READ-ENVIRONMENT*) (START-COMPILATION) (PROCESS-FORMS PROCESS-ENTIRE-FILE) (FINISH-COMPILATION) (SETQ COMPILATION-SUCCEEDED T) - (IL:* IL:|;;| - "Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))") + (IL:* IL:|;;| + "Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))") FASL-PATHNAME)) - (IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.") + (IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.") (IF (STREAMP *INPUT-STREAM*) (CLOSE *INPUT-STREAM*)) @@ -352,9 +348,9 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (IF (STREAMP *LAP-STREAM*) (CLOSE *LAP-STREAM*))))) -(DEFUN START-COMPILATION () (IL:* IL:\; "Edited 19-Sep-2020 22:02 by rmk:") +(DEFUN START-COMPILATION () (IL:* IL:\; "Edited 19-Sep-2020 22:02 by rmk:") -(IL:* IL:|;;;| "Write out banners on the various output files.") +(IL:* IL:|;;;| "Write out banners on the various output files.") (FLET ((DATE-STRING (UNIV-TIME) (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOUR DATE MONTH YEAR DAY-OF-WEEK) @@ -370,7 +366,7 @@ IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>XCLC-TOP-LEVEL.;9|) (LET ((FASL-STREAM (FASL:BEGIN-TEXT *FASL-HANDLE*)) (FILECREATED (IL:READ-FILECREATED *INPUT-STREAM*))) - (IL:* IL:|;;| "RMK: This had a complicated format, didn't work, so I reverted to printout. PRIN3 to stop wrap around") + (IL:* IL:|;;| "RMK: This had a complicated format, didn't work, so I reverted to printout. PRIN3 to stop wrap around") (IL:PRINTOUT FASL-STREAM "XCL Compiler output for source file " IL:\# (IL:PRIN3 (OR (CADDR FILECREATED) @@ -395,9 +391,9 @@ LAP file created ~A.~%~%" (DEFUN FINISH-COMPILATION () -(IL:* IL:|;;;| "Clean up after the compilation.") +(IL:* IL:|;;;| "Clean up after the compilation.") - (IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.") + (IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.") (LOCALLY (DECLARE (IL:GLOBALVARS IL:NOTCOMPILEDFILES)) (SETQ IL:NOTCOMPILEDFILES (REMOVE (INTERN (LET ((TYPE (PATHNAME-TYPE *INPUT-FILENAME*))) @@ -411,13 +407,13 @@ LAP file created ~A.~%~%" "INTERLISP") IL:NOTCOMPILEDFILES))) - (IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.") + (IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.") (WARN-ABOUT-UNKNOWN-FUNCTIONS)) (DEFUN SCAN-ONE-FORM (FORM COMPILER-CONTEXT) - (IL:* IL:|;;| "Assumes sedit like comments have already been stripped ") + (IL:* IL:|;;| "Assumes sedit like comments have already been stripped ") (IF (ATOM FORM) FORM @@ -433,8 +429,7 @@ LAP file created ~A.~%~%" (CERROR "Ignore this DEFMACRO." "~S is not a legal macro name." NAME) ) (T (UNLESS *MAKING-SECOND-PASS* - (ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO - FORM))) + (ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO FORM))) (SCAN-ONE-FORM (OPTIMIZE-AND-MACROEXPAND-1 FORM) COMPILER-CONTEXT))))) ((EVAL-WHEN) (IF (NOT (AND (LISTP (SECOND FORM)) @@ -476,12 +471,11 @@ LAP file created ~A.~%~%" VALUE))))))) ((DEFCONSTANT) (COMPILER-APPLY DEFCONSTANT COMPILER-CONTEXT FORM)) ((IL:DECLARE\:) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT FORM)) - ((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT - FORM)) + ((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT FORM)) ((IL:DEFINEQ) (COMPILER-APPLY IL:DEFINEQ COMPILER-CONTEXT FORM)) ((IL:DEFINE-FILE-INFO) (COMPILER-APPLY IL:DEFINE-FILE-INFO COMPILER-CONTEXT FORM)) ((MAKE-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT EXPORT UNEXPORT USE-PACKAGE - UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT + UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT FORM)) ((PROCLAIM) (COMPILER-APPLY PROCLAIM COMPILER-CONTEXT FORM)) ((COMPILER-LET) (COMPILER-APPLY COMPILER-LET COMPILER-CONTEXT FORM)) @@ -522,11 +516,11 @@ LAP file created ~A.~%~%" (DOLIST (PAIR (UNKNOWN-FUNCTION-WARNING-CALL-LIST CONDITION)) (FORMAT T " ~S -- called from " (CAR PAIR)) - (IL:* IL:|;;| - "I almost used this hairy thing, but FORMAT is too slow... Aren't you glad?") + (IL:* IL:|;;| + "I almost used this hairy thing, but FORMAT is too slow... Aren't you glad?") - (IL:* IL:|;;| - "\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"") + (IL:* IL:|;;| + "\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"") (COND ((NULL (CDR PAIR)) @@ -563,32 +557,32 @@ LAP file created ~A.~%~%" (DEFUN WARN-ABOUT-UNKNOWN-FUNCTIONS () -(IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.") +(IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.") (WHEN (NOT (NULL *UNKNOWN-FUNCTIONS*)) (WARN 'UNKNOWN-FUNCTION-WARNING :CALL-LIST *UNKNOWN-FUNCTIONS*))) (DEFVAR *PROCESSED-FUNCTIONS* -(IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation. Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.") +(IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation. Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.") ) (DEFVAR *UNKNOWN-FUNCTIONS* -(IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation. Actually, it's an AList mapping the unknown function to the list of functions in which it is called. Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.") +(IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation. Actually, it's an AList mapping the unknown function to the list of functions in which it is called. Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.") ) (DEFVAR *CURRENT-FUNCTION* -(IL:* IL:|;;;| "The name of the unit currently being compiled.") +(IL:* IL:|;;;| "The name of the unit currently being compiled.") ) (DEFINE-CONDITION ASSEMBLER-ERROR -(IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.") +(IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.") (ERROR) (FORMAT-STRING FORMAT-ARGUMENTS) @@ -620,33 +614,33 @@ LAP file created ~A.~%~%" (DEFVAR *BLOCK-HASH-TABLE* NIL -(IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function. Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.") +(IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function. Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.") ) (DEFVAR *BLOCKS* NIL -(IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file. This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)") +(IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file. This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)") ) (DEFVAR *CURRENT-BLOCK* NIL -(IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function. This is NIL if the function is not a part of any block.") +(IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function. This is NIL if the function is not a part of any block.") ) (DEFSTRUCT (BLOCK-DECL (:INLINE NIL)) -(IL:* IL:|;;;| -"A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.") +(IL:* IL:|;;;| +"A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.") -(IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.") +(IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.") -(IL:* IL:|;;;| -"FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.") +(IL:* IL:|;;;| +"FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.") -(IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.") +(IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.") NAME FN-NAME-MAP @@ -657,7 +651,7 @@ LAP file created ~A.~%~%" (DEFUN SET-UP-BLOCK-DECLS (DECLS) -(IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.") +(IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.") (LET ((HASH-TABLE (MAKE-HASH-TABLE))) (DOLIST (DECL DECLS) @@ -670,9 +664,9 @@ LAP file created ~A.~%~%" (NOT-RENAMED-FNS (CONS BLOCK-NAME (UNION IL:RETFNS IL:NOLINKFNS))) (FNS NIL)) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS - IL:NOLINKFNS)) + IL:NOLINKFNS)) - (IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.") + (IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.") (COND ((NULL BLOCK-NAME) @@ -681,7 +675,7 @@ LAP file created ~A.~%~%" (T (SETQ IL:LOCALVARS T) (SETQ IL:SPECVARS IL:SYSSPECVARS))) - (IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.") + (IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.") (DOLIST (ITEM (CDR DECL)) (COND @@ -709,8 +703,8 @@ LAP file created ~A.~%~%" "DONTCOMPILEFNS is not supported in BLOCK: declarations." )) ((IL:BLKAPPLYFNS IL:NOLINKFNS IL:RETFNS IL:ENTRIES) - (IL:* IL:\; - "These functions should not be renamed, according to BYTEBLOCKCOMPILE2.") + (IL:* IL:\; + "These functions should not be renamed, according to BYTEBLOCKCOMPILE2.") (WHEN (CONSP (CDR ITEM)) (SETQ NOT-RENAMED-FNS (APPEND (CDR ITEM) NOT-RENAMED-FNS)))) @@ -729,14 +723,14 @@ LAP file created ~A.~%~%" IL:GLOBALVARS) (LET* ((BLOCK-NAME-STRING (STRING BLOCK-NAME)) (BLOCK-PACKAGE (SYMBOL-PACKAGE BLOCK-NAME))) - (UNLESS (NULL BLOCK-NAME) (IL:* IL:\; - "NIL blocks don't do renaming.") + (UNLESS (NULL BLOCK-NAME) (IL:* IL:\; + "NIL blocks don't do renaming.") (SETF (BLOCK-DECL-FN-NAME-MAP BD) (IL:|for| FN IL:|in| (NSET-DIFFERENCE FNS NOT-RENAMED-FNS) IL:|collect| (CONS FN (INTERN (CONCATENATE 'STRING "\\" - BLOCK-NAME-STRING "/" - (STRING FN)) - BLOCK-PACKAGE)))))))) + BLOCK-NAME-STRING "/" + (STRING FN)) + BLOCK-PACKAGE)))))))) HASH-TABLE)) @@ -761,8 +755,8 @@ LAP file created ~A.~%~%" (RETURN NIL)))))))) (DEFUN COMPILE-AND-DUMP (NAME DEFN KIND) - (LET ((*CURRENT-BLOCK* NIL) (IL:* IL:\; - "So that we aren't dependent upon the top-level binding.") + (LET ((*CURRENT-BLOCK* NIL) (IL:* IL:\; + "So that we aren't dependent upon the top-level binding.") ) (COND ((AND (SYMBOLP NAME) @@ -783,7 +777,7 @@ LAP file created ~A.~%~%" (IL:LOCALFREEVARS (BLOCK-DECL-LOCALFREEVARS *CURRENT-BLOCK*)) (IL:GLOBALVARS (BLOCK-DECL-GLOBALVARS *CURRENT-BLOCK*))) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS - IL:GLOBALVARS)) + IL:GLOBALVARS)) (COMPILE-AND-DUMP-1 NEW-NAME DEFN KIND))))))) (T (COMPILE-AND-DUMP-1 NAME DEFN KIND))))) @@ -824,14 +818,14 @@ LAP file created ~A.~%~%" (SYMBOL-FUNCTION NAME))) (SETF (SYMBOL-FUNCTION NAME) (D-ASSEM:INTERN-DCODE DCODE))) - (:ONE-SHOT (LET ((IL:FILEPKGFLG NIL)) (IL:* IL:\; - "so that things don't get marked as changed when you execute the one-shot.") + (:ONE-SHOT (LET ((IL:FILEPKGFLG NIL)) (IL:* IL:\; + "so that things don't get marked as changed when you execute the one-shot.") (DECLARE (SPECIAL IL:FILEPKGFLG)) (FUNCALL (D-ASSEM:INTERN-DCODE DCODE)))))))) (DEFUN COMPILE-ONE-LAMBDA (NAME DEFN) -(IL:* IL:|;;;| "Return a LAP function for the given function definition. NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.") +(IL:* IL:|;;;| "Return a LAP function for the given function definition. NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.") (LET ((*CONTEXT* *NULL-CONTEXT*) (*AUTOMATIC-SPECIAL-DECLARATIONS* NIL)) @@ -844,9 +838,9 @@ LAP file created ~A.~%~%" LAP-CODE))) (DEFUN OPTIMIZE-AND-MACROEXPAND (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*) - (CONTEXT *CONTEXT*)) + (CONTEXT *CONTEXT*)) -(IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.") +(IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.") (PROG (NEW-FORM CHANGED-P) (MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P) @@ -861,9 +855,9 @@ LAP file created ~A.~%~%" (RETURN (VALUES NEW-FORM T))))) (DEFUN OPTIMIZE-AND-MACROEXPAND-1 (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*) - (CONTEXT *CONTEXT*)) + (CONTEXT *CONTEXT*)) -(IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR. Return two values like MACROEXPAND-1.") +(IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR. Return two values like MACROEXPAND-1.") (LET ((*NEW-COMPILER-IS-EXPANDING* T)) (COND @@ -871,23 +865,23 @@ LAP file created ~A.~%~%" (NOT (SYMBOLP (CAR FORM)))) (VALUES FORM NIL)) (T - (IL:* IL:|;;| "Check for compiler optimizers.") + (IL:* IL:|;;| "Check for compiler optimizers.") (LET ((OPTIMIZERS (OPTIMIZER-LIST (CAR FORM)))) (WHEN (AND (NOT (NULL OPTIMIZERS)) (NOT (ENV-FBOUNDP ENVIRONMENT (CAR FORM) :LEXICAL-ONLY T)) (NOT (ENV-INLINE-DISALLOWED ENVIRONMENT (CAR FORM)))) - (IL:* IL:\; - "Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.") + (IL:* IL:\; + "Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.") (DOLIST (OPT-FN OPTIMIZERS) (LET ((RESULT (FUNCALL OPT-FN FORM ENVIRONMENT CONTEXT))) (UNLESS (OR (EQ RESULT 'PASS) (EQ RESULT 'IL:IGNOREMACRO) - (EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.") + (EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.") (RETURN-FROM OPTIMIZE-AND-MACROEXPAND-1 (VALUES RESULT T))))))) - (IL:* IL:|;;| "Check for a macro expansion function.") + (IL:* IL:|;;| "Check for a macro expansion function.") (MACROEXPAND-1 FORM ENVIRONMENT))))) @@ -919,47 +913,45 @@ LAP file created ~A.~%~%" (IL:RPAQQ (IF (EQ (SECOND FORM) *INPUT-FILECOMS-VARIABLE*) - (IL:* IL:|;;| - "Don't remove comments from file coms") + (IL:* IL:|;;| "Don't remove comments from file coms") FORM (REMOVE-COMMENTS FORM))) (IL:DEFCLASS - (IL:* IL:|;;| - "Don't remove comments from LOOPS DEFCLASS forms") + (IL:* IL:|;;| "Don't remove comments from LOOPS DEFCLASS forms") FORM) (IL:DATATYPE - (IL:* IL:|;;| "Don't remove comments from record declarations") + (IL:* IL:|;;| "Don't remove comments from record declarations") FORM) (IL:RECORD - (IL:* IL:|;;| "Don't remove comments from record declarations") + (IL:* IL:|;;| "Don't remove comments from record declarations") FORM) (IL:BLOCKRECORD - (IL:* IL:|;;| "Don't remove comments from record declarations") + (IL:* IL:|;;| "Don't remove comments from record declarations") FORM) (IL:DECLARE\: - (IL:* IL:|;;| - "Process each form inside this as though it were at top-level") + (IL:* IL:|;;| + "Process each form inside this as though it were at top-level") (IL:FOR X IL:IN FORM IL:COLLECT (COND - ((NOT (CONSP X)) - X) - (T (CASE (CAR X) - (IL:DEFCLASS X) - (IL:DATATYPE X) - (IL:RECORD X) - (IL:BLOCKRECORD X) - (OTHERWISE (REMOVE-COMMENTS X))))))) + ((NOT (CONSP X)) + X) + (T (CASE (CAR X) + (IL:DEFCLASS X) + (IL:DATATYPE X) + (IL:RECORD X) + (IL:BLOCKRECORD X) + (OTHERWISE (REMOVE-COMMENTS X))))))) (OTHERWISE (REMOVE-COMMENTS FORM))))) (SCAN-ONE-FORM NEW-FORM *COMPILE-SCAN-CONTEXT*)) (SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*))) @@ -988,9 +980,10 @@ LAP file created ~A.~%~%" (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM)) (LET ((NAME (SECOND NAME-FORM)) (DEFINITION (SECOND FUNCTION-FORM))) - (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a" - (CAR DEFINITION) - NAME) + (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a" (CAR + DEFINITION + ) + NAME) NAME DEFINITION))) (T (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM))))) @@ -1002,8 +995,8 @@ LAP file created ~A.~%~%" (SECOND DEFN) (CONS 'IL:LAMBDA (CDR DEFN))))) (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~s" - (CAR REAL-DEFN) - (CAR DEFN)) + (CAR REAL-DEFN) + (CAR DEFN)) (CAR DEFN) REAL-DEFN))) (CDR FORM))) @@ -1019,10 +1012,10 @@ LAP file created ~A.~%~%" VALUE) (ENV-DECLARE-A-GLOBAL (FIND-TOP-ENVIRONMENT *ENVIRONMENT*) SYMBOL))) - (SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL - (LOCALLY (DECLARE (GLOBAL ,SYMBOL)) - ,(EXPAND-DEFINER 'DEFCONSTANT (REMOVE-COMMENTS FORM) - *ENVIRONMENT*))) + (SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL (LOCALLY (DECLARE (GLOBAL ,SYMBOL)) + ,(EXPAND-DEFINER 'DEFCONSTANT + (REMOVE-COMMENTS FORM) + *ENVIRONMENT*))) COMPILER-CONTEXT))) (DEFUN COMPILE-FILE-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T)) @@ -1044,9 +1037,8 @@ LAP file created ~A.~%~%" ((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((IL:FIRST) ) ((IL:NOTFIRST IL:COMPILERVARS) ) - (OTHERWISE (COMPILER-MESSAGE - "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL)))) - ) + (OTHERWISE (COMPILER-MESSAGE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" + (CAR TAIL))))) ((EQ 'IL:DECLARE\: (CAR (CAR TAIL))) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL) DOCOPY)) @@ -1068,11 +1060,13 @@ LAP file created ~A.~%~%" IL:FILECREATEDLOC) (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC)) (EVAL FORM)) - (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT - `(LET ((*STANDARD-INPUT* (OPEN "{Null}" :DIRECTION :OUTPUT)) - IL:FILECREATEDLOC) - (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC)) - ,FORM)) + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT `(LET ((*STANDARD-INPUT* (OPEN "{Null}" + :DIRECTION + :OUTPUT)) + IL:FILECREATEDLOC) + (DECLARE (SPECIAL *STANDARD-INPUT* + IL:FILECREATEDLOC)) + ,FORM)) (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)) (DEFUN COMPILE-FILE-PACKAGE-FORM (COMPILER-CONTEXT FORM) @@ -1229,7 +1223,7 @@ LAP file created ~A.~%~%" (DEFUN CRACK-DEFMACRO (FORM) -(IL:* IL:|;;;| "FORM is a call to DEFMACRO. Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.") +(IL:* IL:|;;;| "FORM is a call to DEFMACRO. Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.") (LET ((NAME (SECOND FORM)) (ARG-LIST (THIRD FORM)) @@ -1245,7 +1239,7 @@ LAP file created ~A.~%~%" (DEFUN ESTABLISH-MACRO-IN-COMPILER (NAME EXPN-FN) -(IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.") +(IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.") (ENV-BIND-FUNCTION (FIND-TOP-ENVIRONMENT *ENVIRONMENT*) NAME :MACRO EXPN-FN)) @@ -1261,18 +1255,18 @@ LAP file created ~A.~%~%" (DEFVAR *MAKING-SECOND-PASS* NIL -(IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.") +(IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.") ) (DEFVAR *PREPROCESSING-PHASE* NIL -(IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.") +(IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.") ) (DEFUN COMPILE-SCAN-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T) - (DOFIRST NIL)) + (DOFIRST NIL)) (LET ((FIRST-FORMS NIL) (IL:DFNFLG IL:DFNFLG) (*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*)) @@ -1295,9 +1289,8 @@ LAP file created ~A.~%~%" ((IL:FIRST) (SETQ DOFIRST T)) ((IL:NOTFIRST) (SETQ DOFIRST NIL)) ((IL:COMPILERVARS) (SETQ IL:DFNFLG T)) - (OTHERWISE (COMPILER-MESSAGE - "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL)))) - ) + (OTHERWISE (COMPILER-MESSAGE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" + (CAR TAIL))))) ((EQ 'IL:DECLARE\: (CAR (CAR TAIL))) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL) DOCOPY DOFIRST)) @@ -1416,7 +1409,7 @@ LAP file created ~A.~%~%" (*UNKNOWN-FUNCTIONS* NIL) (*CURRENT-FUNCTION* NAME) (*INPUT-STREAM* NIL) - (*LAP-FLG* LAP) (IL:* IL:\; "FXAR-111") + (*LAP-FLG* LAP) (IL:* IL:\; "FXAR-111") (COMPILED-DEFN (RAW-COMPILE NAME DEFN))) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (WARN-ABOUT-UNKNOWN-FUNCTIONS) @@ -1516,7 +1509,7 @@ LAP file created ~A.~%~%" (LET ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*)) COMPILED-DEFN) - (IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:") + (IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:") (SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*) *HOST-ARCHITECTURE*) @@ -1531,20 +1524,20 @@ LAP file created ~A.~%~%" (DEFUN COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT) - (IL:* IL:|;;| - "Compile any outstanding loose forms in the context of a structure definition being compiled") + (IL:* IL:|;;| + "Compile any outstanding loose forms in the context of a structure definition being compiled") (WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*)) (LET* ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*)) COMPILED-DEFN) - (IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:") + (IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:") (SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*) *HOST-ARCHITECTURE*) (SETQ COMPILED-DEFN (RAW-COMPILE *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE *OUTSTANDING-LOOSE-FORMS* - )))) + )))) (SETQ *OUTSTANDING-LOOSE-FORMS* NIL) (FUNCALL COMPILED-DEFN)))) @@ -1561,36 +1554,37 @@ LAP file created ~A.~%~%" (IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE - (DEFPACKAGE "COMPILER" - (:USE "LISP" "XCL")))) -(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 - 1994 2020)) + (DEFPACKAGE "COMPILER" (:USE "LISP" + "XCL")))) (IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL (7050 7194 (COMPILER-ERROR 7050 . 7194)) (8749 17618 (COMPILE-FILE 8749 . 17618)) ( -17620 20017 (START-COMPILATION 17620 . 20017)) (20019 21292 (FINISH-COMPILATION 20019 . 21292)) (21294 - 26872 (SCAN-ONE-FORM 21294 . 26872)) (26874 27071 (FUNCTION-P 26874 . 27071)) (28998 29614 ( -CHECK-FOR-UNKNOWN-FUNCTION 28998 . 29614)) (29616 29870 (WARN-ABOUT-UNKNOWN-FUNCTIONS 29616 . 29870)) -(31345 31475 (ASSEMBLER-ERROR 31345 . 31475)) (33238 38333 (SET-UP-BLOCK-DECLS 33238 . 38333)) (38481 -39021 (CONSTANT-EXPRESSION-P 38481 . 39021)) (39023 40665 (COMPILE-AND-DUMP 39023 . 40665)) (40667 -42619 (COMPILE-AND-DUMP-1 40667 . 42619)) (42621 43312 (COMPILE-ONE-LAMBDA 42621 . 43312)) (43314 -44035 (OPTIMIZE-AND-MACROEXPAND 43314 . 44035)) (44037 45685 (OPTIMIZE-AND-MACROEXPAND-1 44037 . 45685 -)) (45893 49547 (PROCESS-FORMS 45893 . 49547)) (49549 49684 (MAYBE-REMOVE-COMMENTS 49549 . 49684)) ( -49686 50599 (COMPILE-FILE-SETF-SYMBOL-FUNCTION 49686 . 50599)) (50601 51400 (COMPILE-FILE-DEFINEQ -50601 . 51400)) (51402 52329 (COMPILE-FILE-DEFCONSTANT 51402 . 52329)) (52331 54264 ( -COMPILE-FILE-DECLARE\: 52331 . 54264)) (54266 54828 (COMPILE-FILE-DEFINE-FILE-INFO 54266 . 54828)) ( -54830 55074 (COMPILE-FILE-PACKAGE-FORM 54830 . 55074)) (55076 57795 (COMPILE-FILE-PROCLAMATION 55076 - . 57795)) (57797 59208 (COMPILE-FILE-COMPILER-LET 57797 . 59208)) (59210 59890 (COMPILE-FILE-MACROLET - 59210 . 59890)) (59892 60882 (COMPILE-FILE-DEFINER 59892 . 60882)) (60884 61812 ( -COMPILE-FILE-NAMED-PROGN 60884 . 61812)) (61814 62464 (COMPILE-FILE-OUTSTANDING-LOOSE-FORMS 61814 . -62464)) (62466 62608 (COMPILE-FILE-LOOSE-FORM 62466 . 62608)) (62610 62929 ( -COMPILE-FILE-PROCESS-FUNCTION 62610 . 62929)) (62931 63608 (CRACK-DEFMACRO 62931 . 63608)) (63610 -63893 (ESTABLISH-MACRO-IN-COMPILER 63610 . 63893)) (64587 66834 (COMPILE-SCAN-DECLARE\: 64587 . 66834) -) (66836 67198 (COMPILE-SCAN-DEFINE-FILE-INFO 66836 . 67198)) (67200 68114 (COMPILE-SCAN-MACROLET -67200 . 68114)) (68116 68751 (COMPILE-SCAN-DEFINER 68116 . 68751)) (68753 68886 ( -COMPILE-SCAN-LOOSE-FORM 68753 . 68886)) (68888 68962 (COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS 68888 . -68962)) (68964 69412 (MERGE-FIRST-FORMS 68964 . 69412)) (69537 71788 (COMPILE 69537 . 71788)) (71790 -72043 (COMPILE-DEFINER 71790 . 72043)) (72045 73084 (COMPILE-FORM 72045 . 73084)) (73086 73958 ( -RAW-COMPILE 73086 . 73958)) (73960 75059 (COMPILE-DEFINER-DEFINER 73960 . 75059)) (75061 75899 ( -COMPILE-DEFINER-NAMED-PROGN 75061 . 75899)) (75901 76736 (COMPILE-DEFINER-PROCESS-FUNCTION 75901 . -76736)) (76738 77694 (COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS 76738 . 77694))))) + (IL:FILEMAP (NIL (6860 7004 (COMPILER-ERROR 6860 . 7004)) (7006 7507 (COMPILER-APPLY 7006 . 7507)) ( +8559 17297 (COMPILE-FILE 8559 . 17297)) (17299 19704 (START-COMPILATION 17299 . 19704)) (19706 20979 ( +FINISH-COMPILATION 19706 . 20979)) (20981 26437 (SCAN-ONE-FORM 20981 . 26437)) (26439 26636 ( +FUNCTION-P 26439 . 26636)) (26638 26760 (COMPILER-MESSAGE 26638 . 26760)) (26762 26850 ( +COMPILING-MESSAGE 26762 . 26850)) (26852 26919 (DONE-MESSAGE 26852 . 26919)) (28567 29183 ( +CHECK-FOR-UNKNOWN-FUNCTION 28567 . 29183)) (29185 29439 (WARN-ABOUT-UNKNOWN-FUNCTIONS 29185 . 29439)) +(30914 31044 (ASSEMBLER-ERROR 30914 . 31044)) (32807 37890 (SET-UP-BLOCK-DECLS 32807 . 37890)) (38038 +38578 (CONSTANT-EXPRESSION-P 38038 . 38578)) (38580 40220 (COMPILE-AND-DUMP 38580 . 40220)) (40222 +42176 (COMPILE-AND-DUMP-1 40222 . 42176)) (42178 42869 (COMPILE-ONE-LAMBDA 42178 . 42869)) (42871 +43588 (OPTIMIZE-AND-MACROEXPAND 42871 . 43588)) (43590 45236 (OPTIMIZE-AND-MACROEXPAND-1 43590 . 45236 +)) (45238 45442 (EXPAND-DEFINER 45238 . 45442)) (45444 48977 (PROCESS-FORMS 45444 . 48977)) (48979 +49114 (MAYBE-REMOVE-COMMENTS 48979 . 49114)) (49116 50132 (COMPILE-FILE-SETF-SYMBOL-FUNCTION 49116 . +50132)) (50134 50925 (COMPILE-FILE-DEFINEQ 50134 . 50925)) (50927 51935 (COMPILE-FILE-DEFCONSTANT +50927 . 51935)) (51937 53854 (COMPILE-FILE-DECLARE\: 51937 . 53854)) (53856 54795 ( +COMPILE-FILE-DEFINE-FILE-INFO 53856 . 54795)) (54797 55041 (COMPILE-FILE-PACKAGE-FORM 54797 . 55041)) +(55043 57762 (COMPILE-FILE-PROCLAMATION 55043 . 57762)) (57764 59175 (COMPILE-FILE-COMPILER-LET 57764 + . 59175)) (59177 59857 (COMPILE-FILE-MACROLET 59177 . 59857)) (59859 60849 (COMPILE-FILE-DEFINER +59859 . 60849)) (60851 61779 (COMPILE-FILE-NAMED-PROGN 60851 . 61779)) (61781 62431 ( +COMPILE-FILE-OUTSTANDING-LOOSE-FORMS 61781 . 62431)) (62433 62575 (COMPILE-FILE-LOOSE-FORM 62433 . +62575)) (62577 62896 (COMPILE-FILE-PROCESS-FUNCTION 62577 . 62896)) (62898 63575 (CRACK-DEFMACRO 62898 + . 63575)) (63577 63860 (ESTABLISH-MACRO-IN-COMPILER 63577 . 63860)) (64554 66781 ( +COMPILE-SCAN-DECLARE\: 64554 . 66781)) (66783 67145 (COMPILE-SCAN-DEFINE-FILE-INFO 66783 . 67145)) ( +67147 68061 (COMPILE-SCAN-MACROLET 67147 . 68061)) (68063 68698 (COMPILE-SCAN-DEFINER 68063 . 68698)) +(68700 68833 (COMPILE-SCAN-LOOSE-FORM 68700 . 68833)) (68835 68909 ( +COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS 68835 . 68909)) (68911 69359 (MERGE-FIRST-FORMS 68911 . 69359)) ( +69484 71735 (COMPILE 69484 . 71735)) (71737 71990 (COMPILE-DEFINER 71737 . 71990)) (71992 73031 ( +COMPILE-FORM 71992 . 73031)) (73033 73905 (RAW-COMPILE 73033 . 73905)) (73907 75006 ( +COMPILE-DEFINER-DEFINER 73907 . 75006)) (75008 75846 (COMPILE-DEFINER-NAMED-PROGN 75008 . 75846)) ( +75848 76683 (COMPILE-DEFINER-PROCESS-FUNCTION 75848 . 76683)) (76685 77639 ( +COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS 76685 . 77639))))) IL:STOP diff --git a/sources/XCLC-TOP-LEVEL.DFASL b/sources/XCLC-TOP-LEVEL.DFASL index 8e34de38..8ad70f81 100644 Binary files a/sources/XCLC-TOP-LEVEL.DFASL and b/sources/XCLC-TOP-LEVEL.DFASL differ